[commit: ghc] wip/nested-cpr: Use the un-postprocessed DmdResult to build nested CPR (b40ce5f)

[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/b40ce5ff1c2009055eeb8cb3695f7cf475f136ed/ghc

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

commit b40ce5ff1c2009055eeb8cb3695f7cf475f136ed
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Wed Dec 4 16:29:35 2013 +0000

    Use the un-postprocessed DmdResult to build nested CPR


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

b40ce5ff1c2009055eeb8cb3695f7cf475f136ed
 compiler/basicTypes/Demand.lhs |   16 ++++++++--------
 compiler/stranal/DmdAnal.lhs   |   33 +++++++++++++++++++--------------
 2 files changed, 27 insertions(+), 22 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index 29ddc7a..8a4b5c2 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -26,7 +26,7 @@ module Demand (
         peelFV,
 
         DmdResult(..), CPRResult(..),
-        isBotRes, isTopRes, resTypeArgDmd, 
+        isBotRes, isTopRes, getDmdResult, resTypeArgDmd,
         topRes, botRes, cprConRes, vanillaCprConRes,
         appIsBottom, isBottomingSig, pprIfaceStrictSig, 
         returnsCPR, returnsCPR_maybe,
@@ -825,14 +825,14 @@ forgetCPR Diverges = Diverges
 forgetCPR (Converges _) = Converges NoCPR
 forgetCPR (Dunno _) = Dunno NoCPR
 
-cprConRes :: ConTag -> [DmdType] -> CPRResult
-cprConRes tag arg_tys
+cprConRes :: ConTag -> [DmdResult] -> CPRResult
+cprConRes tag arg_ress
   | opt_CprOff = NoCPR
-  | otherwise  = cutCPRResult maxCPRDepth $ RetCon tag (map get_res arg_tys)
-  where
-    get_res :: DmdType -> DmdResult
-    get_res (DmdType _ [] r) = r       -- Only for data-typed arguments!
-    get_res _                = topRes
+  | otherwise  = cutCPRResult maxCPRDepth $ RetCon tag arg_ress
+
+getDmdResult :: DmdType -> DmdResult
+getDmdResult (DmdType _ [] r) = r       -- Only for data-typed arguments!
+getDmdResult _                = topRes
 
 vanillaCprConRes :: ConTag -> Arity -> CPRResult
 vanillaCprConRes tag arity
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index e0876e0..c493e85 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -110,11 +110,15 @@ dmdTransformThunkDmd e
 -- See |-* relation in the companion paper
 dmdAnalStar :: AnalEnv 
             -> Demand 	-- This one takes a *Demand*
-            -> CoreExpr -> (DmdType, CoreExpr)
+            -> CoreExpr
+            -> (DmdType, DmdResult, CoreExpr)
 dmdAnalStar env dmd e 
   | (cd, defer_and_use) <- toCleanDmd dmd
   , (dmd_ty, e')        <- dmdAnal env cd e
-  = (postProcessDmdTypeM defer_and_use dmd_ty, e')
+  = let dmd_ty' = postProcessDmdTypeM defer_and_use dmd_ty
+    in -- pprTrace "dmdAnalStar" (vcat [ppr e, ppr dmd, ppr defer_and_use, ppr dmd_ty, ppr dmd_ty'])
+        -- We also return the unmodified DmdResult, to store it in nested CPR information
+       (dmd_ty', getDmdResult dmd_ty,  e')
 
 -- Main Demand Analsysis machinery
 dmdAnal :: AnalEnv
@@ -502,7 +506,7 @@ completeApp env (fun_ty, fun') (arg:args)
   | otherwise     = completeApp env (res_ty `bothDmdType` arg_ty, App fun' arg') args
   where
     (arg_dmd, res_ty) = splitDmdTy fun_ty
-    (arg_ty, arg')    = dmdAnalStar env (dmdTransformThunkDmd arg arg_dmd) arg
+    (arg_ty, _, arg')    = dmdAnalStar env (dmdTransformThunkDmd arg arg_dmd) arg
 
 ----------------
 dmdAnalVarApp :: AnalEnv -> CleanDemand -> Id
@@ -511,7 +515,7 @@ dmdAnalVarApp env dmd fun args
   | Just con <- isDataConWorkId_maybe fun  -- Data constructor
   , isVanillaDataCon con
   , n_val_args == dataConRepArity con      -- Saturated
-  , let cpr_info = Converges (cprConRes (dataConTag con) arg_tys)
+  , let cpr_info = Converges (cprConRes (dataConTag con) arg_rets)
         res_ty = foldl bothDmdType (DmdType emptyDmdEnv [] cpr_info) arg_tys
   = -- pprTrace "dmdAnalVarApp" (vcat [ ppr con, ppr args, ppr n_val_args, ppr cxt_ds
     --                                , ppr arg_tys, ppr (Converges cpr_info), ppr res_ty]) $
@@ -520,20 +524,21 @@ dmdAnalVarApp env dmd fun args
   where
     n_val_args = valArgCount args
     cxt_ds = splitProdCleanDmd  n_val_args dmd
-    (arg_tys, args') = anal_con_args cxt_ds args
+
+    (arg_tys, arg_rets, args') = anal_con_args cxt_ds args
         -- The constructor itself is lazy
         -- See Note [Data-con worker strictness] in MkId
 
-    anal_con_args :: [Demand] -> [CoreExpr] -> ([DmdType], [CoreExpr])
-    anal_con_args _ [] = ([],[])
+    anal_con_args :: [Demand] -> [CoreExpr] -> ([DmdType], [DmdResult], [CoreExpr])
+    anal_con_args _ [] = ([],[],[])
     anal_con_args ds (arg : args)
-      | isTyCoArg arg
-      , (arg_tys, args') <- anal_con_args ds args
-      = (arg_tys, arg:args')
+      | isTypeArg arg
+      , (arg_tys, arg_rets, args') <- anal_con_args ds args
+      = (arg_tys, arg_rets, arg:args')
     anal_con_args (d:ds) (arg : args)
-      | (arg_ty,  arg')  <- dmdAnalStar env (dmdTransformThunkDmd arg d) arg
-      , (arg_tys, args') <- anal_con_args ds args
-      = (arg_ty:arg_tys, arg':args')
+      | (arg_ty, arg_ret, arg') <- dmdAnalStar env (dmdTransformThunkDmd arg d) arg
+      , (arg_tys, arg_rets, args') <- anal_con_args ds args
+      = (arg_ty:arg_tys, arg_ret:arg_rets, arg':args')
     anal_con_args ds args = pprPanic "anal_con_args" (ppr args $$ ppr ds)
 
 dmdAnalVarApp env dmd fun args
@@ -813,7 +818,7 @@ annotateLamIdBndr env arg_of_dfun dmd_ty one_shot id
                  Nothing  -> main_ty
                  Just unf -> main_ty `bothDmdType` unf_ty
                           where
-                             (unf_ty, _) = dmdAnalStar env dmd unf
+                             (unf_ty, _, _) = dmdAnalStar env dmd unf
 
     main_ty = addDemand dmd dmd_ty'
     (dmd_ty', dmd) = peelFV dmd_ty id