Commit 367e603d authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Refactor case-merging and identical-alternative optimisations

These two optimisations were originally done by SimplUtils.mkCase
*after* all the pieces have been simplified.  Some while ago I
moved them *before*, so they were done by SimplUtils.prepareAlts.
It think the reason was that I couldn't rely on the dead-binder 
information on OutIds, and that info is useful in these optimisations.

However, 
 (a) Other changes (notably moving case-binder-swap to OccurAnal)
     have meant that dead-binder information is accurate in 
     OutIds

 (b) When there is a cascade of case-merges, they happen in 
     one sweep if you do it after, but in many sweeps if you
     do it before.  Reason: doing it after means you are looking
     at nice simplified Core.
parent d21c80ea
......@@ -6,7 +6,7 @@
\begin{code}
module SimplUtils (
-- Rebuilding
mkLam, mkCase, prepareAlts, bindCaseBndr,
mkLam, mkCase, prepareAlts,
-- Inlining,
preInlineUnconditionally, postInlineUnconditionally,
......@@ -1296,83 +1296,61 @@ Historical note: if you use let-bindings instead of a substitution, beware of th
prepareAlts tries these things:
1. If several alternatives are identical, merge them into
a single DEFAULT alternative. I've occasionally seen this
making a big difference:
case e of =====> case e of
C _ -> f x D v -> ....v....
D v -> ....v.... DEFAULT -> f x
DEFAULT -> f x
The point is that we merge common RHSs, at least for the DEFAULT case.
[One could do something more elaborate but I've never seen it needed.]
To avoid an expensive test, we just merge branches equal to the *first*
alternative; this picks up the common cases
a) all branches equal
b) some branches equal to the DEFAULT (which occurs first)
1. Eliminate alternatives that cannot match, including the
DEFAULT alternative.
2. Case merging:
case e of b { ==> case e of b {
p1 -> rhs1 p1 -> rhs1
... ...
pm -> rhsm pm -> rhsm
_ -> case b of b' { pn -> let b'=b in rhsn
pn -> rhsn ...
... po -> let b'=b in rhso
po -> rhso _ -> let b'=b in rhsd
_ -> rhsd
}
which merges two cases in one case when -- the default alternative of
the outer case scrutises the same variable as the outer case This
transformation is called Case Merging. It avoids that the same
variable is scrutinised multiple times.
2. If the DEFAULT alternative can match only one possible constructor,
then make that constructor explicit.
e.g.
case e of x { DEFAULT -> rhs }
===>
case e of x { (a,b) -> rhs }
where the type is a single constructor type. This gives better code
when rhs also scrutinises x or e.
3. Returns a list of the constructors that cannot holds in the
DEFAULT alternative (if there is one)
The case where transformation (1) showed up was like this (lib/std/PrelCError.lhs):
Here "cannot match" includes knowledge from GADTs
x | p `is` 1 -> e1
| p `is` 2 -> e2
...etc...
It's a good idea do do this stuff before simplifying the alternatives, to
avoid simplifying alternatives we know can't happen, and to come up with
the list of constructors that are handled, to put into the IdInfo of the
case binder, for use when simplifying the alternatives.
where @is@ was something like
p `is` n = p /= (-1) && p == n
Eliminating the default alternative in (1) isn't so obvious, but it can
happen:
This gave rise to a horrible sequence of cases
data Colour = Red | Green | Blue
case p of
(-1) -> $j p
1 -> e1
DEFAULT -> $j p
f x = case x of
Red -> ..
Green -> ..
DEFAULT -> h x
and similarly in cascade for all the join points!
h y = case y of
Blue -> ..
DEFAULT -> [ case y of ... ]
Note [Dead binders]
~~~~~~~~~~~~~~~~~~~~
We do this *here*, looking at un-simplified alternatives, because we
have to check that r doesn't mention the variables bound by the
pattern in each alternative, so the binder-info is rather useful.
If we inline h into f, the default case of the inlined h can't happen.
If we don't notice this, we may end up filtering out *all* the cases
of the inner case y, which give us nowhere to go!
\begin{code}
prepareAlts :: SimplEnv -> OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt])
prepareAlts env scrut case_bndr' alts
= do { dflags <- getDOptsSmpl
; alts <- combineIdenticalAlts case_bndr' alts
; let (alts_wo_default, maybe_deflt) = findDefault alts
prepareAlts :: OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt])
prepareAlts scrut case_bndr' alts
= do { let (alts_wo_default, maybe_deflt) = findDefault alts
alt_cons = [con | (con,_,_) <- alts_wo_default]
imposs_deflt_cons = nub (imposs_cons ++ alt_cons)
-- "imposs_deflt_cons" are handled
-- EITHER by the context,
-- OR by a non-DEFAULT branch in this case expression.
; default_alts <- prepareDefault dflags env case_bndr' mb_tc_app
; default_alts <- prepareDefault case_bndr' mb_tc_app
imposs_deflt_cons maybe_deflt
; let trimmed_alts = filterOut impossible_alt alts_wo_default
merged_alts = mergeAlts trimmed_alts default_alts
merged_alts = mergeAlts trimmed_alts default_alts
-- We need the mergeAlts in case the new default_alt
-- has turned into a constructor alternative.
-- The merge keeps the inner DEFAULT at the front, if there is one
......@@ -1393,29 +1371,7 @@ prepareAlts env scrut case_bndr' alts
impossible_alt _ = False
--------------------------------------------------
-- 1. Merge identical branches
--------------------------------------------------
combineIdenticalAlts :: OutId -> [InAlt] -> SimplM [InAlt]
combineIdenticalAlts case_bndr ((_con1,bndrs1,rhs1) : con_alts)
| all isDeadBinder bndrs1, -- Remember the default
length filtered_alts < length con_alts -- alternative comes first
-- Also Note [Dead binders]
= do { tick (AltMerge case_bndr)
; return ((DEFAULT, [], rhs1) : filtered_alts) }
where
filtered_alts = filter keep con_alts
keep (_con,bndrs,rhs) = not (all isDeadBinder bndrs && rhs `cheapEqExpr` rhs1)
combineIdenticalAlts _ alts = return alts
-------------------------------------------------------------------------
-- Prepare the default alternative
-------------------------------------------------------------------------
prepareDefault :: DynFlags
-> SimplEnv
-> OutId -- Case binder; need just for its type. Note that as an
prepareDefault :: OutId -- Case binder; need just for its type. Note that as an
-- OutId, it has maximum information; this is important.
-- Test simpl013 is an example
-> Maybe (TyCon, [Type]) -- Type of scrutinee, decomposed
......@@ -1423,42 +1379,9 @@ prepareDefault :: DynFlags
-> Maybe InExpr -- Rhs
-> SimplM [InAlt] -- Still unsimplified
-- We use a list because it's what mergeAlts expects,
-- And becuase case-merging can cause many to show up
------- Merge nested cases ----------
prepareDefault dflags env outer_bndr _bndr_ty imposs_cons (Just deflt_rhs)
| dopt Opt_CaseMerge dflags
, Case (Var inner_scrut_var) inner_bndr _ inner_alts <- deflt_rhs
, DoneId inner_scrut_var' <- substId env inner_scrut_var
-- Remember, inner_scrut_var is an InId, but outer_bndr is an OutId
, inner_scrut_var' == outer_bndr
-- NB: the substId means that if the outer scrutinee was a
-- variable, and inner scrutinee is the same variable,
-- then inner_scrut_var' will be outer_bndr
-- via the magic of simplCaseBinder
= do { tick (CaseMerge outer_bndr)
; let munge_rhs rhs = bindCaseBndr inner_bndr (Var outer_bndr) rhs
; return [(con, args, munge_rhs rhs) | (con, args, rhs) <- inner_alts,
not (con `elem` imposs_cons) ]
-- NB: filter out any imposs_cons. Example:
-- case x of
-- A -> e1
-- DEFAULT -> case x of
-- A -> e2
-- B -> e3
-- When we merge, we must ensure that e1 takes
-- precedence over e2 as the value for A!
}
-- Warning: don't call prepareAlts recursively!
-- Firstly, there's no point, because inner alts have already had
-- mkCase applied to them, so they won't have a case in their default
-- Secondly, if you do, you get an infinite loop, because the bindCaseBndr
-- in munge_rhs may put a case into the DEFAULT branch!
--------- Fill in known constructor -----------
prepareDefault _ _ case_bndr (Just (tycon, inst_tys)) imposs_cons (Just deflt_rhs)
prepareDefault case_bndr (Just (tycon, inst_tys)) imposs_cons (Just deflt_rhs)
| -- This branch handles the case where we are
-- scrutinisng an algebraic data type
isAlgTyCon tycon -- It's a data type, tuple, or unboxed tuples.
......@@ -1477,7 +1400,7 @@ prepareDefault _ _ case_bndr (Just (tycon, inst_tys)) imposs_cons (Just deflt_rh
-- which would be quite legitmate. But it's a really obscure corner, and
-- not worth wasting code on.
, let imposs_data_cons = [con | DataAlt con <- imposs_cons] -- We now know it's a data type
impossible con = con `elem` imposs_data_cons || dataConCannotMatch inst_tys con
impossible con = con `elem` imposs_data_cons || dataConCannotMatch inst_tys con
= case filterOut impossible all_cons of
[] -> return [] -- Eliminate the default alternative
-- altogether if it can't match
......@@ -1492,27 +1415,48 @@ prepareDefault _ _ case_bndr (Just (tycon, inst_tys)) imposs_cons (Just deflt_rh
_ -> return [(DEFAULT, [], deflt_rhs)]
| debugIsOn, isAlgTyCon tycon, not (isOpenTyCon tycon), null (tyConDataCons tycon)
-- This can legitimately happen for type families, so don't report that
-- Check for no data constructors
-- This can legitimately happen for type families, so don't report that
= pprTrace "prepareDefault" (ppr case_bndr <+> ppr tycon)
$ return [(DEFAULT, [], deflt_rhs)]
--------- Catch-all cases -----------
prepareDefault _dflags _env _case_bndr _bndr_ty _imposs_cons (Just deflt_rhs)
prepareDefault _case_bndr _bndr_ty _imposs_cons (Just deflt_rhs)
= return [(DEFAULT, [], deflt_rhs)]
prepareDefault _dflags _env _case_bndr _bndr_ty _imposs_cons Nothing
prepareDefault _case_bndr _bndr_ty _imposs_cons Nothing
= return [] -- No default branch
\end{code}
=================================================================================
%************************************************************************
%* *
mkCase
%* *
%************************************************************************
mkCase tries these things
1. Eliminate the case altogether if possible
1. Merge Nested Cases
2. Case-identity:
case e of b { ==> case e of b {
p1 -> rhs1 p1 -> rhs1
... ...
pm -> rhsm pm -> rhsm
_ -> case b of b' { pn -> let b'=b in rhsn
pn -> rhsn ...
... po -> let b'=b in rhso
po -> rhso _ -> let b'=b in rhsd
_ -> rhsd
}
which merges two cases in one case when -- the default alternative of
the outer case scrutises the same variable as the outer case. This
transformation is called Case Merging. It avoids that the same
variable is scrutinised multiple times.
2. Eliminate Identity Case
case e of ===> e
True -> True;
......@@ -1520,19 +1464,99 @@ mkCase tries these things
and similar friends.
3. Merge identical alternatives.
If several alternatives are identical, merge them into
a single DEFAULT alternative. I've occasionally seen this
making a big difference:
case e of =====> case e of
C _ -> f x D v -> ....v....
D v -> ....v.... DEFAULT -> f x
DEFAULT -> f x
The point is that we merge common RHSs, at least for the DEFAULT case.
[One could do something more elaborate but I've never seen it needed.]
To avoid an expensive test, we just merge branches equal to the *first*
alternative; this picks up the common cases
a) all branches equal
b) some branches equal to the DEFAULT (which occurs first)
The case where Merge Identical Alternatives transformation showed up
was like this (base/Foreign/C/Err/Error.lhs):
x | p `is` 1 -> e1
| p `is` 2 -> e2
...etc...
where @is@ was something like
p `is` n = p /= (-1) && p == n
This gave rise to a horrible sequence of cases
case p of
(-1) -> $j p
1 -> e1
DEFAULT -> $j p
and similarly in cascade for all the join points!
\begin{code}
mkCase :: OutExpr -> OutId -> [OutAlt] -- Increasing order
-> SimplM OutExpr
mkCase, mkCase1, mkCase2
:: DynFlags
-> OutExpr -> OutId
-> [OutAlt] -- Alternatives in standard (increasing) order
-> SimplM OutExpr
--------------------------------------------------
-- 2. Identity case
-- 1. Merge Nested Cases
--------------------------------------------------
mkCase scrut case_bndr alts -- Identity case
mkCase dflags scrut outer_bndr ((DEFAULT, _, deflt_rhs) : outer_alts)
| dopt Opt_CaseMerge dflags
, Case (Var inner_scrut_var) inner_bndr _ inner_alts <- deflt_rhs
, inner_scrut_var == outer_bndr
= do { tick (CaseMerge outer_bndr)
; let wrap_alt (con, args, rhs) = ASSERT( outer_bndr `notElem` args )
(con, args, wrap_rhs rhs)
-- Simplifier's no-shadowing invariant should ensure
-- that outer_bndr is not shadowed by the inner patterns
wrap_rhs rhs = Let (NonRec inner_bndr (Var outer_bndr)) rhs
-- The let is OK even for unboxed binders,
wrapped_alts | isDeadBinder inner_bndr = inner_alts
| otherwise = map wrap_alt inner_alts
merged_alts = mergeAlts outer_alts wrapped_alts
-- NB: mergeAlts gives priority to the left
-- case x of
-- A -> e1
-- DEFAULT -> case x of
-- A -> e2
-- B -> e3
-- When we merge, we must ensure that e1 takes
-- precedence over e2 as the value for A!
; mkCase1 dflags scrut outer_bndr merged_alts
}
-- Warning: don't call mkCase recursively!
-- Firstly, there's no point, because inner alts have already had
-- mkCase applied to them, so they won't have a case in their default
-- Secondly, if you do, you get an infinite loop, because the bindCaseBndr
-- in munge_rhs may put a case into the DEFAULT branch!
mkCase dflags scrut bndr alts = mkCase1 dflags scrut bndr alts
--------------------------------------------------
-- 2. Eliminate Identity Case
--------------------------------------------------
mkCase1 _dflags scrut case_bndr alts -- Identity case
| all identity_alt alts
= do tick (CaseIdentity case_bndr)
return (re_cast scrut)
= do { tick (CaseIdentity case_bndr)
; return (re_cast scrut) }
where
identity_alt (con, args, rhs) = check_eq con args (de_cast rhs)
......@@ -1560,22 +1584,93 @@ mkCase scrut case_bndr alts -- Identity case
(_,_,Cast _ co) -> Cast scrut co
_ -> scrut
--------------------------------------------------
-- 3. Merge Identical Alternatives
--------------------------------------------------
mkCase1 dflags scrut case_bndr ((_con1,bndrs1,rhs1) : con_alts)
| all isDeadBinder bndrs1 -- Remember the default
, length filtered_alts < length con_alts -- alternative comes first
-- Also Note [Dead binders]
= do { tick (AltMerge case_bndr)
; mkCase2 dflags scrut case_bndr alts' }
where
alts' = (DEFAULT, [], rhs1) : filtered_alts
filtered_alts = filter keep con_alts
keep (_con,bndrs,rhs) = not (all isDeadBinder bndrs && rhs `cheapEqExpr` rhs1)
mkCase1 dflags scrut bndr alts = mkCase2 dflags scrut bndr alts
--------------------------------------------------
-- Catch-all
--------------------------------------------------
mkCase scrut bndr alts = return (Case scrut bndr (coreAltsType alts) alts)
mkCase2 _dflags scrut bndr alts
= return (Case scrut bndr (coreAltsType alts) alts)
\end{code}
When adding auxiliary bindings for the case binder, it's worth checking if
its dead, because it often is, and occasionally these mkCase transformations
cascade rather nicely.
\begin{code}
bindCaseBndr :: Id -> CoreExpr -> CoreExpr -> CoreExpr
bindCaseBndr bndr rhs body
| isDeadBinder bndr = body
| otherwise = bindNonRec bndr rhs body
\end{code}
Note [Dead binders]
~~~~~~~~~~~~~~~~~~~~
Note that dead-ness is maintained by the simplifier, so that it is
accurate after simplification as well as before.
Note [Cascading case merge]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Case merging should cascade in one sweep, because it
happens bottom-up
case e of a {
DEFAULT -> case a of b
DEFAULT -> case b of c {
DEFAULT -> e
A -> ea
B -> eb
C -> ec
==>
case e of a {
DEFAULT -> case a of b
DEFAULT -> let c = b in e
A -> let c = b in ea
B -> eb
C -> ec
==>
case e of a {
DEFAULT -> let b = a in let c = b in e
A -> let b = a in let c = b in ea
B -> let b = a in eb
C -> ec
However here's a tricky case that we still don't catch, and I don't
see how to catch it in one pass:
case x of c1 { I# a1 ->
case a1 of c2 ->
0 -> ...
DEFAULT -> case x of c3 { I# a2 ->
case a2 of ...
After occurrence analysis (and its binder-swap) we get this
case x of c1 { I# a1 ->
let x = c1 in -- Binder-swap addition
case a1 of c2 ->
0 -> ...
DEFAULT -> case x of c3 { I# a2 ->
case a2 of ...
When we simplify the inner case x, we'll see that
x=c1=I# a1. So we'll bind a2 to a1, and get
case x of c1 { I# a1 ->
case a1 of c2 ->
0 -> ...
DEFAULT -> case a1 of ...
This is corect, but we can't do a case merge in this sweep
because c2 /= a1. Reason: the binding c1=I# a1 went inwards
without getting changed to c1=I# c2.
I don't think this is worth fixing, even if I knew how. It'll
all come out in the next pass anyway.
\ No newline at end of file
......@@ -597,7 +597,7 @@ completeBind env top_lvl old_bndr new_bndr new_rhs
; if postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs new_unfolding
-- Inline and discard the binding
then do { tick (PostInlineUnconditionally old_bndr)
; return (extendIdSubst env old_bndr (DoneEx new_rhs)) }
; return (extendIdSubst env old_bndr (DoneEx new_rhs)) }
-- Use the substitution to make quite, quite sure that the
-- substitution will happen, since we are going to discard the binding
......@@ -1472,10 +1472,13 @@ rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont
-- exprOkForSpeculation was intended for.
var_demanded_later _ = False
--------------------------------------------------
-- 3. Try seq rules; see Note [User-defined RULES for seq] in MkId
--------------------------------------------------
rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont
| all isDeadBinder (case_bndr : bndrs) -- So this is just 'seq'
= -- For this case, see Note [User-defined RULES for seq] in MkId
do { let rhs' = substExpr env rhs
= do { let rhs' = substExpr env rhs
out_args = [Type (substTy env (idType case_bndr)),
Type (exprType rhs'), scrut, rhs']
-- Lazily evaluated, so we don't do most of this
......@@ -1506,9 +1509,11 @@ reallyRebuildCase env scrut case_bndr alts cont
-- Check for empty alternatives
; if null alts' then missingAlt env case_bndr alts cont
else do
{ case_expr <- mkCase scrut' case_bndr' alts'
{ dflags <- getDOptsSmpl
; case_expr <- mkCase dflags scrut' case_bndr' alts'
-- Notice that rebuild gets the in-scope set from env, not alt_env
-- Notice that rebuild gets the in-scope set from env', not alt_env
-- (which in any case is only build in simplAlts)
-- The case binder *not* scope over the whole returned case-expression
; rebuild env' case_expr nodup_cont } }
\end{code}
......@@ -1599,65 +1604,6 @@ At one point I did transformation in LiberateCase, but it's more
robust here. (Otherwise, there's a danger that we'll simply drop the
'seq' altogether, before LiberateCase gets to see it.)
\begin{code}
improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv
-> OutExpr -> InId -> OutId -> [InAlt]
-> SimplM (SimplEnv, OutExpr, OutId)
-- Note [Improving seq]
improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)]
| not (isDeadBinder case_bndr) -- Not a pure seq! See the Note!
, Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1)
= do { case_bndr2 <- newId (fsLit "nt") ty2
; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co)
env2 = extendIdSubst env case_bndr rhs
; return (env2, scrut `Cast` co, case_bndr2) }
improveSeq _ env scrut _ case_bndr1 _
= return (env, scrut, case_bndr1)
\end{code}
simplAlts does two things:
1. Eliminate alternatives that cannot match, including the
DEFAULT alternative.
2. If the DEFAULT alternative can match only one possible constructor,
then make that constructor explicit.
e.g.
case e of x { DEFAULT -> rhs }
===>
case e of x { (a,b) -> rhs }
where the type is a single constructor type. This gives better code
when rhs also scrutinises x or e.
Here "cannot match" includes knowledge from GADTs
It's a good idea do do this stuff before simplifying the alternatives, to
avoid simplifying alternatives we know can't happen, and to come up with
the list of constructors that are handled, to put into the IdInfo of the
case binder, for use when simplifying the alternatives.
Eliminating the default alternative in (1) isn't so obvious, but it can
happen:
data Colour = Red | Green | Blue
f x = case x of
Red -> ..
Green -> ..
DEFAULT -> h x
h y = case y of
Blue -> ..
DEFAULT -> [ case y of ... ]
If we inline h into f, the default case of the inlined h can't happen.
If we don't notice this, we may end up filtering out *all* the cases
of the inner case y, which give us nowhere to go!
\begin{code}
simplAlts :: SimplEnv
-> OutExpr
......@@ -1666,7 +1612,7 @@ simplAlts :: SimplEnv
-> SimplCont
-> SimplM (OutExpr, OutId, [OutAlt]) -- Includes the continuation
-- Like simplExpr, this just returns the simplified alternatives;
-- it not return an environment
-- it does not return an environment
simplAlts env scrut case_bndr alts cont'
= -- pprTrace "simplAlts" (ppr alts $$ ppr (seIdSubst env)) $
......@@ -1678,11 +1624,29 @@ simplAlts env scrut case_bndr alts cont'
; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env1 scrut
case_bndr case_bndr1 alts
; (imposs_deflt_cons, in_alts) <- prepareAlts alt_env' scrut' case_bndr' alts
; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts
; alts' <- mapM (simplAlt alt_env' imposs_deflt_cons case_bndr' cont') in_alts
; return (scrut', case_bndr', alts') }
------------------------------------
improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv
-> OutExpr -> InId -> OutId -> [InAlt]
-> SimplM (SimplEnv, OutExpr, OutId)
-- Note [Improving seq]
improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)]
| not (isDeadBinder case_bndr) -- Not a pure seq! See the Note!
, Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1)
= do { case_bndr2 <- newId (fsLit "nt") ty2
; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co)
env2 = extendIdSubst env case_bndr rhs
; return (env2, scrut `Cast` co, case_bndr2) }
improveSeq _ env scrut _ case_bndr1 _
= return (env, scrut, case_bndr1)
------------------------------------
simplAlt :: SimplEnv
-> [AltCon] -- These constructors can't be present when
......
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