[commit: ghc] wip/nested-cpr: Unify the code paths that create cpr signatures (2ee0836)

[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/2ee0836af24625d2101c54989f62b74a48e7abc9/ghc

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

commit 2ee0836af24625d2101c54989f62b74a48e7abc9
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Fri Jan 17 12:03:42 2014 +0000

    Unify the code paths that create cpr signatures


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

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

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index 579813c..c224572 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -19,7 +19,7 @@ module Demand (
         peelUseCall, cleanUseDmd_maybe, strictenDmd, bothCleanDmd,
 
         DmdType(..), dmdTypeDepth, lubDmdType, lubDmdTypes, bothDmdType,
-        nopDmdType, litDmdType, botDmdType, mkDmdType,
+        nopDmdType, litDmdType, botDmdType, mkDmdType, cprProdDmdType, cprSumDmdType,
         addDemand, removeDmdTyArgs,
         BothDmdArg, mkBothDmdArg, toBothDmdArg,
 
@@ -28,7 +28,7 @@ module Demand (
 
         DmdResult, CPRResult,
         isBotRes, isTopRes, getDmdResult, resTypeArgDmd,
-        topRes, convRes, botRes, cprProdRes, cprSumRes,
+        topRes, convRes, botRes,
         splitNestedRes,
         appIsBottom, isBottomingSig, pprIfaceStrictSig,
         returnsCPR_maybe,
@@ -1162,9 +1162,13 @@ nopDmdType = DmdType emptyDmdEnv [] topRes
 botDmdType = DmdType emptyDmdEnv [] botRes
 litDmdType = DmdType emptyDmdEnv [] convRes
 
-cprProdDmdType :: Arity -> DmdType
-cprProdDmdType arity
-  = DmdType emptyDmdEnv [] (Dunno (RetProd (replicate arity topRes)))
+cprProdDmdType :: [DmdResult] -> DmdType
+cprProdDmdType arg_ress
+  = DmdType emptyDmdEnv [] $ cprProdRes arg_ress
+
+cprSumDmdType :: ConTag -> DmdType
+cprSumDmdType tag
+  = DmdType emptyDmdEnv [] $ cprSumRes tag
 
 isNopDmdType :: DmdType -> Bool
 isNopDmdType (DmdType env [] res)
@@ -1542,8 +1546,8 @@ nopSig, botSig :: StrictSig
 nopSig = StrictSig nopDmdType
 botSig = StrictSig botDmdType
 
-cprProdSig :: Arity -> StrictSig
-cprProdSig arity = StrictSig (cprProdDmdType arity)
+cprProdSig :: [DmdResult] -> StrictSig
+cprProdSig arg_ress = StrictSig (cprProdDmdType arg_ress)
 
 sigMayDiverge :: StrictSig -> StrictSig
 sigMayDiverge (StrictSig (DmdType env ds res)) = (StrictSig (DmdType env ds (divergeDmdResult res)))
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index fa4ad8b..e86e597 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -209,7 +209,7 @@ dmdAnal env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, bndrs, _)])
 
         -- Build a surely converging, CPR carrying signature for the builder,
         -- and for the components use what we get from the scrunitee
-        case_bndr_sig = mkClosedStrictSig [] (cprProdRes comp_rets)
+        case_bndr_sig = cprProdSig comp_rets
 
         env_w_tc              = env { ae_rec_tc = rec_tc' }
 	env_alt	              = extendAnalEnvs NotTopLevel env_w_tc $
@@ -240,7 +240,7 @@ dmdAnal env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)])
 	(alt_ty, alt')	      = dmdAnalAlt env_alt dmd alt
 	(alt_ty1, case_bndr') = annotateBndr env alt_ty case_bndr
 	(_, bndrs', _)	      = alt'
-	case_bndr_sig	      = cprProdSig (dataConRepArity dc)
+	case_bndr_sig	      = cprProdSig (replicate (dataConRepArity dc) topRes)
 		-- Inside the alternative, the case binder has the CPR property, and
                 -- is known to converge.
 		-- Meaning that a case on it will successfully cancel.
@@ -570,9 +570,9 @@ dmdAnalVarApp env dmd fun args
   , dataConRepArity con > 0
   , dataConRepArity con < 10
   , let cpr_info
-          | isProductTyCon (dataConTyCon con) = cprProdRes arg_rets
-          | otherwise                         = cprSumRes (dataConTag con)
-        res_ty = foldl bothDmdType (DmdType emptyDmdEnv [] cpr_info) arg_tys
+          | isProductTyCon (dataConTyCon con) = cprProdDmdType arg_rets
+          | otherwise                         = cprSumDmdType (dataConTag con)
+        res_ty = foldl bothDmdType cpr_info arg_tys
   = -- pprTrace "dmdAnalVarApp" (vcat [ ppr con, ppr args, ppr n_val_args, ppr cxt_ds
     --                                , ppr arg_tys, ppr cpr_info, ppr res_ty]) $
     ( res_ty
@@ -1194,7 +1194,8 @@ extendSigsWithLam env id
        -- See Note [Optimistic CPR in the "virgin" case]
        -- See Note [Initial CPR for strict binders]
   , Just (dc,_,_,_) <- deepSplitProductType_maybe (ae_fam_envs env) $ idType id
-  = extendAnalEnv NotTopLevel env id (sigMayDiverge (cprProdSig (dataConRepArity dc)))
+  = extendAnalEnv NotTopLevel env id $ sigMayDiverge $
+    cprProdSig (replicate (dataConRepArity dc) topRes)
 
   | otherwise 
   = env