Commit c16382d5 authored by Simon Peyton Jones's avatar Simon Peyton Jones

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.
parent 7f459064
......@@ -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
......
case dt of dt { __DEFAULT -> T14626.MkT dt }
case dt of dt [Occ=Once] { __DEFAULT -> T14626.MkT dt }
case v of { T14626.MkT y [Occ=Once] ->
......@@ -17,7 +17,7 @@ test('T9632', normal, compile, [''])
# discussed in #11330.
test('dynamic-paper',
expect_broken_for(11330, ['profasm']),
compile, [''])
compile_fail, [''])
test('T11311', normal, compile, [''])
test('T11405', normal, compile, [''])
test('T11241', normal, compile, [''])
......
......@@ -105,7 +105,9 @@ g [InlPrag=NOUSERINLINE[2]] :: Bool -> Bool -> Int -> Int
(w1 [Occ=Once] :: Bool)
(w2 [Occ=Once!] :: Int) ->
case w2 of { GHC.Types.I# ww1 [Occ=Once] ->
case T13143.$wg w w1 ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 }
case T13143.$wg w w1 ww1 of ww2 [Occ=Once] { __DEFAULT ->
GHC.Types.I# ww2
}
}}]
g = \ (w :: Bool) (w1 :: Bool) (w2 :: Int) ->
case w2 of { GHC.Types.I# ww1 ->
......
......@@ -71,7 +71,9 @@ foo [InlPrag=NOUSERINLINE[2]] :: Int -> Int
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (w [Occ=Once!] :: Int) ->
case w of { GHC.Types.I# ww1 [Occ=Once] ->
case T3717.$wfoo ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 }
case T3717.$wfoo ww1 of ww2 [Occ=Once] { __DEFAULT ->
GHC.Types.I# ww2
}
}}]
foo
= \ (w :: Int) ->
......
......@@ -71,7 +71,9 @@ foo [InlPrag=NOUSERINLINE[2]] :: Int -> Int
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (w [Occ=Once!] :: Int) ->
case w of { GHC.Types.I# ww1 [Occ=Once] ->
case T4930.$wfoo ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 }
case T4930.$wfoo ww1 of ww2 [Occ=Once] { __DEFAULT ->
GHC.Types.I# ww2
}
}}]
foo
= \ (w :: Int) ->
......
......@@ -57,10 +57,10 @@ fun2 :: forall a. [a] -> ((), Int)
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (@ a) (x [Occ=Once!] :: [a]) ->
(T7360.fun5,
case x of wild {
case x of wild [Occ=Once] {
[] -> T7360.fun4;
: _ [Occ=Dead] _ [Occ=Dead] ->
case GHC.List.$wlenAcc @ a wild 0# of ww2 { __DEFAULT ->
case GHC.List.$wlenAcc @ a wild 0# of ww2 [Occ=Once] { __DEFAULT ->
GHC.Types.I# ww2
}
})}]
......
T7865.$wexpensive [InlPrag=NOINLINE]
T7865.$wexpensive
expensive [InlPrag=NOUSERINLINE[0]] :: Int -> Int
case T7865.$wexpensive ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 }
case T7865.$wexpensive ww1 of ww2 [Occ=Once] { __DEFAULT ->
expensive
case T7865.$wexpensive ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 }
case T7865.$wexpensive ww1 of ww2 { __DEFAULT ->
......
......@@ -144,7 +144,9 @@ Roman.foo_go [InlPrag=NOUSERINLINE[2]]
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)
Tmpl= \ (w [Occ=Once] :: Maybe Int) (w1 [Occ=Once] :: Maybe Int) ->
case Roman.$wgo w w1 of ww { __DEFAULT -> GHC.Types.I# ww }}]
case Roman.$wgo w w1 of ww [Occ=Once] { __DEFAULT ->
GHC.Types.I# ww
}}]
Roman.foo_go
= \ (w :: Maybe Int) (w1 :: Maybe Int) ->
case Roman.$wgo w w1 of ww { __DEFAULT -> GHC.Types.I# ww }
......@@ -177,7 +179,7 @@ foo :: Int -> Int
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (n [Occ=Once!] :: Int) ->
case n of n1 { GHC.Types.I# _ [Occ=Dead] ->
case n of n1 [Occ=Once] { GHC.Types.I# _ [Occ=Dead] ->
Roman.foo_go (GHC.Base.Just @ Int n1) Roman.foo1
}}]
foo
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment