[commit: ghc] cardinality: a controversial treatment of call demands changed (dc69220)

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

On branch  : cardinality

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

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

commit dc69220d2db9cedbb200a148a9af0e505e9d3467
Author: Ilya Sergey <[email protected]>
Date:   Wed Sep 19 00:07:13 2012 +0100

    a controversial treatment of call demands changed

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

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

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index aab016d..d7c7f1a 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -546,8 +546,8 @@ isSingleUsed (JD {absd=a}) = isUsedOnce a
 -- see Note [Default semands for right-hand sides]  
 vanillaCall :: Arity -> Demand
 vanillaCall 0 = onceEvalDmd
+-- generate C^n (U)  
 vanillaCall n =
-  -- generate C^n (U)  
   let strComp = (iterate strCall strStr) !! n
       absComp = (iterate (absCall Many) usedMany) !! n
    in mkJointDmd strComp absComp
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index a8af607..f78b13d 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -170,7 +170,7 @@ dmdAnal env dmd (Lam var body)
     (body_ty, Lam var body')
 
   | Just (body_dmd, One) <- peelCallDmd dmd	
-  -- A call demand, also a single-shot lambda
+  -- A call demand, also a one-shot lambda
   = let	
 	env'		 = extendSigsWithLam env var
 	(body_ty, body') = dmdAnal env' body_dmd body
@@ -180,12 +180,12 @@ dmdAnal env dmd (Lam var body)
     (lam_ty, Lam armed_var body')
 
   | Just (body_dmd, Many) <- peelCallDmd dmd	
-  -- A call demand: good!
+  -- 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        = coarsenType body_ty
-	(lam_ty, var')   = annotateLamIdBndr env coarse_ty var
+        -- coarse_ty        = body_ty `both` body_ty
+	(lam_ty, var')   = annotateLamIdBndr env body_ty var
     in
     (lam_ty, Lam var' body')
 
@@ -196,9 +196,6 @@ dmdAnal env dmd (Lam var body)
 	(lam_ty, var')   = annotateLamIdBndr env body_ty var
     in
     (deferType lam_ty, Lam var' body')
-  where
-    coarsenType ty = ty `both` ty 
-     
 
 dmdAnal env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)])
   -- Only one alternative with a product constructor
@@ -519,7 +516,7 @@ dmdAnalRhs top_lvl rec_flag env (id, 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, 
                        -- in which case we should not complain. 
-		       mkSigTy top_lvl rec_flag env id rhs rhs_dmd_ty
+                       mkSigTy top_lvl rec_flag env id rhs rhs_dmd_ty
   id'		     = id `setIdStrictness` sig_ty
   sigs'		     = extendSigEnv top_lvl (sigEnv env) id sig_ty