[commit: ghc] wip/nested-cpr: Pass nested CPR information from scrunitee to body (60d9a40)

[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/60d9a40cef5e5e9079cdc93e66868c5531ccc240/ghc

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

commit 60d9a40cef5e5e9079cdc93e66868c5531ccc240
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Wed Jan 8 15:09:42 2014 +0000

    Pass nested CPR information from scrunitee to body
    
    in case of a complex case scrunitee.


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

60d9a40cef5e5e9079cdc93e66868c5531ccc240
 compiler/basicTypes/Demand.lhs |   16 ++++++++++++++--
 compiler/stranal/DmdAnal.lhs   |   41 ++++++++++++++++++++++++++++++++++++++++
 2 files changed, 55 insertions(+), 2 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index 23dacea..b2a9465 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -27,8 +27,9 @@ module Demand (
         peelFV,
 
         DmdResult, CPRResult,
-        isBotRes, isTopRes, getDmdResult,
+        isBotRes, isTopRes, getDmdResult, resTypeArgDmd,
         topRes, convRes, botRes, cprProdRes, vanillaCprProdRes, cprSumRes,
+        splitNestedRes,
         appIsBottom, isBottomingSig, pprIfaceStrictSig,
         returnsCPR, returnsCPR_maybe,
         forgetCPR, forgetSumCPR,
@@ -704,6 +705,7 @@ splitProdDmd_maybe (JD {strd = s, absd = u})
       (Str s,          Use _ (UProd ux)) -> Just (mkJointDmds (splitStrProdDmd (length ux) s) ux)
       (Lazy,           Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy)    ux)
       _                                  -> Nothing
+
 \end{code}
 
 %************************************************************************
@@ -875,13 +877,23 @@ forgetSumCPR_help (RetProd ds) = RetProd (map forgetSumCPR ds)
 forgetSumCPR_help (RetSum _)   = NoCPR
 forgetSumCPR_help NoCPR        = NoCPR
 
-
 vanillaCprProdRes :: Arity -> DmdResult
 vanillaCprProdRes arity
   | opt_CprOff        = topRes
   | opt_NestedCprOff  = Converges $ cutCPRResult flatCPRDepth $ RetProd (replicate arity topRes)
   | otherwise         = Converges $ cutCPRResult maxCPRDepth  $ RetProd (replicate arity topRes)
 
+splitNestedRes :: DmdResult -> [DmdResult]
+splitNestedRes Diverges      = repeat topRes
+splitNestedRes (Dunno c)     = splitNestedCPR c
+splitNestedRes (Converges c) = splitNestedCPR c
+
+splitNestedCPR :: CPRResult -> [DmdResult]
+splitNestedCPR NoCPR        = repeat topRes
+splitNestedCPR (RetSum _)   = repeat topRes
+splitNestedCPR (RetProd cs) = cs
+
+
 isTopRes :: DmdResult -> Bool
 isTopRes (Dunno NoCPR) = True
 isTopRes _             = False
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index a080930..d37e5bc 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -190,6 +190,44 @@ dmdAnal env dmd (Lam var body)
     in
     (postProcessUnsat defer_and_use lam_ty, Lam var' body')
 
+dmdAnal env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, bndrs, _)])
+  -- Only one alternative with a product constructor, and a complex scrutinee
+  | let tycon = dataConTyCon dc
+  , isProductTyCon tycon
+  -- If the scrutinee is not trivial, we are not going to get much from
+  -- passing the body demand to it. OTOH, we might be getting some nested CPR
+  -- information from the scrutinee that we can feed into the bound variables.
+  , not (exprIsTrivial scrut)
+  , Just rec_tc' <- checkRecTc (ae_rec_tc env) tycon
+  = let
+        scrut_dmd = mkProdDmd (replicate (dataConRepArity dc) topDmd)
+	(scrut_ty, scrut') = dmdAnal env scrut_dmd scrut
+
+        scrut_ret  = getDmdResult scrut_ty
+        -- The case binder has the same signature as the scrunitee,
+        -- but at least the usual CPR property according to dc
+	case_bndr_sig | returnsCPR scrut_ret = convergeSig (mkClosedStrictSig [] scrut_ret)
+                      | otherwise            = cprProdSig (dataConRepArity dc)
+
+
+        env_w_tc              = env { ae_rec_tc = rec_tc' }
+	env_alt	              = extendAnalEnvs NotTopLevel env_w_tc $
+            (case_bndr, case_bndr_sig) :
+            zipWith (\b ty -> (b, mkClosedStrictSig [] ty))
+               bndrs (splitNestedRes scrut_ret)
+
+	(alt_ty, alt')	      = dmdAnalAlt env_alt dmd alt
+	(alt_ty1, case_bndr') = annotateBndr env alt_ty case_bndr
+        res_ty                = alt_ty1 `bothDmdType` toBothDmdArg scrut_ty
+    in
+    -- pprTrace "dmdAnal:CaseComplex" (vcat [ text "scrut" <+> ppr scrut
+    --                                , text "dmd" <+> ppr dmd
+    --                                , text "scrut_dmd" <+> ppr scrut_dmd
+    --                                , text "scrut_ty" <+> ppr scrut_ty
+    --                                , text "alt_ty" <+> ppr alt_ty1
+    --                                , text "res_ty" <+> ppr res_ty ]) $
+    (res_ty, Case scrut' case_bndr' ty [alt'])
+
 dmdAnal env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)])
   -- Only one alternative with a product constructor
   | let tycon = dataConTyCon dc
@@ -1109,6 +1147,9 @@ sigEnv = ae_sigs
 updSigEnv :: AnalEnv -> SigEnv -> AnalEnv
 updSigEnv env sigs = env { ae_sigs = sigs }
 
+extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [(Id, StrictSig)] -> AnalEnv
+extendAnalEnvs top_lvl = foldl' (\e (i,s) -> extendAnalEnv top_lvl e i s)
+
 extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> StrictSig -> AnalEnv
 extendAnalEnv top_lvl env var sig
   = env { ae_sigs = extendSigEnv top_lvl (ae_sigs env) var sig' }