[commit: ghc] cardinality: post-refactoring bugs fixed in the demand/cardinality analyser (3a8cde0)

[Ilya Sergey]

Repository : http://darcs.haskell.org/ghc.git/

On branch  : cardinality

http://hackage.haskell.org/trac/ghc/changeset/3a8cde04e6d1014ea6afd9331f5af7f0d983d924

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

commit 3a8cde04e6d1014ea6afd9331f5af7f0d983d924
Author: Ilya Sergey <ilya.sergey at gmail.com>
Date:   Sat Mar 9 21:10:12 2013 +0100

    post-refactoring bugs fixed in the demand/cardinality analyser

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

 compiler/basicTypes/Demand.lhs | 21 ++++++++++-----------
 compiler/stranal/DmdAnal.lhs   | 21 +++++++++++++++------
 2 files changed, 25 insertions(+), 17 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index 1a323fe..00ce043 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -39,8 +39,8 @@ module Demand (
         dmdTransformSig, dmdTransformDataConSig,
 
         -- cardinality unleashing stuff (perhaps, redundant)
-        -- use, useType, useEnv, trimFvUsageTy         
-        isSingleUsed, 
+        -- use, useEnv, trimFvUsageTy         
+        isSingleUsed, useType,
 
         worthSplittingFun, worthSplittingThunk
 
@@ -240,7 +240,7 @@ instance Outputable UseDmd where
   ppr Used           = char 'U'
   ppr (UCall c a)    = char 'C' <> ppr c <> parens (ppr a)
   ppr UHead          = char 'H'
-  ppr (UProd as)     = char 'U' <> parens (hcat (map ppr as))
+  ppr (UProd as)     = char 'U' <> parens (hcat (punctuate (char ',') (map ppr as)))
 
 instance Outputable Count where
   ppr One  = char '1'
@@ -543,9 +543,8 @@ peelCallDmd (CD {sd = s, ud = u})
     peel_s _           = (strStr, False)
 
     peel_u (UCall c u) = (Use c u, c)
-    peel_u Used        = (useTop, Many)
     peel_u UHead       = (Abs, One)
-    peel_u d@(UProd _) = pprPanic "attempt to peel a product usage demand" (ppr d)
+    peel_u _           = (useTop, Many)
 
 -- see Note [Default demands for right-hand sides]  
 vanillaCall :: Arity -> CleanDemand
@@ -1135,14 +1134,14 @@ dmdTransformDataConSig :: Arity -> StrictSig -> CleanDemand -> DmdType
 -- If the constructor is saturated, we feed the demand on 
 -- the result into the constructor arguments.
 dmdTransformDataConSig arity (StrictSig (DmdType _ _ con_res)) dmd
-  = go arity (sd dmd)
+  = go arity dmd
   where
-    go 0 _ = DmdType emptyDmdEnv (splitProdDmd arity dmd) con_res
+    go 0 dmd = DmdType emptyDmdEnv (splitProdDmd arity dmd) con_res
                 -- Must remember whether it's a product, hence con_res, not TopRes
-    go n d = case d of SCall d'       -> go (n-1) d'
-                       HyperStr       -> go (n-1) HyperStr                     
-                       _              -> topDmdType
-
+    go n dmd = case peelCallDmd dmd of
+                 (_,False,_)                -> topDmdType
+                 (dmd',_,_) | isAbsDmd dmd' -> topDmdType
+                 (dmd',_,_)                 -> go (n-1) (toCleanDmd dmd')
 \end{code}
 
 Note [Non-full application] 
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index aa0acf3..22d8176 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -195,9 +195,14 @@ dmdAnal dflags env dmd (App fun arg)	-- Non-type arguments
 	(arg_dmd, res_ty) = splitDmdTy fun_ty
         (arg_ty, arg') 	  = dmdAnalStar dflags env arg_dmd arg
         
+        -- coarsening cardinaliy for argument basing on arg_d,d
+        arg_ty'           = if isSingleUsed arg_dmd
+                            then arg_ty
+                            else useType arg_ty
+
 	-- annotate components with single-shotness explicitly a-posteriori
-        arg''             = annLamWithShotness (toCleanDmd arg_dmd) arg'
-        fun''             = annLamWithShotness call_dmd fun'
+        arg''             = annLamWithShotness arg_dmd arg'
+        fun''             = annLamWithShotness (mkOnceUsedDmd call_dmd) fun'
     in
 --    pprTrace "dmdAnal:app" (vcat
 --         [ text "dmd =" <+> ppr dmd
@@ -207,7 +212,7 @@ dmdAnal dflags env dmd (App fun arg)	-- Non-type arguments
 --         , text "arg dmd_ty =" <+> ppr arg_ty
 --         , text "res dmd_ty =" <+> ppr res_ty
 --         , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ])
-    (res_ty `bothDmdType` arg_ty, App fun'' arg'')
+    (res_ty `bothDmdType` arg_ty', App fun'' arg'')
 
 dmdAnal dflags env dmd (Lam var body)
   | isTyVar var
@@ -330,7 +335,7 @@ dmdAnal dflags env dmd (Let (NonRec id rhs) body)
         
         -- Annotate top-level lambdas at RHS basing on the aggregated demand info
         -- See Note [Annotating lambdas at right-hand side] 
-        annotated_rhs                 = annLamWithShotness (toCleanDmd id_dmd) rhs'   
+        annotated_rhs                 = annLamWithShotness id_dmd rhs'   
     in
 	-- If the actual demand is better than the vanilla call
 	-- demand, you might think that we might do better to re-analyse 
@@ -375,8 +380,12 @@ dmdAnal dflags env dmd (Let (Rec pairs) body)
     in
     (body_ty2,  Let (Rec pairs') body')
 
-annLamWithShotness :: CleanDemand -> CoreExpr -> CoreExpr
-annLamWithShotness d e = annotate_lambda (getUsage d) e
+annLamWithShotness :: Demand -> CoreExpr -> CoreExpr
+annLamWithShotness d e
+  | isAbsDmd d 
+  = e 
+  | otherwise
+  = annotate_lambda (getUsage $ toCleanDmd d) e
   where
     annotate_lambda dmd lam@(Lam var body)
       | isTyVar var