[commit: ghc] wip/nested-cpr: Pass nested CPR information from scrunitee to body (2e6a0d8)
git at git.haskell.org
git at git.haskell.org
Tue Feb 4 18:27:10 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/nested-cpr
Link : http://ghc.haskell.org/trac/ghc/changeset/2e6a0d80451a0f3e5d676c5424a82859b1974a60/ghc
>---------------------------------------------------------------
commit 2e6a0d80451a0f3e5d676c5424a82859b1974a60
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.
>---------------------------------------------------------------
2e6a0d80451a0f3e5d676c5424a82859b1974a60
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 c7338c4..da576f3 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 5ae2439..c4b9f02 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -191,6 +191,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
@@ -1117,6 +1155,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' }
More information about the ghc-commits
mailing list