diff options
-rw-r--r-- | compiler/GHC/Core/Opt/DmdAnal.hs | 25 | ||||
-rw-r--r-- | compiler/GHC/Types/Demand.hs | 28 |
2 files changed, 23 insertions, 30 deletions
diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs index fa4bed48f0..c52b079c61 100644 --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -101,13 +101,21 @@ dmdAnalProgram opts fam_envs rules binds add_exported_use env dmd_ty id | isExportedId id || elemVarSet id rule_fvs -- See Note [Absence analysis for stable unfoldings and RULES] - = dmd_ty `plusDmdType` fst (dmdAnalStar env topDmd (Var id)) + = keepAlive env id dmd_ty | otherwise = dmd_ty rule_fvs :: IdSet rule_fvs = rulesRhsFreeIds rules +keepAlive :: AnalEnv -> Id -> DmdType -> DmdType +-- See Note [Absence analysis for stable unfoldings and RULES] +keepAlive env id ty = plusDmdType ty (fst $ dmdAnalStar env topDmd $ Var id) + +keepAliveSet :: AnalEnv -> IdSet -> DmdType -> DmdType +-- See Note [Absence analysis for stable unfoldings and RULES] +keepAliveSet env ids ty = nonDetStrictFoldVarSet (keepAlive env) ty ids + -- | We attach useful (e.g. not 'topDmd') 'idDemandInfo' to top-level bindings -- that satisfy this function. -- @@ -284,8 +292,7 @@ dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec (rhs_ty, rhs') = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd') rhs -- See Note [Absence analysis for stable unfoldings and RULES] - rule_fvs = bndrRuleAndUnfoldingIds id - final_ty = body_ty' `plusDmdType` rhs_ty `keepAliveDmdType` rule_fvs + final_ty = keepAliveSet env (bndrRuleAndUnfoldingIds id) (body_ty' `plusDmdType` rhs_ty) -- | Let bindings can be processed in two ways: -- Down (RHS before body) or Up (body before RHS). @@ -867,7 +874,7 @@ dmdAnalRhsSig -- See Note [NOINLINE and strictness] dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr sig $$ ppr lazy_fv) $ - (env', lazy_fv, id', rhs') + (env', emptyVarEnv, id', rhs') where rhs_arity = idArity id -- See Note [Demand signatures are computed for a threshold demand based on idArity] @@ -888,7 +895,7 @@ dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs WithDmdType rhs_dmd_ty rhs' = dmdAnal (adjustInlFun id 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) + sig = mkDmdSigForArity rhs_arity sig_ty id' = id `setIdDmdSig` sig !env' = extendAnalEnv top_lvl env id' sig @@ -905,15 +912,13 @@ dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs -- we'd have to do an additional iteration. reuseEnv makes sure that -- we never get used-once info for FVs of recursive functions. -- See #14816 where we try to get rid of reuseEnv. - rhs_fv1 = case rec_flag of + rhs_fv' = case rec_flag of Recursive -> reuseEnv rhs_fv NonRecursive -> rhs_fv + dmd_ty' = DmdType rhs_fv' rhs_dmds rhs_div -- See Note [Absence analysis for stable unfoldings and RULES] - rhs_fv2 = rhs_fv1 `keepAliveDmdEnv` bndrRuleAndUnfoldingIds id - - -- See Note [Lazy and unleashable free variables] - !(!lazy_fv, !sig_fv) = partitionVarEnv isWeakDmd rhs_fv2 + sig_ty = keepAliveSet env (bndrRuleAndUnfoldingIds id) dmd_ty' unboxableResultWidth :: AnalEnv -> Id -> Maybe Arity unboxableResultWidth env id diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs index ed7ef25aa8..b4f6f3e549 100644 --- a/compiler/GHC/Types/Demand.hs +++ b/compiler/GHC/Types/Demand.hs @@ -98,7 +98,6 @@ import GHC.Utils.Binary import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import Data.Function @@ -880,20 +879,7 @@ isUsedOnceDmd (n :* _) = isUsedOnce n -- signatures for analysis performance reasons. -- See Note [Lazy and unleashable free variables] in "GHC.Core.Opt.DmdAnal". isWeakDmd :: Demand -> Bool -isWeakDmd dmd@(n :* _) = not (isStrict n) && is_plus_idem_dmd dmd - where - -- @is_plus_idem_* thing@ checks whether @thing `plus` thing = thing@, - -- e.g. if @thing@ is idempotent wrt. to @plus@. - -- is_plus_idem_card n = plusCard n n == n - is_plus_idem_card = isCardNonOnce - -- is_plus_idem_dmd dmd = plusDmd dmd dmd == dmd - is_plus_idem_dmd AbsDmd = True - is_plus_idem_dmd BotDmd = True - is_plus_idem_dmd (n :* sd) = is_plus_idem_card n && is_plus_idem_sub_dmd sd - -- is_plus_idem_sub_dmd sd = plusSubDmd sd sd == sd - is_plus_idem_sub_dmd (Poly _ n) = assert (isCardNonOnce n) True - is_plus_idem_sub_dmd (Prod _ ds) = all is_plus_idem_dmd ds - is_plus_idem_sub_dmd (Call n _) = is_plus_idem_card n -- See Note [Call demands are relative] +isWeakDmd _ = False evalDmd :: Demand evalDmd = C_1N :* topSubDmd @@ -1503,11 +1489,13 @@ data DmdType instance Eq DmdType where (==) (DmdType fv1 ds1 div1) - (DmdType fv2 ds2 div2) = nonDetUFMToList fv1 == nonDetUFMToList fv2 - -- It's OK to use nonDetUFMToList here because we're testing for - -- equality and even though the lists will be in some arbitrary - -- Unique order, it is the same order for both - && ds1 == ds2 && div1 == div2 + (DmdType fv2 ds2 div2) = div1 == div2 && ds1 == ds2 -- cheap checks first + && as_list div1 fv1 == as_list div2 fv2 + where + as_list div = filter (\(_, dmd) -> dmd /= defaultFvDmd div) . nonDetUFMToList + -- It's OK to use nonDetUFMToList here because we're testing for + -- equality and even though the lists will be in some arbitrary + -- Unique order, it is the same order for both -- | Compute the least upper bound of two 'DmdType's elicited /by the same -- incoming demand/! |