[commit: ghc] wip/nested-cpr: Comments and small refactor (052d78b)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/nested-cpr
Link       : http://ghc.haskell.org/trac/ghc/changeset/052d78b0851b46eec7eb9c4d075af443b5def704/ghc

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

commit 052d78b0851b46eec7eb9c4d075af443b5def704
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Wed Dec 4 16:00:24 2013 +0000

    Comments and small refactor


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

052d78b0851b46eec7eb9c4d075af443b5def704
 compiler/basicTypes/Demand.lhs |    8 ++++----
 compiler/stranal/DmdAnal.lhs   |   41 +++++++++++++++++++++-------------------
 2 files changed, 26 insertions(+), 23 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index 368468a..1af645f 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -723,16 +723,16 @@ We have lubs, but not glbs; but that is ok.
 -- Constructed Product Result                                             
 ------------------------------------------------------------------------
 
-data CPRResult = NoCPR                      -- Top of the lattice
-               | RetCon ConTag [DmdResult]  -- Returns a constructor from a data type
-               deriving( Eq, Show )
-
 data DmdResult = Diverges              -- Definitely diverges
                | Converges CPRResult   -- Definitely converges 
                | Dunno CPRResult       -- Might diverge or converge, but in the latter case the
                                        -- result shape is described by CPRResult
                deriving( Eq, Show ) 
 
+data CPRResult = NoCPR                      -- Top of the lattice
+               | RetCon ConTag [DmdResult]  -- Returns a constructor from a data type
+               deriving( Eq, Show )
+
 lubCPR :: CPRResult -> CPRResult -> CPRResult
 lubCPR (RetCon ct1 ds1) (RetCon ct2 ds2) 
   | ct1 == ct2
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index 686c4de..a029fff 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -523,34 +523,37 @@ dmdAnalVarApp env dmd fun args
     --                                , ppr arg_tys, ppr cpr_info, ppr res_ty]) $
     ( res_ty
     , foldl App (Var fun) args')
-
-  | otherwise
-  = --pprTrace "dmdAnalVarApp" (vcat [ ppr fun, ppr args, ppr n_val_args
-    --                               , ppr dmd
-    --                               , ppr (mkCallDmdN n_val_args dmd)
-    --                               , ppr $ dmdTransform env fun (mkCallDmdN n_val_args dmd)
-    --                               , ppr $ completeApp env (dmdTransform env fun (mkCallDmdN n_val_args dmd), Var fun) args
-    --                               ])
-    completeApp env (dmdTransform env fun (mkCallDmdN n_val_args dmd), Var fun) args
   where
     n_val_args = valArgCount args
-    cxt_ds = splitProdCleanDmd  n_val_args dmd
-    (arg_tys, args') = anal_args cxt_ds args
-        -- The constructor itself is lazy
+    cxt_ds = splitProdCleanDmd n_val_args dmd
+    (arg_tys, args') = anal_con_args cxt_ds args
+        -- The constructor itself is lazy, so we don't need to look at the
+        -- strictness signature on the data constructor. Instead just
+        -- propagate demand from the context into the constructor arguments
         -- See Note [Data-con worker strictness] in MkId
 
-    anal_args :: [Demand] -> [CoreExpr] -> ([DmdType], [CoreExpr])
-    anal_args _ [] = ([],[])
-    anal_args ds (arg : args)
+    anal_con_args :: [Demand] -> [CoreExpr] -> ([DmdType], [CoreExpr])
+    anal_con_args _ [] = ([],[])
+    anal_con_args ds (arg : args)
       | isTypeArg arg
-      , (arg_tys, args') <- anal_args ds args
+      , (arg_tys, args') <- anal_con_args ds args
       = (arg_tys, arg:args')
-    anal_args (d:ds) (arg : args)
+    anal_con_args (d:ds) (arg : args)
       | (arg_ty,  arg')  <- dmdAnalArg env d arg
-      , (arg_tys, args') <- anal_args ds args
+      , (arg_tys, args') <- anal_con_args ds args
       = --pprTrace "dmdAnalVarApp arg" (vcat [ ppr d, ppr arg, ppr arg_ty, ppr arg' ])
         (arg_ty:arg_tys, arg':args')
-    anal_args ds args = pprPanic "anal_args" (ppr args $$ ppr ds)
+    anal_con_args ds args = pprPanic "anal_con_args" (ppr args $$ ppr ds)
+
+
+dmdAnalVarApp env dmd fun args
+  | otherwise  -- Not a saturated constructor
+  = --pprTrace "dmdAnalVarApp" (vcat [ ppr fun, ppr args, ppr n_val_args
+    --                               , ppr dmd
+    --                               , ppr $ dmdTransform env fun (mkCallDmdN n_val_args dmd)
+    --                               , ppr $ completeApp env (dmdTransform env fun (mkCallDmdN n_val_args dmd), Var fun) args
+    --                               ])
+    completeApp env (dmdTransform env fun (mkCallDmdN (valArgCount args) dmd), Var fun) args
 \end{code}
 
 %************************************************************************