[commit: ghc] wip/nested-cpr: Rename postProcessDmdType to postProcessUnsat and use* to reuse* (779dca7)
git at git.haskell.org
git at git.haskell.org
Mon Dec 16 20:59:14 UTC 2013
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/nested-cpr
Link : http://ghc.haskell.org/trac/ghc/changeset/779dca75eb383c057dc6a8b065727265f0ec1401/ghc
>---------------------------------------------------------------
commit 779dca75eb383c057dc6a8b065727265f0ec1401
Author: Joachim Breitner <mail at joachim-breitner.de>
Date: Thu Dec 12 16:12:00 2013 +0000
Rename postProcessDmdType to postProcessUnsat and use* to reuse*
>---------------------------------------------------------------
779dca75eb383c057dc6a8b065727265f0ec1401
compiler/basicTypes/Demand.lhs | 81 ++++++++++++++++++++++------------------
compiler/stranal/DmdAnal.lhs | 4 +-
2 files changed, 46 insertions(+), 39 deletions(-)
diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index 3ca8466..cdb60af 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -38,13 +38,13 @@ module Demand (
evalDmd, cleanEvalDmd, cleanEvalProdDmd, isStrictDmd,
splitDmdTy, splitFVs,
deferAfterIO,
- postProcessDmdType, postProcessDmdTypeM,
+ postProcessUnsat, postProcessDmdTypeM,
splitProdDmd, splitProdDmd_maybe, peelCallDmd, mkCallDmd,
dmdTransformSig, dmdTransformDataConSig, dmdTransformDictSelSig,
argOneShots, argsOneShots,
- isSingleUsed, useEnv, zapDemand, zapStrictSig,
+ isSingleUsed, reuseEnv, zapDemand, zapStrictSig,
worthSplittingArgDmd, worthSplittingThunkDmd,
@@ -400,23 +400,25 @@ Compare with: (C) making Used win for both, but UProd win for lub
\begin{code}
-markAsUsedDmd :: MaybeUsed -> MaybeUsed
-markAsUsedDmd Abs = Abs
-markAsUsedDmd (Use _ a) = Use Many (markUsed a)
+-- If a demand is used multiple times (i.e. reused), than any use-once
+-- mentioned there, that is not protected by a UCall, can happen many times.
+markReusedDmd :: MaybeUsed -> MaybeUsed
+markReusedDmd Abs = Abs
+markReusedDmd (Use _ a) = Use Many (markReused a)
-markUsed :: UseDmd -> UseDmd
-markUsed (UCall _ u) = UCall Many u -- No need to recurse here
-markUsed (UProd ux) = UProd (map markAsUsedDmd ux)
-markUsed u = u
+markReused :: UseDmd -> UseDmd
+markReused (UCall _ u) = UCall Many u -- No need to recurse here
+markReused (UProd ux) = UProd (map markReusedDmd ux)
+markReused u = u
isUsedMU :: MaybeUsed -> Bool
--- True <=> markAsUsedDmd d = d
+-- True <=> markReusedDmd d = d
isUsedMU Abs = True
isUsedMU (Use One _) = False
isUsedMU (Use Many u) = isUsedU u
isUsedU :: UseDmd -> Bool
--- True <=> markUsed d = d
+-- True <=> markReused d = d
isUsedU Used = True
isUsedU UHead = True
isUsedU (UProd us) = all isUsedMU us
@@ -1121,34 +1123,39 @@ toCleanDmd (JD { strd = s, absd = u })
(Lazy, Use c u') -> (CD { sd = HeadStr, ud = u' }, Just (True, c))
(_, Abs) -> (CD { sd = HeadStr, ud = Used }, Nothing)
+-- This is used in dmdAnalStar when post-processing
+-- a function's argument demand. So we only care about what
+-- does to free variables, and whether it terminates.
postProcessDmdTypeM :: DeferAndUseM -> DmdType -> DmdType
postProcessDmdTypeM Nothing _ = nopDmdType
-- Incoming demand was Absent, so just discard all usage information
-- We only processed the thing at all to analyse the body
-- See Note [Always analyse in virgin pass]
-postProcessDmdTypeM (Just du) ty = postProcessDmdType du ty
-
-postProcessDmdType :: DeferAndUse -> DmdType -> DmdType
-postProcessDmdType (True, Many) ty = deferAndUse ty
-postProcessDmdType (False, Many) ty = useType ty
-postProcessDmdType (True, One) ty = deferType ty
-postProcessDmdType (False, One) ty = ty
-
-deferType, useType, deferAndUse :: DmdType -> DmdType
-deferType (DmdType fv ds _) = DmdType (deferEnv fv) (map deferDmd ds) topRes
-useType (DmdType fv ds res_ty) = DmdType (useEnv fv) (map useDmd ds) res_ty
-deferAndUse (DmdType fv ds _) = DmdType (deferUseEnv fv) (map deferUseDmd ds) topRes
-
-deferEnv, useEnv, deferUseEnv :: DmdEnv -> DmdEnv
-deferEnv fv = mapVarEnv deferDmd fv
-useEnv fv = mapVarEnv useDmd fv
-deferUseEnv fv = mapVarEnv deferUseDmd fv
-
-deferDmd, useDmd, deferUseDmd :: JointDmd -> JointDmd
-deferDmd (JD {strd=_, absd=a}) = mkJointDmd Lazy a
-useDmd (JD {strd=d, absd=a}) = mkJointDmd d (markAsUsedDmd a)
-deferUseDmd (JD {strd=_, absd=a}) = mkJointDmd Lazy (markAsUsedDmd a)
-
+postProcessDmdTypeM (Just du) ty = postProcessUnsat du ty
+
+postProcessUnsat :: DeferAndUse -> DmdType -> DmdType
+postProcessUnsat (True, Many) ty = deferReuse ty
+postProcessUnsat (False, Many) ty = reuseType ty
+postProcessUnsat (True, One) ty = deferType ty
+postProcessUnsat (False, One) ty = ty
+
+deferType, reuseType, deferReuse :: DmdType -> DmdType
+deferType (DmdType fv ds _) = DmdType (deferEnv fv) (map deferDmd ds) topRes
+reuseType (DmdType fv ds res_ty) = DmdType (reuseEnv fv) (map reuseDmd ds) res_ty
+deferReuse (DmdType fv ds _) = DmdType (deferReuseEnv fv) (map deferReuseDmd ds) topRes
+
+deferEnv, reuseEnv, deferReuseEnv :: DmdEnv -> DmdEnv
+deferEnv fv = mapVarEnv deferDmd fv
+reuseEnv fv = mapVarEnv reuseDmd fv
+deferReuseEnv fv = mapVarEnv deferReuseDmd fv
+
+deferDmd, reuseDmd, deferReuseDmd :: JointDmd -> JointDmd
+deferDmd (JD {strd=_, absd=a}) = mkJointDmd Lazy a
+reuseDmd (JD {strd=d, absd=a}) = mkJointDmd d (markReusedDmd a)
+deferReuseDmd (JD {strd=_, absd=a}) = mkJointDmd Lazy (markReusedDmd a)
+
+-- Peels one call level from the demand, and also returns
+-- whether it was unsaturated (separately for strictness and usage)
peelCallDmd :: CleanDemand -> (CleanDemand, DeferAndUse)
-- Exploiting the fact that
-- on the strictness side C(B) = B
@@ -1352,8 +1359,8 @@ dmdTransformSig :: StrictSig -> CleanDemand -> DmdType
-- signature is fun_sig, with demand dmd. We return the demand
-- that the function places on its context (eg its args)
dmdTransformSig (StrictSig dmd_ty@(DmdType _ arg_ds _)) cd
- = postProcessDmdType (peelManyCalls arg_ds cd) dmd_ty
- -- NB: it's important to use postProcessDmdType, and not
+ = postProcessUnsat (peelManyCalls arg_ds cd) dmd_ty
+ -- NB: it's important to use postProcessUnsat, and not
-- just return nopDmdType for unsaturated calls
-- Consider let { f x y = p + x } in f 1
-- The application isn't saturated, but we must nevertheless propagate
@@ -1391,7 +1398,7 @@ dmdTransformDictSelSig :: StrictSig -> CleanDemand -> DmdType
dmdTransformDictSelSig (StrictSig (DmdType _ [dict_dmd] _)) cd
| (cd',defer_use) <- peelCallDmd cd
, Just jds <- splitProdDmd_maybe dict_dmd
- = postProcessDmdType defer_use $
+ = postProcessUnsat defer_use $
DmdType emptyDmdEnv [mkOnceUsedDmd $ mkProdDmd $ map (enhance cd') jds] topRes
| otherwise
= nopDmdType -- See Note [Demand transformer for a dictionary selector]
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index 01c990a..cbdcc67 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -206,7 +206,7 @@ dmdAnal env dmd (Lam var body)
(body_ty, body') = dmdAnal env' body_dmd body
(lam_ty, var') = annotateLamIdBndr env notArgOfDfun body_ty one_shot var
in
- (postProcessDmdType defer_and_use lam_ty, Lam var' body')
+ (postProcessUnsat defer_and_use lam_ty, Lam var' body')
dmdAnal env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)])
-- Only one alternative with a product constructor
@@ -619,7 +619,7 @@ dmdAnalRhs top_lvl rec_flag env id rhs
-- See Note [Lazy and unleashable free variables]
-- See Note [Aggregated demand for cardinality]
rhs_fv1 = case rec_flag of
- Just bs -> useEnv (delVarEnvList rhs_fv bs)
+ Just bs -> reuseEnv (delVarEnvList rhs_fv bs)
Nothing -> rhs_fv
(lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv1
More information about the ghc-commits
mailing list