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

[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/95cdc08f7346e80726f922453c644bb4baed36d7/ghc

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

commit 95cdc08f7346e80726f922453c644bb4baed36d7
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.


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

95cdc08f7346e80726f922453c644bb4baed36d7
 compiler/basicTypes/Demand.lhs |   15 +++++++++++++--
 compiler/stranal/DmdAnal.lhs   |   41 ++++++++++++++++++++++++++++++++++++++++
 2 files changed, 54 insertions(+), 2 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index 28aad59..2e67291 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_maybe,
         forgetCPR, forgetSumCPR,
@@ -702,6 +703,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}
 
 %************************************************************************
@@ -874,10 +876,19 @@ forgetSumCPR_help (RetProd ds) = RetProd (map forgetSumCPR ds)
 forgetSumCPR_help (RetSum _)   = NoCPR
 forgetSumCPR_help NoCPR        = NoCPR
 
-
 vanillaCprProdRes :: Arity -> DmdResult
 vanillaCprProdRes arity = cprProdRes (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..a1e5eba 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
+        comp_rets  = take (dataConRepArity dc) $ splitNestedRes scrut_ret -- infinite list!
+
+        -- 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)
+
+        env_w_tc              = env { ae_rec_tc = rec_tc' }
+	env_alt	              = extendAnalEnvs NotTopLevel env_w_tc $
+            (case_bndr, case_bndr_sig) :
+            zipWithEqual "dmdAnal:CaseComplex"
+               (\b ty -> (b, mkClosedStrictSig [] ty)) bndrs  comp_rets
+
+	(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' }