[commit: ghc] cardinality: peeling call demand bug fixed (fb55ce2)

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

On branch  : cardinality

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

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

commit fb55ce2b236af800cf79a2f4421cd4d86dc682ba
Author: Ilya Sergey <[email protected]>
Date:   Wed Sep 19 12:39:03 2012 +0100

    peeling call demand bug fixed

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

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

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index d7c7f1a..f003d28 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -525,9 +525,12 @@ mkCallDmd (JD {strd = d, absd = a})
 
 -- Returns result demand + one-shotness of the call
 peelCallDmd :: JointDmd -> Maybe (JointDmd, Count)
-peelCallDmd (JD {strd = SCall d, absd = UCall c a}) = Just (mkJointDmd d a, c)
-peelCallDmd (JD {strd = SCall d, absd = Used _})    = Just (mkJointDmd d top, Many)
-peelCallDmd _                                       = Nothing 
+peelCallDmd (JD {strd = SCall d, absd = UCall c a})  = Just (mkJointDmd d a, c)
+peelCallDmd (JD {strd = Lazy, absd = UCall c a})     = Just (mkJointDmd Lazy a, c)
+peelCallDmd (JD {strd = Str, absd = UCall c a})      = Just (mkJointDmd Lazy a, c)
+peelCallDmd (JD {strd = HyperStr, absd = UCall c a}) = Just (mkJointDmd HyperStr a, c)
+peelCallDmd (JD {strd = SCall d, absd = Used _})     = Just (mkJointDmd d top, Many)
+peelCallDmd _                                        = Nothing 
 
 
 splitCallDmd :: JointDmd -> (Int, JointDmd)
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index f78b13d..aff4664 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -159,7 +159,7 @@ dmdAnal env dmd (App fun arg)	-- Non-type arguments
 	(arg_dmd, res_ty) = splitDmdTy fun_ty
 	(arg_ty, arg') 	  = dmdAnal env arg_dmd arg
     in
-    -- pprTrace "dmdAnal-App" (vcat [ppr fun, ppr fun_ty]) $
+    pprTrace "dmdAnal-App" (vcat [ppr fun, ppr fun_ty]) $
     (res_ty `both` arg_ty, App fun' arg')
 
 dmdAnal env dmd (Lam var body)
@@ -172,21 +172,22 @@ dmdAnal env dmd (Lam var body)
   | Just (body_dmd, One) <- peelCallDmd dmd	
   -- A call demand, also a one-shot lambda
   = let	
-	env'		 = extendSigsWithLam env var
+        env'		 = extendSigsWithLam env var
 	(body_ty, body') = dmdAnal env' body_dmd body
-	(lam_ty, var')   = annotateLamIdBndr env body_ty var
-        armed_var        = setOneShotLambda var'
+        armed_var        = setOneShotLambda var
+	(lam_ty, var')   = annotateLamIdBndr env body_ty armed_var
     in
-    (lam_ty, Lam armed_var body')
+    pprTrace "dmdAnal-Lam-One" (vcat [ppr var, ppr dmd, ppr lam_ty]) $
+    (lam_ty, Lam var' body')
 
   | Just (body_dmd, Many) <- peelCallDmd dmd	
   -- A call demand: good! (but not a one-shot lambda)
   = let	
 	env'		 = extendSigsWithLam env var
 	(body_ty, body') = dmdAnal env' body_dmd body
-        -- coarse_ty        = body_ty `both` body_ty
 	(lam_ty, var')   = annotateLamIdBndr env body_ty var
     in
+    pprTrace "dmdAnal-Lam-Many" (vcat [ppr var, ppr dmd, ppr lam_ty]) $
     (lam_ty, Lam var' body')
 
 
@@ -195,6 +196,7 @@ dmdAnal env dmd (Lam var body)
 	(body_ty, body') = dmdAnal env evalDmd body
 	(lam_ty, var')   = annotateLamIdBndr env body_ty var
     in
+    pprTrace "dmdAnal-Lam-Other" (vcat [ppr var, ppr dmd, ppr lam_ty]) $
     (deferType lam_ty, Lam var' body')     
 
 dmdAnal env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)])
@@ -660,7 +662,7 @@ mk_sig_ty thunk_cpr_ok rhs (DmdType fv dmds res)
     -- See Note [Lazy and unleasheable free variables]
     lazy_fv      = filterUFM (not . can_be_unleahsed) fv
     unleashed_fv = filterUFM can_be_unleahsed         fv
-    can_be_unleahsed d = isStrictDmd d || isSingleUsed d 
+    can_be_unleahsed d = isStrictDmd d
 
         -- final_dmds = setUnpackStrategy dmds
 	-- Set the unpacking strategy