[commit: ghc] cardinality: Improve simple-minded boxity analysis for function bodies (be5fe43)

[Simon Peyton Jones]

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

On branch  : cardinality

https://github.com/ghc/ghc/commit/be5fe43fcf80be87c17c7cc963c5c3b2274d52d8

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

commit be5fe43fcf80be87c17c7cc963c5c3b2274d52d8
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Mon Mar 25 13:00:15 2013 +0000

    Improve simple-minded boxity analysis for function bodies

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

 compiler/basicTypes/Demand.lhs | 34 +++-------------------------------
 compiler/stranal/DmdAnal.lhs   | 36 +++++++++++++++++++++++++++++++++---
 2 files changed, 36 insertions(+), 34 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index 0462573..725c69d 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -630,48 +630,20 @@ peelCallDmd (CD {sd = s, ud = u})
        -- The last case includes UHead which seems a bit wrong
        -- because the body isn't used at all!
 
--- see Note [Default demands for right-hand sides]  
-vanillaCall :: Arity -> CleanDemand
-vanillaCall 0 = cleanEvalDmd
-vanillaCall n =
-  let strComp = nTimes n mkSCall       HeadStr
-      absComp = nTimes n (mkUCall One) Used
-   in mkCleanDmd strComp absComp
-
 cleanEvalDmd :: CleanDemand
 cleanEvalDmd = mkCleanDmd HeadStr Used
 
+cleanEvalProdDmd :: Arity -> CleanDemand
+cleanEvalProdDmd n = mkCleanDmd HeadStr (UProd (replicate n useTop))
+
 isSingleUsed :: JointDmd -> Bool
 isSingleUsed (JD {absd=a}) = is_used_once a
   where
     is_used_once Abs         = True
     is_used_once (Use One _) = True
     is_used_once _           = False
-
--- -- see Note [Threshold demands]  
--- mkThresholdDmd :: Arity -> JointDmd
--- mkThresholdDmd 0 = topDmd
--- mkThresholdDmd n =
---   let absComp = (iterate (mkUCall One) useTop) !! n
---    in mkJointDmd Lazy absComp
-
-
 \end{code}
 
-Note [Default demands for right-hand sides]  
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When analysis a right-hand side of a let binding, we create a
-"default" demand using `vanillaCall`. It is worth mentioning that for
-*thunks* the demand, under which a RHS is analysed is (Used One),
-whereas for lambdas it is C(C...(U)...).
-
-This phenomenon is due to the special nature of thunks: they "merge"
-multiple usage demands into one. This also explains the fact that the
-demand transformer for thunks is triggered by a less-precise, mere U
-demand (not U1). This is not true for lambda, therefore to analyze
-them we create a conservative demand C(C...(U)...), where the number
-of call layers is equal to syntactic arity of the lambda.
-
 Note [Threshold demands]
 ~~~~~~~~~~~~~~~~~~~~~~~~
 Threshold usage demand is generated to figure out if
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index 14d6fce..e706bd3 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -23,9 +23,9 @@ import VarEnv
 import BasicTypes	
 import FastString
 import Data.List
-import DataCon		( dataConTyCon, dataConRepStrictness, isMarkedStrict )
+import DataCon
 import Id
-import CoreUtils	( exprIsHNF, exprIsTrivial )
+import CoreUtils	( exprIsHNF, exprType, exprIsTrivial )
 import PprCore	
 import TyCon
 import Pair
@@ -594,15 +594,21 @@ dmdAnalRhs top_lvl rec_flag env id rhs
   where
     (bndrs, body)        = collectBinders rhs
     env_body             = foldl extendSigsWithLam env bndrs
-    (body_dmd_ty, body') = dmdAnal env_body cleanEvalDmd body
+    (body_dmd_ty, body') = dmdAnal env_body body_dmd body
     (rhs_dmd_ty, bndrs') = annotateLamBndrs env body_dmd_ty bndrs
     id'		         = id `setIdStrictness` sig_ty
     sig_ty               = mkStrictSig (mkDmdType sig_fv rhs_dmds rhs_res')
 	-- See Note [NOINLINE and strictness]
 
+    -- See Note [Product demands for function body]
+    body_dmd = case deepSplitProductType_maybe (exprType body) of
+                 Nothing            -> cleanEvalDmd
+                 Just (dc, _, _, _) -> cleanEvalProdDmd (dataConRepArity dc)
+
     DmdType rhs_fv rhs_dmds rhs_res = rhs_dmd_ty
 
     -- See Note [Lazy and unleashable free variables]
+    -- See Note [Aggregated demand for cardinality]
     rhs_fv1 = case rec_flag of
                 Just bs -> useEnv (delVarEnvList rhs_fv bs)
                 Nothing -> rhs_fv
@@ -626,6 +632,30 @@ dmdAnalRhs top_lvl rec_flag env id rhs
           -- See Note [Optimistic CPR in the "virgin" case]
 \end{code}
 
+Note [Product demands for function body]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This example comes from shootout/binary_trees:
+
+    Main.check' = \ b z ds. case z of z' { I# ip ->
+        			case ds_d13s of
+        			  Main.Nil -> z'
+        			  Main.Node s14k s14l s14m ->
+        			    Main.check' (not b)
+        			      (Main.check' b
+        			         (case b {
+        			            False -> I# (-# s14h s14k);
+        			            True  -> I# (+# s14h s14k)
+        			          })
+        			         s14l)
+        			     s14m   }   }   }
+
+Here we *really* want to unbox z, even though it appears to be used boxed in
+the Nil case.  Partly the Nil case is not a hot path.  But more specifically,
+the whole function gets the CPR property if we do. 
+
+So for the demand on the body of a RHS we use a product demand if it's
+a product type.
+
 %************************************************************************
 %*									*
 \subsection{Strictness signatures and types}