[commit: ghc] cardinality: some enhancements (b6e84e7)

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : cardinality

http://hackage.haskell.org/trac/ghc/changeset/b6e84e771c6d1e2a7e995c237ea232ef39125a7f

>---------------------------------------------------------------

commit b6e84e771c6d1e2a7e995c237ea232ef39125a7f
Author: Ilya Sergey <[email protected]>
Date:   Tue Sep 4 18:41:56 2012 +0100

    some enhancements

>---------------------------------------------------------------

 compiler/basicTypes/Demand.lhs |   20 ++++----------------
 compiler/stranal/DmdAnal.lhs   |    5 +++--
 2 files changed, 7 insertions(+), 18 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index e512ef5..7ac53a9 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -308,8 +308,8 @@ instance LatticeLike AbsDmd where
      | length ux1 == length ux2    = absProd Many $ zipWith both ux1 ux2
   -- is it correct? -- explain! 
   -- possibly, wrong...
-  --both (UCall _ u1) (UCall _ u2)   = absCall Many (u1 `lub` u2)
-  both (UCall _ u1) (UCall _ u2)   = absCall Many (u1 `both` u2)
+  both (UCall _ u1) (UCall _ u2)   = absCall Many (u1 `lub` u2)
+  -- both (UCall _ u1) (UCall _ u2)   = absCall Many (u1 `both` u2)
   both _ _                         = top
 
 -- utility functions
@@ -325,7 +325,7 @@ markAsUsed Abs         = Abs
 markAsUsed (Used _)    = Used Many
 markAsUsed (UHead _)   = UHead Many
 markAsUsed (UProd _ x) = UProd Many $ map markAsUsed x
-markAsUsed (UCall _ x) = UCall Many $ markAsUsed x
+markAsUsed (UCall _ x) = markAsUsed x
 
 seqAbsDmd :: AbsDmd -> ()
 seqAbsDmd (Used c)     = c `seq` ()
@@ -381,18 +381,6 @@ instance Binary AbsDmd where
                       ux <- get bh
                       return $ absProd c ux
 
-    -- get  bh = do
-    --         h <- getByte bh
-    --         case h of 
-    --           0 -> return Abs       
-    --           1 -> return Used Many
-    --           2 -> return UHead Many
-    --           3 -> do u  <- get bh
-    --                   return $ absCall Many u  
-    --           _ -> do ux <- get bh
-    --                   return $ absProd Many ux
-
-
 -- Splitting polymorphic demands
 replicateAbsDmd :: Int -> AbsDmd -> [AbsDmd]
 replicateAbsDmd n Abs          = replicate n Abs
@@ -533,7 +521,7 @@ should be: <L,C(U(AU))>m
 
 mkCallDmd :: JointDmd -> JointDmd
 mkCallDmd (JD {strd = d, absd = a}) 
-          = mkJointDmd (strCall d) (absCall Many a)
+          = mkJointDmd (strCall d) (absCall One a)
 
 -- TODO: think how to peel
 peelCallDmd :: JointDmd -> Maybe JointDmd
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index 4eb8a79..394110a 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -393,10 +393,10 @@ dmdTransform env var dmd
 
 ------ 	LOCAL LET/REC BOUND THING
   | Just (StrictSig dmd_ty, top_lvl) <- lookupSigEnv env var
-  = pprTrace "dmdTransform-Local" (vcat [ppr var, ppr dmd, ppr dmd_ty]) $
+  = -- pprTrace "dmdTransform-Local" (vcat [ppr var, ppr dmd, ppr dmd_ty]) $
     let
 	fn_ty | dmdTypeDepth dmd_ty <= call_depth = dmd_ty 
-	      | otherwise   		          = deferType dmd_ty
+	      | otherwise   		          = (deferType . markAsUsedType) dmd_ty
 	-- NB: it's important to use deferType, and not just return topDmdType
 	-- Consider	let { f x y = p + x } in f 1
 	-- The application isn't saturated, but we must nevertheless propagate 
@@ -509,6 +509,7 @@ dmdAnalRhs top_lvl rec_flag env (id, rhs)
  where
   arity		     = idArity id   -- The idArity should be up to date
 				    -- The simplifier was run just beforehand
+  
   (rhs_dmd_ty, rhs') = dmdAnal env (vanillaCall arity) rhs
   (lazy_fv, sig_ty)  = WARN( arity /= dmdTypeDepth rhs_dmd_ty && not (exprIsTrivial rhs), ppr id )
                        -- The RHS can be eta-reduced to just a variable,