[commit: ghc] cardinality: single-shot call demands added (c640520)

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

On branch  : cardinality

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

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

commit c64052042677458dbdfb19f4eef6f4b5d8d8d137
Author: Ilya Sergey <[email protected]>
Date:   Tue Sep 4 00:08:23 2012 +0100

    single-shot call demands added

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

 compiler/basicTypes/Demand.lhs |   16 +++++++++-------
 compiler/stranal/DmdAnal.lhs   |    2 +-
 2 files changed, 10 insertions(+), 8 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index d368d35..5a90f49 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -306,9 +306,9 @@ instance LatticeLike AbsDmd where
   both (UHead _) (UProd _ ux)      = UProd Many ux
   both (UProd _ ux1) (UProd _ ux2)
      | length ux1 == length ux2    = absProd Many $ zipWith both ux1 ux2
-  -- is it correct? 
-  -- both (UCall _ u1) (UCall _ u2)   = absCall Many (u1 `lub` u2)
-  both (UCall _ u1) (UCall _ u2)   = absCall Many (u1 `both` u2)
+  -- is it correct? -- explain! 
+  both (UCall _ u1) (UCall _ u2)   = absCall Many (u1 `lub` u2)
+  --both (UCall _ u1) (UCall _ u2)   = absCall Many (u1 `both` u2)
   both _ _                         = top
 
 -- utility functions
@@ -532,7 +532,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
@@ -556,11 +556,13 @@ isSingleShot :: JointDmd -> Bool
 isSingleShot (JD {absd=a}) = isUsedOnce a
   
 vanillaCall :: Arity -> Demand
-vanillaCall 0 = evalDmd
+vanillaCall 0 = 
+      -- we have no ide how many times the result is going to be used
+      evalDmd
 vanillaCall n =
-  -- generate S^n (S)  
+  -- generate C^n (S)  
   let strComp = (iterate strCall strStr) !! n
-      absComp = (iterate (absCall Many) usedOnce) !! n
+      absComp = (iterate (absCall One) usedOnce) !! n
    in mkJointDmd strComp absComp
 
 \end{code}
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index edee3c2..4eb8a79 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -393,7 +393,7 @@ 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 env, ppr dmd]) $
+  = 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