[commit: ghc] wip/nested-cpr: Refactor trimCPRInfo away (34db1df)
git at git.haskell.org
git at git.haskell.org
Tue Feb 4 18:27:08 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/nested-cpr
Link : http://ghc.haskell.org/trac/ghc/changeset/34db1df27aee84aca959a370a134a17337b57560/ghc
>---------------------------------------------------------------
commit 34db1df27aee84aca959a370a134a17337b57560
Author: Joachim Breitner <mail at joachim-breitner.de>
Date: Wed Jan 15 17:44:30 2014 +0000
Refactor trimCPRInfo away
>---------------------------------------------------------------
34db1df27aee84aca959a370a134a17337b57560
compiler/basicTypes/Demand.lhs | 35 ++++++++++++++++++++---------------
compiler/stranal/DmdAnal.lhs | 38 ++++++++++++++++++++++++--------------
2 files changed, 44 insertions(+), 29 deletions(-)
diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index 0d26d66..c7338c4 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -30,7 +30,8 @@ module Demand (
isBotRes, isTopRes, getDmdResult,
topRes, convRes, botRes, cprProdRes, vanillaCprProdRes, cprSumRes,
appIsBottom, isBottomingSig, pprIfaceStrictSig,
- trimCPRInfo, returnsCPR_maybe,
+ returnsCPR_maybe,
+ forgetCPR, forgetSumCPR,
StrictSig(..), mkStrictSig, mkClosedStrictSig, nopSig, botSig, cprProdSig, convergeSig,
isNopSig, splitStrictSig, increaseStrictSigArity,
sigMayDiverge,
@@ -856,6 +857,24 @@ cutCPRResult n (RetProd rs) = RetProd (map (cutDmdResult (n-1)) rs)
cutDmdResult n (Converges c) = Converges (cutCPRResult n c)
cutDmdResult n (Dunno c) = Dunno (cutCPRResult n c)
+-- Forget the CPR information, but remember if it converges or diverges
+-- Used for non-strict thunks and non-top-level things with sum type
+forgetCPR :: DmdResult -> DmdResult
+forgetCPR Diverges = Diverges
+forgetCPR (Converges _) = Converges NoCPR
+forgetCPR (Dunno _) = Dunno NoCPR
+
+forgetSumCPR :: DmdResult -> DmdResult
+forgetSumCPR Diverges = Diverges
+forgetSumCPR (Converges r) = Converges (forgetSumCPR_help r)
+forgetSumCPR (Dunno r) = Dunno (forgetSumCPR_help r)
+
+forgetSumCPR_help :: CPRResult -> CPRResult
+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)
@@ -867,20 +886,6 @@ isBotRes :: DmdResult -> Bool
isBotRes Diverges = True
isBotRes _ = False
-trimCPRInfo :: Bool -> Bool -> DmdResult -> DmdResult
-trimCPRInfo trim_all trim_sums res
- = trimR res
- where
- trimR (Converges c) = Converges (trimC c)
- trimR (Dunno c) = Dunno (trimC c)
- trimR Diverges = Diverges
-
- trimC (RetSum n) | trim_all || trim_sums = NoCPR
- | otherwise = RetSum n
- trimC (RetProd rs) | trim_all = NoCPR
- | otherwise = RetProd (map trimR rs)
- trimC NoCPR = NoCPR
-
returnsCPR_maybe :: DmdResult -> Maybe ConTag
returnsCPR_maybe (Converges c) = retCPR_maybe c
returnsCPR_maybe (Dunno c) = retCPR_maybe c
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index bfe406f..5ae2439 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -652,22 +652,26 @@ dmdAnalRhs :: TopLevelFlag
-> (StrictSig, DmdEnv, Id, CoreExpr)
-- Process the RHS of the binding, add the strictness signature
-- to the Id, and augment the environment with the signature as well.
-dmdAnalRhs top_lvl rec_flag env id rhs
+dmdAnalRhs top_lvl rec_flag env var rhs
| Just fn <- unpackTrivial rhs -- See Note [Trivial right-hand sides]
, let fn_str = getStrictness env fn
- = (fn_str, emptyDmdEnv, set_idStrictness env id fn_str, rhs)
+ = (fn_str, emptyDmdEnv, set_idStrictness env var fn_str, rhs)
| otherwise
- = (sig_ty, lazy_fv, id', mkLams bndrs' body')
+ = (sig_ty, lazy_fv, var', mkLams bndrs' body')
where
- (bndrs, body) = collectBinders rhs
- env_body = foldl extendSigsWithLam env bndrs
- (body_ty, body') = dmdAnal env_body body_dmd body
- body_ty' = removeDmdTyArgs body_ty -- zap possible deep CPR info
+ (bndrs, body) = collectBinders rhs
+ env_body = foldl extendSigsWithLam env bndrs
+ (body_ty, body') = dmdAnal env_body body_dmd body
+ body_ty' = removeDmdTyArgs body_ty -- zap possible deep CPR info
(DmdType rhs_fv rhs_dmds rhs_res, bndrs')
- = annotateLamBndrs env (isDFunId id) body_ty' bndrs
- sig_ty = mkStrictSig (mkDmdType sig_fv rhs_dmds rhs_res')
- id' = set_idStrictness env id sig_ty
+ = annotateLamBndrs env (isDFunId var) body_ty' bndrs
+ sig_ty = mkStrictSig $
+ mkDmdType sig_fv rhs_dmds $
+ handle_sum_cpr $
+ handle_thunk_cpr $
+ rhs_res
+ var' = set_idStrictness env var sig_ty
-- See Note [NOINLINE and strictness]
-- See Note [Product demands for function body]
@@ -683,16 +687,19 @@ dmdAnalRhs top_lvl rec_flag env id rhs
(lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv1
- rhs_res' = trimCPRInfo trim_all trim_sums rhs_res
- trim_all = is_thunk && not_strict
- trim_sums = not (isTopLevel top_lvl) -- See Note [CPR for sum types]
+ -- Note [CPR for sum types]
+ handle_sum_cpr | isTopLevel top_lvl = id
+ | otherwise = forgetSumCPR
-- See Note [CPR for thunks]
+ handle_thunk_cpr | is_thunk && not_strict = forgetCPR
+ | otherwise = id
+
is_thunk = not (exprIsHNF rhs)
not_strict
= isTopLevel top_lvl -- Top level and recursive things don't
|| isJust rec_flag -- get their demandInfo set at all
- || not (isStrictDmd (idDemandInfo id) || ae_virgin env)
+ || not (isStrictDmd (idDemandInfo var) || ae_virgin env)
-- See Note [Optimistic CPR in the "virgin" case]
unpackTrivial :: CoreExpr -> Maybe Id
@@ -883,6 +890,9 @@ may be CPR'd (via the returned Justs). But in the case of
sums, there may be Nothing alternatives; and that messes
up the sum-type CPR.
+This also applies to nested CPR information: Keep product CPR information, but
+zap sum CPR information therein.
+
Conclusion: only do this for products. It's still not
guaranteed OK for products, but sums definitely lose sometimes.
More information about the ghc-commits
mailing list