summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--compiler/GHC/Core/Opt/DmdAnal.hs236
-rw-r--r--compiler/GHC/Core/UsageEnv.hs2
-rw-r--r--compiler/GHC/Types/Demand.hs11
3 files changed, 160 insertions, 89 deletions
diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs
index d1bbc232c7..b317fa5ff5 100644
--- a/compiler/GHC/Core/Opt/DmdAnal.hs
+++ b/compiler/GHC/Core/Opt/DmdAnal.hs
@@ -60,6 +60,15 @@ newtype DmdAnalOpts = DmdAnalOpts
{ dmd_strict_dicts :: Bool -- ^ Use strict dictionaries
}
+-- This is a strict alternative to (,)
+-- See Note [Space Leaks in Demand Analysis]
+data WithDmdType a = WithDmdType !DmdType !a
+
+getAnnotated :: WithDmdType a -> a
+getAnnotated (WithDmdType _ a) = a
+
+data DmdResult a b = R !a !b
+
-- | Outputs a new copy of the Core program in which binders have been annotated
-- with demand and strictness information.
--
@@ -67,19 +76,19 @@ newtype DmdAnalOpts = DmdAnalOpts
-- [Stamp out space leaks in demand analysis])
dmdAnalProgram :: DmdAnalOpts -> FamInstEnvs -> [CoreRule] -> CoreProgram -> CoreProgram
dmdAnalProgram opts fam_envs rules binds
- = snd $ go (emptyAnalEnv opts fam_envs) binds
+ = getAnnotated $ go (emptyAnalEnv opts fam_envs) binds
where
-- See Note [Analysing top-level bindings]
-- and Note [Why care for top-level demand annotations?]
- go _ [] = (nopDmdType, [])
+ go _ [] = WithDmdType nopDmdType []
go env (b:bs) = cons_up $ dmdAnalBind TopLevel env topSubDmd b anal_body
where
anal_body env'
- | (body_ty, bs') <- go env' bs
- = (add_exported_uses env' body_ty (bindersOf b), bs')
+ | WithDmdType body_ty bs' <- go env' bs
+ = WithDmdType (add_exported_uses env' body_ty (bindersOf b)) bs'
- cons_up :: (a, b, [b]) -> (a, [b])
- cons_up (dmd_ty, b', bs') = (dmd_ty, b':bs')
+ cons_up :: WithDmdType (DmdResult b [b]) -> WithDmdType [b]
+ cons_up (WithDmdType dmd_ty (R b' bs')) = WithDmdType dmd_ty (b' : bs')
add_exported_uses :: AnalEnv -> DmdType -> [Id] -> DmdType
add_exported_uses env = foldl' (add_exported_use env)
@@ -229,9 +238,9 @@ dmdAnalBind
-> SubDemand -- ^ Demand put on the "body"
-- (important for join points)
-> CoreBind
- -> (AnalEnv -> (DmdType, a)) -- ^ How to analyse the "body", e.g.
+ -> (AnalEnv -> WithDmdType a) -- ^ How to analyse the "body", e.g.
-- where the binding is in scope
- -> (DmdType, CoreBind, a)
+ -> WithDmdType (DmdResult CoreBind a)
dmdAnalBind top_lvl env dmd bind anal_body = case bind of
NonRec id rhs
| useLetUp top_lvl id
@@ -258,12 +267,17 @@ setBindIdDemandInfo top_lvl id dmd = setIdDemandInfo id $ case top_lvl of
-- 'useLetUp').
--
-- This is the LetUp rule in the paper “Higher-Order Cardinality Analysis”.
-dmdAnalBindLetUp :: TopLevelFlag -> AnalEnv -> Id -> CoreExpr -> (AnalEnv -> (DmdType, a)) -> (DmdType, CoreBind, a)
-dmdAnalBindLetUp top_lvl env id rhs anal_body = (final_ty, NonRec id' rhs', body')
+dmdAnalBindLetUp :: TopLevelFlag
+ -> AnalEnv
+ -> Id
+ -> CoreExpr
+ -> (AnalEnv -> WithDmdType a)
+ -> WithDmdType (DmdResult CoreBind a)
+dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec id' rhs') (body'))
where
- (body_ty, body') = anal_body env
- (body_ty', id_dmd) = findBndrDmd env notArgOfDfun body_ty id
- id' = setBindIdDemandInfo top_lvl id id_dmd
+ WithDmdType body_ty body' = anal_body env
+ WithDmdType body_ty' id_dmd = findBndrDmd env notArgOfDfun body_ty id
+ !id' = setBindIdDemandInfo top_lvl id id_dmd
(rhs_ty, rhs') = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd) rhs
-- See Note [Absence analysis for stable unfoldings and RULES]
@@ -282,7 +296,7 @@ dmdAnalBindLetUp top_lvl env id rhs anal_body = (final_ty, NonRec id' rhs', body
-- Local non-recursive definitions without a lambda are handled with LetUp.
--
-- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”.
-dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> (DmdType, a)) -> (DmdType, CoreBind, a)
+dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> WithDmdType a) -> WithDmdType (DmdResult CoreBind a)
dmdAnalBindLetDown top_lvl env dmd bind anal_body = case bind of
NonRec id rhs
| (env', lazy_fv, id1, rhs1) <-
@@ -292,14 +306,15 @@ dmdAnalBindLetDown top_lvl env dmd bind anal_body = case bind of
| (env', lazy_fv, pairs') <- dmdFix top_lvl env dmd pairs
-> do_rest env' lazy_fv pairs' Rec
where
- do_rest env' lazy_fv pairs1 build_bind = (final_ty, build_bind pairs2, body')
+ do_rest env' lazy_fv pairs1 build_bind = WithDmdType final_ty (R (build_bind pairs2) body')
where
- (body_ty, body') = anal_body env'
+ WithDmdType body_ty body' = anal_body env'
-- see Note [Lazy and unleashable free variables]
- dmd_ty = addLazyFVs body_ty lazy_fv
- (!final_ty, id_dmds) = findBndrsDmds env' dmd_ty (map fst pairs1)
- pairs2 = zipWith do_one pairs1 id_dmds
- do_one (id', rhs') dmd = (setBindIdDemandInfo top_lvl id' dmd, rhs')
+ dmd_ty = addLazyFVs body_ty lazy_fv
+ WithDmdType final_ty id_dmds = findBndrsDmds env' dmd_ty (strictMap fst pairs1)
+ -- Important to force this as build_bind might not force it.
+ !pairs2 = strictZipWith do_one pairs1 id_dmds
+ do_one (id', rhs') dmd = ((,) $! setBindIdDemandInfo top_lvl id' dmd) $! rhs'
-- If the actual demand is better than the vanilla call
-- demand, you might think that we might do better to re-analyse
-- the RHS with the stronger demand.
@@ -328,7 +343,7 @@ dmdAnalStar :: AnalEnv
-> CoreExpr -- Should obey the let/app invariant
-> (PlusDmdArg, CoreExpr)
dmdAnalStar env (n :* cd) e
- | (dmd_ty, e') <- dmdAnal env cd e
+ | WithDmdType dmd_ty e' <- dmdAnal env cd e
= ASSERT2( not (isUnliftedType (exprType e)) || exprOkForSpeculation e, ppr e )
-- The argument 'e' should satisfy the let/app invariant
-- See Note [Analysing with absent demand] in GHC.Types.Demand
@@ -337,33 +352,33 @@ dmdAnalStar env (n :* cd) e
-- Main Demand Analsysis machinery
dmdAnal, dmdAnal' :: AnalEnv
-> SubDemand -- The main one takes a *SubDemand*
- -> CoreExpr -> (DmdType, CoreExpr)
+ -> CoreExpr -> WithDmdType CoreExpr
dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $
dmdAnal' env d e
-dmdAnal' _ _ (Lit lit) = (nopDmdType, Lit lit)
-dmdAnal' _ _ (Type ty) = (nopDmdType, Type ty) -- Doesn't happen, in fact
+dmdAnal' _ _ (Lit lit) = WithDmdType nopDmdType (Lit lit)
+dmdAnal' _ _ (Type ty) = WithDmdType nopDmdType (Type ty) -- Doesn't happen, in fact
dmdAnal' _ _ (Coercion co)
- = (unitDmdType (coercionDmdEnv co), Coercion co)
+ = WithDmdType (unitDmdType (coercionDmdEnv co)) (Coercion co)
dmdAnal' env dmd (Var var)
- = (dmdTransform env var dmd, Var var)
+ = WithDmdType (dmdTransform env var dmd) (Var var)
dmdAnal' env dmd (Cast e co)
- = (dmd_ty `plusDmdType` mkPlusDmdArg (coercionDmdEnv co), Cast e' co)
+ = WithDmdType (dmd_ty `plusDmdType` mkPlusDmdArg (coercionDmdEnv co)) (Cast e' co)
where
- (dmd_ty, e') = dmdAnal env dmd e
+ WithDmdType dmd_ty e' = dmdAnal env dmd e
dmdAnal' env dmd (Tick t e)
- = (dmd_ty, Tick t e')
+ = WithDmdType dmd_ty (Tick t e')
where
- (dmd_ty, e') = dmdAnal env dmd e
+ WithDmdType dmd_ty e' = dmdAnal env dmd e
dmdAnal' env dmd (App fun (Type ty))
- = (fun_ty, App fun' (Type ty))
+ = WithDmdType fun_ty (App fun' (Type ty))
where
- (fun_ty, fun') = dmdAnal env dmd fun
+ WithDmdType fun_ty fun' = dmdAnal env dmd fun
-- Lots of the other code is there to make this
-- beautiful, compositional, application rule :-)
@@ -373,7 +388,7 @@ dmdAnal' env dmd (App fun arg)
-- value arguments (#10288)
let
call_dmd = mkCalledOnceDmd dmd
- (fun_ty, fun') = dmdAnal env call_dmd fun
+ WithDmdType fun_ty fun' = dmdAnal env call_dmd fun
(arg_dmd, res_ty) = splitDmdTy fun_ty
(arg_ty, arg') = dmdAnalStar env (dmdTransformThunkDmd arg arg_dmd) arg
in
@@ -385,41 +400,46 @@ dmdAnal' env dmd (App fun arg)
-- , text "arg dmd_ty =" <+> ppr arg_ty
-- , text "res dmd_ty =" <+> ppr res_ty
-- , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ])
- (res_ty `plusDmdType` arg_ty, App fun' arg')
+ WithDmdType (res_ty `plusDmdType` arg_ty) (App fun' arg')
dmdAnal' env dmd (Lam var body)
| isTyVar var
= let
- (body_ty, body') = dmdAnal env dmd body
+ WithDmdType body_ty body' = dmdAnal env dmd body
in
- (body_ty, Lam var body')
+ WithDmdType body_ty (Lam var body')
| otherwise
= let (n, body_dmd) = peelCallDmd dmd
-- body_dmd: a demand to analyze the body
- (body_ty, body') = dmdAnal env body_dmd body
- (lam_ty, var') = annotateLamIdBndr env notArgOfDfun body_ty var
+ WithDmdType body_ty body' = dmdAnal env body_dmd body
+ WithDmdType lam_ty var' = annotateLamIdBndr env notArgOfDfun body_ty var
+ new_dmd_type = multDmdType n lam_ty
in
- (multDmdType n lam_ty, Lam var' body')
+ WithDmdType new_dmd_type (Lam var' body')
dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt bndrs rhs])
-- Only one alternative.
-- If it's a DataAlt, it should be the only constructor of the type.
| is_single_data_alt alt
= let
- (rhs_ty, rhs') = dmdAnal env dmd rhs
- (alt_ty1, dmds) = findBndrsDmds env rhs_ty bndrs
- (alt_ty2, case_bndr_dmd) = findBndrDmd env False alt_ty1 case_bndr
+ WithDmdType rhs_ty rhs' = dmdAnal env dmd rhs
+ WithDmdType alt_ty1 dmds = findBndrsDmds env rhs_ty bndrs
+ WithDmdType alt_ty2 case_bndr_dmd = findBndrDmd env False alt_ty1 case_bndr
-- Evaluation cardinality on the case binder is irrelevant and a no-op.
-- What matters is its nested sub-demand!
(_ :* case_bndr_sd) = case_bndr_dmd
-- Compute demand on the scrutinee
- (bndrs', scrut_sd)
+ -- FORCE the result, otherwise thunks will end up retaining the
+ -- whole DmdEnv
+ !(!bndrs', !scrut_sd)
| DataAlt _ <- alt
, id_dmds <- addCaseBndrDmd case_bndr_sd dmds
-- See Note [Demand on scrutinee of a product case]
- = (setBndrsDemandInfo bndrs id_dmds, mkProd id_dmds)
+ = let !new_info = setBndrsDemandInfo bndrs id_dmds
+ !new_prod = mkProd id_dmds
+ in (new_info, new_prod)
| otherwise
-- __DEFAULT and literal alts. Simply add demands and discard the
-- evaluation cardinality, as we evaluate the scrutinee exactly once.
@@ -432,9 +452,9 @@ dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt bndrs rhs])
| otherwise
= alt_ty2
- (scrut_ty, scrut') = dmdAnal env scrut_sd scrut
+ WithDmdType scrut_ty scrut' = dmdAnal env scrut_sd scrut
res_ty = alt_ty3 `plusDmdType` toPlusDmdArg scrut_ty
- case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd
+ !case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd
in
-- pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut
-- , text "dmd" <+> ppr dmd
@@ -443,16 +463,27 @@ dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt bndrs rhs])
-- , text "scrut_ty" <+> ppr scrut_ty
-- , text "alt_ty" <+> ppr alt_ty2
-- , text "res_ty" <+> ppr res_ty ]) $
- (res_ty, Case scrut' case_bndr' ty [Alt alt bndrs' rhs'])
+ WithDmdType res_ty (Case scrut' case_bndr' ty [Alt alt bndrs' rhs'])
where
is_single_data_alt (DataAlt dc) = isJust $ tyConSingleAlgDataCon_maybe $ dataConTyCon dc
is_single_data_alt _ = True
+
+
+
dmdAnal' env dmd (Case scrut case_bndr ty alts)
= let -- Case expression with multiple alternatives
- (alt_tys, alts') = mapAndUnzip (dmdAnalSumAlt env dmd case_bndr) alts
- (scrut_ty, scrut') = dmdAnal env topSubDmd scrut
- (alt_ty, case_bndr') = annotateBndr env (foldr lubDmdType botDmdType alt_tys) case_bndr
+ WithDmdType alt_ty alts' = combineAltDmds alts
+
+ combineAltDmds [] = WithDmdType botDmdType []
+ combineAltDmds (a:as) =
+ let
+ WithDmdType cur_ty a' = dmdAnalSumAlt env dmd case_bndr a
+ WithDmdType rest_ty as' = combineAltDmds as
+ in WithDmdType (lubDmdType cur_ty rest_ty) (a':as')
+
+ WithDmdType scrut_ty scrut' = dmdAnal env topSubDmd scrut
+ WithDmdType alt_ty1 case_bndr' = annotateBndr env alt_ty case_bndr
-- NB: Base case is botDmdType, for empty case alternatives
-- This is a unit for lubDmdType, and the right result
-- when there really are no alternatives
@@ -460,9 +491,9 @@ dmdAnal' env dmd (Case scrut case_bndr ty alts)
alt_ty2
-- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand"
| exprMayThrowPreciseException fam_envs scrut
- = deferAfterPreciseException alt_ty
+ = deferAfterPreciseException alt_ty1
| otherwise
- = alt_ty
+ = alt_ty1
res_ty = alt_ty2 `plusDmdType` toPlusDmdArg scrut_ty
in
@@ -471,13 +502,13 @@ dmdAnal' env dmd (Case scrut case_bndr ty alts)
-- , text "alt_tys" <+> ppr alt_tys
-- , text "alt_ty2" <+> ppr alt_ty2
-- , text "res_ty" <+> ppr res_ty ]) $
- (res_ty, Case scrut' case_bndr' ty alts')
+ WithDmdType res_ty (Case scrut' case_bndr' ty alts')
dmdAnal' env dmd (Let bind body)
- = (final_ty, Let bind' body')
+ = WithDmdType final_ty (Let bind' body')
where
- (final_ty, bind', body') = dmdAnalBind NotTopLevel env dmd bind go'
- go' env' = dmdAnal env' dmd body
+ !(WithDmdType final_ty (R bind' body')) = dmdAnalBind NotTopLevel env dmd bind go'
+ go' !env' = dmdAnal env' dmd body
-- | A simple, syntactic analysis of whether an expression MAY throw a precise
-- exception when evaluated. It's always sound to return 'True'.
@@ -514,14 +545,16 @@ forcesRealWorld fam_envs ty
| otherwise
= False
-dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> Alt Var -> (DmdType, Alt Var)
+dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> Alt Var -> WithDmdType (Alt Var)
dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs)
- | (rhs_ty, rhs') <- dmdAnal env dmd rhs
- , (alt_ty, dmds) <- findBndrsDmds env rhs_ty bndrs
+ | WithDmdType rhs_ty rhs' <- dmdAnal env dmd rhs
+ , WithDmdType alt_ty dmds <- findBndrsDmds env rhs_ty bndrs
, let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr
-- See Note [Demand on scrutinee of a product case]
id_dmds = addCaseBndrDmd case_bndr_sd dmds
- = (alt_ty, Alt con (setBndrsDemandInfo bndrs id_dmds) rhs')
+ -- Do not put a thunk into the Alt
+ !new_ids = setBndrsDemandInfo bndrs id_dmds
+ = WithDmdType alt_ty (Alt con new_ids rhs')
{-
Note [Analysing with absent demand]
@@ -769,13 +802,13 @@ dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs
| otherwise
= mkCalledOnceDmds rhs_arity topSubDmd
- (rhs_dmd_ty, rhs') = dmdAnal env rhs_dmd rhs
+ WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_dmd rhs
DmdType rhs_fv rhs_dmds rhs_div = rhs_dmd_ty
sig = mkDmdSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div)
id' = id `setIdDmdSig` sig
- env' = extendAnalEnv top_lvl env id' sig
+ !env' = extendAnalEnv top_lvl env id' sig
-- See Note [Aggregated demand for cardinality]
-- FIXME: That Note doesn't explain the following lines at all. The reason
@@ -796,7 +829,7 @@ dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs
rhs_fv2 = rhs_fv1 `keepAliveDmdEnv` bndrRuleAndUnfoldingIds id
-- See Note [Lazy and unleashable free variables]
- (lazy_fv, sig_fv) = partitionVarEnv isWeakDmd rhs_fv2
+ !(!lazy_fv, !sig_fv) = partitionVarEnv isWeakDmd rhs_fv2
-- | If given the (local, non-recursive) let-bound 'Id', 'useLetUp' determines
-- whether we should process the binding up (body before rhs) or down (rhs
@@ -1099,9 +1132,9 @@ dmdFix top_lvl env let_dmd orig_pairs
start_env | first_round = env
| otherwise = nonVirgin env
- start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyDmdEnv)
+ start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyVarEnv)
- ((_,lazy_fv), pairs') = mapAccumL my_downRhs start pairs
+ !((_,!lazy_fv), !pairs') = mapAccumL my_downRhs start pairs
-- mapAccumL: Use the new signature to do the next pair
-- The occurrence analyser has arranged them in a good order
-- so this can significantly reduce the number of iterations needed
@@ -1110,8 +1143,8 @@ dmdFix top_lvl env let_dmd orig_pairs
= -- pprTrace "my_downRhs" (ppr id $$ ppr (idDmdSig id) $$ ppr sig) $
((env', lazy_fv'), (id', rhs'))
where
- (env', lazy_fv1, id', rhs') = dmdAnalRhsSig top_lvl Recursive env let_dmd id rhs
- lazy_fv' = plusVarEnv_C plusDmd lazy_fv lazy_fv1
+ !(!env', !lazy_fv1, !id', !rhs') = dmdAnalRhsSig top_lvl Recursive env let_dmd id rhs
+ !lazy_fv' = plusVarEnv_C plusDmd lazy_fv lazy_fv1
zapIdDmdSig :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]
zapIdDmdSig pairs = [(setIdDmdSig id nopSig, rhs) | (id, rhs) <- pairs ]
@@ -1235,35 +1268,40 @@ dictionaries.
setBndrsDemandInfo :: [Var] -> [Demand] -> [Var]
setBndrsDemandInfo (b:bs) (d:ds)
| isTyVar b = b : setBndrsDemandInfo bs (d:ds)
- | otherwise = setIdDemandInfo b d : setBndrsDemandInfo bs ds
+ | otherwise =
+ let !new_info = setIdDemandInfo b d
+ !vars = setBndrsDemandInfo bs ds
+ in new_info : vars
setBndrsDemandInfo [] ds = ASSERT( null ds ) []
setBndrsDemandInfo bs _ = pprPanic "setBndrsDemandInfo" (ppr bs)
-annotateBndr :: AnalEnv -> DmdType -> Var -> (DmdType, Var)
+annotateBndr :: AnalEnv -> DmdType -> Var -> WithDmdType Var
-- The returned env has the var deleted
-- The returned var is annotated with demand info
-- according to the result demand of the provided demand type
-- No effect on the argument demands
annotateBndr env dmd_ty var
- | isId var = (dmd_ty', setIdDemandInfo var dmd)
- | otherwise = (dmd_ty, var)
+ | isId var = WithDmdType dmd_ty' new_id
+ | otherwise = WithDmdType dmd_ty var
where
- (dmd_ty', dmd) = findBndrDmd env False dmd_ty var
+ new_id = setIdDemandInfo var dmd
+ WithDmdType dmd_ty' dmd = findBndrDmd env False dmd_ty var
annotateLamIdBndr :: AnalEnv
-> DFunFlag -- is this lambda at the top of the RHS of a dfun?
-> DmdType -- Demand type of body
-> Id -- Lambda binder
- -> (DmdType, -- Demand type of lambda
- Id) -- and binder annotated with demand
+ -> WithDmdType Id -- Demand type of lambda
+ -- and binder annotated with demand
annotateLamIdBndr env arg_of_dfun dmd_ty id
-- For lambdas we add the demand to the argument demands
-- Only called for Ids
= ASSERT( isId id )
-- pprTrace "annLamBndr" (vcat [ppr id, ppr dmd_ty, ppr final_ty]) $
- (final_ty, setIdDemandInfo id dmd)
+ WithDmdType final_ty new_id
where
+ new_id = setIdDemandInfo id dmd
-- Watch out! See note [Lambda-bound unfoldings]
final_ty = case maybeUnfoldingTemplate (idUnfolding id) of
Nothing -> main_ty
@@ -1272,7 +1310,7 @@ annotateLamIdBndr env arg_of_dfun dmd_ty id
(unf_ty, _) = dmdAnalStar env dmd unf
main_ty = addDemand dmd dmd_ty'
- (dmd_ty', dmd) = findBndrDmd env arg_of_dfun dmd_ty id
+ WithDmdType dmd_ty' dmd = findBndrDmd env arg_of_dfun dmd_ty id
{- Note [NOINLINE and strictness]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1421,23 +1459,23 @@ lookupSigEnv env id = lookupVarEnv (ae_sigs env) id
nonVirgin :: AnalEnv -> AnalEnv
nonVirgin env = env { ae_virgin = False }
-findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> (DmdType, [Demand])
+findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> WithDmdType [Demand]
-- Return the demands on the Ids in the [Var]
findBndrsDmds env dmd_ty bndrs
= go dmd_ty bndrs
where
- go dmd_ty [] = (dmd_ty, [])
+ go dmd_ty [] = WithDmdType dmd_ty []
go dmd_ty (b:bs)
- | isId b = let (dmd_ty1, dmds) = go dmd_ty bs
- (dmd_ty2, dmd) = findBndrDmd env False dmd_ty1 b
- in (dmd_ty2, dmd : dmds)
+ | isId b = let WithDmdType dmd_ty1 dmds = go dmd_ty bs
+ WithDmdType dmd_ty2 dmd = findBndrDmd env False dmd_ty1 b
+ in WithDmdType dmd_ty2 (dmd : dmds)
| otherwise = go dmd_ty bs
-findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> (DmdType, Demand)
+findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> WithDmdType Demand
-- See Note [Trimming a demand to a type]
findBndrDmd env arg_of_dfun dmd_ty id
= -- pprTrace "findBndrDmd" (ppr id $$ ppr dmd_ty $$ ppr starting_dmd $$ ppr dmd') $
- (dmd_ty', dmd')
+ WithDmdType dmd_ty' dmd'
where
dmd' = strictify $
trimToType starting_dmd (findTypeShape fam_envs id_ty)
@@ -1525,4 +1563,36 @@ relied upon, as the simplifier tends to be very careful about not
duplicating actual function calls.
Also see #11731.
+
+Note [Space Leaks in Demand Analysis]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Ticket: #15455
+MR: !5399
+
+In the past the result of demand analysis was not forced until the whole module
+had finished being analysed. In big programs, this led to a big build up of thunks
+which were all ultimately forced at the end of the analysis.
+
+This was because the return type of the analysis was a lazy pair:
+ dmdAnal :: AnalEnv -> SubDemand -> CoreExpr -> (DmdType, CoreExpr)
+To avoid space leaks we added extra bangs to evaluate the DmdType component eagerly; but
+we were never sure we had added enough.
+The easiest way to systematically fix this was to use a strict pair type for the
+return value of the analysis so that we can be more confident that the result
+is incrementally computed rather than all at the end.
+
+A second, only loosely related point is that
+the updating of Ids was not forced because the result of updating
+an Id was placed into a lazy field in CoreExpr. This meant that until the end of
+demand analysis, the unforced Ids would retain the DmdEnv which the demand information
+was fetch from. Now we are quite careful to force Ids before putting them
+back into core expressions so that we can garbage-collect the environments more eagerly.
+For example see the `Case` branch of `dmdAnal'` where `case_bndr'` is forced
+or `dmdAnalSumAlt`.
+
+The net result of all these improvements is the peak live memory usage of compiling
+jsaddle-dom decreases about 4GB (from 6.5G to 2.5G). A bunch of bytes allocated benchmarks also
+decrease because we allocate a lot fewer thunks which we immediately overwrite and
+also runtime for the pass is faster! Overall, good wins.
+
-}
diff --git a/compiler/GHC/Core/UsageEnv.hs b/compiler/GHC/Core/UsageEnv.hs
index 5c2f613247..b8a6dd1468 100644
--- a/compiler/GHC/Core/UsageEnv.hs
+++ b/compiler/GHC/Core/UsageEnv.hs
@@ -52,7 +52,7 @@ scaleUsage x Bottom = MUsage x
scaleUsage x (MUsage y) = MUsage $ mkMultMul x y
-- For now, we use extra multiplicity Bottom for empty case.
-data UsageEnv = UsageEnv (NameEnv Mult) Bool
+data UsageEnv = UsageEnv !(NameEnv Mult) Bool
unitUE :: NamedThing n => n -> Mult -> UsageEnv
unitUE x w = UsageEnv (unitNameEnv (getName x) w) False
diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs
index b4d9aa9384..84e5a9ac67 100644
--- a/compiler/GHC/Types/Demand.hs
+++ b/compiler/GHC/Types/Demand.hs
@@ -1118,9 +1118,9 @@ keepAliveDmdEnv env vs
-- * Diverges on every code path or not ('dt_div')
data DmdType
= DmdType
- { dt_env :: DmdEnv -- ^ Demand on explicitly-mentioned free variables
- , dt_args :: [Demand] -- ^ Demand on arguments
- , dt_div :: Divergence -- ^ Whether evaluation diverges.
+ { dt_env :: !DmdEnv -- ^ Demand on explicitly-mentioned free variables
+ , dt_args :: ![Demand] -- ^ Demand on arguments
+ , dt_div :: !Divergence -- ^ Whether evaluation diverges.
-- See Note [Demand type Divergence]
}
@@ -1225,9 +1225,10 @@ peelFV :: DmdType -> Var -> (DmdType, Demand)
peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv)
(DmdType fv' ds res, dmd)
where
- fv' = fv `delVarEnv` id
+ -- Force these arguments so that old `Env` is not retained.
+ !fv' = fv `delVarEnv` id
-- See Note [Default demand on free variables and arguments]
- dmd = lookupVarEnv fv id `orElse` defaultFvDmd res
+ !dmd = lookupVarEnv fv id `orElse` defaultFvDmd res
addDemand :: Demand -> DmdType -> DmdType
addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res