diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2018-06-07 11:03:21 +0100 |
---|---|---|
committer | Simon Peyton Jones <simonpj@microsoft.com> | 2018-06-07 11:05:56 +0100 |
commit | c16382d57ed9bf51089a14f079404ff8b4ce6eb2 (patch) | |
tree | eb12c5abb507e3cd3d57890454fc39ddf36828e2 /compiler | |
parent | 7f45906428c97a097ca4d9e1f46d35495380bee1 (diff) | |
download | haskell-c16382d57ed9bf51089a14f079404ff8b4ce6eb2.tar.gz |
Remove ad-hoc special case in occAnal
Back in 1999 I put this ad-hoc code in the Case-handling
code for occAnal:
occAnal env (Case scrut bndr ty alts)
= ...
-- Note [Case binder usage]
-- ~~~~~~~~~~~~~~~~~~~~~~~~
-- The case binder gets a usage of either "many" or "dead", never "one".
-- Reason: we like to inline single occurrences, to eliminate a binding,
-- but inlining a case binder *doesn't* eliminate a binding.
-- We *don't* want to transform
-- case x of w { (p,q) -> f w }
-- into
-- case x of w { (p,q) -> f (p,q) }
tag_case_bndr usage bndr
= (usage', setIdOccInfo bndr final_occ_info)
where
occ_info = lookupDetails usage bndr
usage' = usage `delDetails` bndr
final_occ_info = case occ_info of IAmDead -> IAmDead
_ -> noOccInfo
But the comment looks wrong -- the bad inlining will not happen -- and
I think it relates to some long-ago version of the simplifier.
So I simply removed the special case, which gives more accurate
occurrence-info to the case binder. Interestingly I got a slight
improvement in nofib binary sizes.
--------------------------------------------------------------------------------
Program Size Allocs Runtime Elapsed TotalMem
--------------------------------------------------------------------------------
cacheprof -0.1% +0.2% -0.7% -1.2% +8.6%
--------------------------------------------------------------------------------
Min -0.2% 0.0% -14.5% -30.5% 0.0%
Max -0.1% +0.2% +10.0% +10.0% +25.0%
Geometric Mean -0.2% +0.0% -1.9% -5.4% +0.3%
I have no idea if the improvement in runtime is real. I did look at the
tiny increase in allocation for cacheprof and concluded that it was
unimportant (I forget the details).
Also the more accurate occ-info for the case binder meant that some
inlining happens in one pass that previously took successive passes
for the test dependent/should_compile/dynamic-paper (which has a
known Russel-paradox infinite loop in the simplifier).
In short, a small win: less ad-hoc complexity and slightly smaller
binaries.
Diffstat (limited to 'compiler')
-rw-r--r-- | compiler/simplCore/OccurAnal.hs | 75 |
1 files changed, 36 insertions, 39 deletions
diff --git a/compiler/simplCore/OccurAnal.hs b/compiler/simplCore/OccurAnal.hs index 8ffb6bed69..a8cfbc0868 100644 --- a/compiler/simplCore/OccurAnal.hs +++ b/compiler/simplCore/OccurAnal.hs @@ -1772,29 +1772,12 @@ occAnal env (Case scrut bndr ty alts) case mapAndUnzip occ_anal_alt alts of { (alts_usage_s, alts') -> let alts_usage = foldr orUDs emptyDetails alts_usage_s - (alts_usage1, tagged_bndr) = tag_case_bndr alts_usage bndr + (alts_usage1, tagged_bndr) = tagLamBinder alts_usage bndr total_usage = markAllNonTailCalled scrut_usage `andUDs` alts_usage1 -- Alts can have tail calls, but the scrutinee can't in total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }} where - -- Note [Case binder usage] - -- ~~~~~~~~~~~~~~~~~~~~~~~~ - -- The case binder gets a usage of either "many" or "dead", never "one". - -- Reason: we like to inline single occurrences, to eliminate a binding, - -- but inlining a case binder *doesn't* eliminate a binding. - -- We *don't* want to transform - -- case x of w { (p,q) -> f w } - -- into - -- case x of w { (p,q) -> f (p,q) } - tag_case_bndr usage bndr - = (usage', setIdOccInfo bndr final_occ_info) - where - occ_info = lookupDetails usage bndr - usage' = usage `delDetails` bndr - final_occ_info = case occ_info of IAmDead -> IAmDead - _ -> noOccInfo - alt_env = mkAltEnv env scrut bndr occ_anal_alt = occAnalAlt alt_env @@ -2023,10 +2006,9 @@ occAnalAlt :: (OccEnv, Maybe (Id, CoreExpr)) occAnalAlt (env, scrut_bind) (con, bndrs, rhs) = case occAnal env rhs of { (rhs_usage1, rhs1) -> let - (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage1 bndrs - -- See Note [Binders in case alternatives] - (alt_usg', rhs2) = - wrapAltRHS env scrut_bind alt_usg tagged_bndrs rhs1 + (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage1 bndrs + -- See Note [Binders in case alternatives] + (alt_usg', rhs2) = wrapAltRHS env scrut_bind alt_usg tagged_bndrs rhs1 in (alt_usg', (con, tagged_bndrs, rhs2)) } @@ -2044,12 +2026,16 @@ wrapAltRHS env (Just (scrut_var, let_rhs)) alt_usg bndrs alt_rhs = ( alt_usg' `andUDs` let_rhs_usg , Let (NonRec tagged_scrut_var let_rhs') alt_rhs ) where - captured = any (`usedIn` let_rhs_usg) bndrs + captured = any (`usedIn` let_rhs_usg) bndrs -- Check condition (b) + -- The rhs of the let may include coercion variables -- if the scrutinee was a cast, so we must gather their -- usage. See Note [Gather occurrences of coercion variables] + -- Moreover, the rhs of the let may mention the case-binder, and + -- we want to gather its occ-info as well (let_rhs_usg, let_rhs') = occAnal env let_rhs - (alt_usg', [tagged_scrut_var]) = tagLamBinders alt_usg [scrut_var] + + (alt_usg', tagged_scrut_var) = tagLamBinder alt_usg scrut_var wrapAltRHS _ _ alt_usg _ alt_rhs = (alt_usg, alt_rhs) @@ -2372,10 +2358,10 @@ information right. -} mkAltEnv :: OccEnv -> CoreExpr -> Id -> (OccEnv, Maybe (Id, CoreExpr)) --- Does two things: a) makes the occ_one_shots = OccVanilla --- b) extends the GlobalScruts if possible --- c) returns a proxy mapping, binding the scrutinee --- to the case binder, if possible +-- Does three things: a) makes the occ_one_shots = OccVanilla +-- b) extends the GlobalScruts if possible +-- c) returns a proxy mapping, binding the scrutinee +-- to the case binder, if possible mkAltEnv env@(OccEnv { occ_gbl_scrut = pe }) scrut case_bndr = case stripTicksTopE (const True) scrut of Var v -> add_scrut v case_bndr' @@ -2384,15 +2370,19 @@ mkAltEnv env@(OccEnv { occ_gbl_scrut = pe }) scrut case_bndr _ -> (env { occ_encl = OccVanilla }, Nothing) where - add_scrut v rhs = ( env { occ_encl = OccVanilla, occ_gbl_scrut = pe `extendVarSet` v } + add_scrut v rhs = ( env { occ_encl = OccVanilla + , occ_gbl_scrut = pe `extendVarSet` v } , Just (localise v, rhs) ) - case_bndr' = Var (zapIdOccInfo case_bndr) -- See Note [Zap case binders in proxy bindings] - localise scrut_var = mkLocalIdOrCoVar (localiseName (idName scrut_var)) (idType scrut_var) - -- Localise the scrut_var before shadowing it; we're making a - -- new binding for it, and it might have an External Name, or - -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees] - -- Also we don't want any INLINE or NOINLINE pragmas! + case_bndr' = Var (zapIdOccInfo case_bndr) + -- See Note [Zap case binders in proxy bindings] + + -- Localise the scrut_var before shadowing it; we're making a + -- new binding for it, and it might have an External Name, or + -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees] + -- Also we don't want any INLINE or NOINLINE pragmas! + localise scrut_var = mkLocalIdOrCoVar (localiseName (idName scrut_var)) + (idType scrut_var) {- ************************************************************************ @@ -2592,14 +2582,21 @@ tagLamBinders :: UsageDetails -- Of scope -> [Id] -- Binders -> (UsageDetails, -- Details with binders removed [IdWithOccInfo]) -- Tagged binders +tagLamBinders usage binders + = usage' `seq` (usage', bndrs') + where + (usage', bndrs') = mapAccumR tagLamBinder usage binders + +tagLamBinder :: UsageDetails -- Of scope + -> Id -- Binder + -> (UsageDetails, -- Details with binder removed + IdWithOccInfo) -- Tagged binders -- Used for lambda and case binders -- It copes with the fact that lambda bindings can have a -- stable unfolding, used for join points -tagLamBinders usage binders = usage' `seq` (usage', bndrs') +tagLamBinder usage bndr + = (usage2, bndr') where - (usage', bndrs') = mapAccumR tag_lam usage binders - tag_lam usage bndr = (usage2, bndr') - where occ = lookupDetails usage bndr bndr' = setBinderOcc (markNonTailCalled occ) bndr -- Don't try to make an argument into a join point |