%
% (c) The AQUA Project, Glasgow University, 19931998
%
\section{Common subexpression}
\begin{code}
module CSE (
cseProgram
) where
#include "HsVersions.h"
#ifdef OLD_CSENV_REP
import CoreUtils ( exprIsBig, hashExpr, eqExpr )
import StaticFlags ( opt_PprStyle_Debug )
import Util ( lengthExceeds )
import UniqFM
import FastString
#else
import TrieMap
#endif
import CoreSubst
import Var ( Var )
import Id ( Id, idType, idInlineActivation, zapIdOccInfo )
import CoreUtils ( mkAltExpr
, exprIsTrivial, exprIsCheap )
import DataCon ( isUnboxedTupleCon )
import Type ( tyConAppArgs )
import CoreSyn
import Outputable
import BasicTypes ( isAlwaysActive )
import Data.List
\end{code}
Simple common subexpression
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we see
x1 = C a b
x2 = C x1 b
we build up a reverse mapping: C a b -> x1
C x1 b -> x2
and apply that to the rest of the program.
When we then see
y1 = C a b
y2 = C y1 b
we replace the C a b with x1. But then we *dont* want to
add x1 -> y1 to the mapping. Rather, we want the reverse, y1 -> x1
so that a subsequent binding
y2 = C y1 b
will get transformed to C x1 b, and then to x2.
So we carry an extra var->var substitution which we apply *before* looking up in the
reverse mapping.
Note [Shadowing]
~~~~~~~~~~~~~~~~
We have to be careful about shadowing.
For example, consider
f = \x -> let y = x+x in
h = \x -> x+x
in ...
Here we must *not* do CSE on the inner x+x! The simplifier used to guarantee no
shadowing, but it doesn't any more (it proved too hard), so we clone as we go.
We can simply add clones to the substitution already described.
Note [Case binders 1]
~~~~~~~~~~~~~~~~~~~~~~
Consider
f = \x -> case x of wild {
(a:as) -> case a of wild1 {
(p,q) -> ...(wild1:as)...
Here, (wild1:as) is morally the same as (a:as) and hence equal to wild.
But that's not quite obvious. In general we want to keep it as (wild1:as),
but for CSE purpose that's a bad idea.
So we add the binding (wild1 -> a) to the extra var->var mapping.
Notice this is exactly backwards to what the simplifier does, which is
to try to replaces uses of 'a' with uses of 'wild1'
Note [Case binders 2]
~~~~~~~~~~~~~~~~~~~~~~
Consider
case (h x) of y -> ...(h x)...
We'd like to replace (h x) in the alternative, by y. But because of
the preceding [Note: case binders 1], we only want to add the mapping
scrutinee -> case binder
to the reverse CSE mapping if the scrutinee is a nontrivial expression.
(If the scrutinee is a simple variable we want to add the mapping
case binder -> scrutinee
to the substitution
Note [Unboxed tuple case binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
case f x of t { (# a,b #) ->
case ... of
True -> f x
False -> 0 }
We must not replace (f x) by t, because t is an unboxedtuple binder.
Instead, we shoudl replace (f x) by (# a,b #). That is, the "reverse mapping" is
f x --> (# a,b #)
That is why the CSEMap has pairs of expressions.
Note [CSE for INLINE and NOINLINE]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We are careful to do no CSE inside functions that the user has marked as
INLINE or NOINLINE. In terms of Core, that means
a) we do not do CSE inside an InlineRule
b) we do not do CSE on the RHS of a binding b=e
unless b's InlinePragma is AlwaysActive
Here's why (examples from Roman Leshchinskiy). Consider
yes :: Int
yes = undefined
no :: Int
no = undefined
foo :: Int -> Int -> Int
foo m n = n
bar :: Int -> Int
bar = foo yes
We do not expect the rule to fire. But if we do CSE, then we get
yes=no, and the rule does fire. Worse, whether we get yes=no or
no=yes depends on the order of the definitions.
In general, CSE should probably never touch things with INLINE pragmas
as this could lead to surprising results. Consider
foo = <rhs>
bar = <rhs>
If CSE produces
foo = bar
then foo will never be inlined (when it should be); but if it produces
bar = foo
bar will be inlined (when it should not be). Even if we remove INLINE foo,
we'd still like foo to be inlined if rhs is small. This won't happen
with foo = bar.
Not CSEing inside INLINE also solves an annoying bug in CSE. Consider
a worker/wrapper, in which the worker has turned into a single variable:
$wf = h
f = \x -> ...$wf...
Now CSE may transform to
f = \x -> ...h...
But the WorkerInfo for f still says $wf, which is now dead! This won't
happen now that we don't look inside INLINEs (which wrappers are).
%************************************************************************
%* *
\section{Common subexpression}
%* *
%************************************************************************
\begin{code}
cseProgram :: CoreProgram -> CoreProgram
cseProgram binds = cseBinds emptyCSEnv binds
cseBinds :: CSEnv -> [CoreBind] -> [CoreBind]
cseBinds _ [] = []
cseBinds env (b:bs) = (b':bs')
where
(env1, b') = cseBind env b
bs' = cseBinds env1 bs
cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind)
cseBind env (NonRec b e)
= (env2, NonRec b' e')
where
(env1, b') = addBinder env b
(env2, e') = cseRhs env1 (b',e)
cseBind env (Rec pairs)
= (env2, Rec (bs' `zip` es'))
where
(bs,es) = unzip pairs
(env1, bs') = addRecBinders env bs
(env2, es') = mapAccumL cseRhs env1 (bs' `zip` es)
cseRhs :: CSEnv -> (OutBndr, InExpr) -> (CSEnv, OutExpr)
cseRhs env (id',rhs)
= case lookupCSEnv env rhs' of
Just other_expr -> (env, other_expr)
Nothing -> (addCSEnvItem env rhs' (Var id'), rhs')
where
rhs' | isAlwaysActive (idInlineActivation id') = cseExpr env rhs
| otherwise = rhs
tryForCSE :: CSEnv -> InExpr -> OutExpr
tryForCSE env expr
| exprIsTrivial expr' = expr'
| Just smaller <- lookupCSEnv env expr' = smaller
| otherwise = expr'
where
expr' = cseExpr env expr
cseExpr :: CSEnv -> InExpr -> OutExpr
cseExpr env (Type t) = Type (substTy (csEnvSubst env) t)
cseExpr env (Coercion c) = Coercion (substCo (csEnvSubst env) c)
cseExpr _ (Lit lit) = Lit lit
cseExpr env (Var v) = lookupSubst env v
cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a)
cseExpr env (Tick t e) = Tick t (cseExpr env e)
cseExpr env (Cast e co) = Cast (cseExpr env e) (substCo (csEnvSubst env) co)
cseExpr env (Lam b e) = let (env', b') = addBinder env b
in Lam b' (cseExpr env' e)
cseExpr env (Let bind e) = let (env', bind') = cseBind env bind
in Let bind' (cseExpr env' e)
cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr'' ty alts'
where
alts' = cseAlts env' scrut' bndr bndr'' alts
scrut' = tryForCSE env scrut
(env', bndr') = addBinder env bndr
bndr'' = zapIdOccInfo bndr'
cseAlts :: CSEnv -> OutExpr -> InBndr -> InBndr -> [InAlt] -> [OutAlt]
cseAlts env scrut' bndr _bndr' [(DataAlt con, args, rhs)]
| isUnboxedTupleCon con
= [(DataAlt con, args'', tryForCSE new_env rhs)]
where
(env', args') = addBinders env args
args'' = map zapIdOccInfo args'
new_env | exprIsCheap scrut' = env'
| otherwise = extendCSEnv env' scrut' tup_value
tup_value = mkAltExpr (DataAlt con) args'' (tyConAppArgs (idType bndr))
cseAlts env scrut' bndr bndr' alts
= map cse_alt alts
where
(con_target, alt_env)
= case scrut' of
Var v' -> (v', extendCSSubst env bndr v')
_ -> (bndr', extendCSEnv env scrut' (Var bndr'))
arg_tys = tyConAppArgs (idType bndr)
cse_alt (DataAlt con, args, rhs)
| not (null args)
= (DataAlt con, args', tryForCSE new_env rhs)
where
(env', args') = addBinders alt_env args
new_env = extendCSEnv env' (mkAltExpr (DataAlt con) args' arg_tys)
(Var con_target)
cse_alt (con, args, rhs)
= (con, args', tryForCSE env' rhs)
where
(env', args') = addBinders alt_env args
\end{code}
%************************************************************************
%* *
\section{The CSE envt}
%* *
%************************************************************************
\begin{code}
type InExpr = CoreExpr
type InBndr = CoreBndr
type InAlt = CoreAlt
type OutExpr = CoreExpr
type OutBndr = CoreBndr
type OutAlt = CoreAlt
#ifdef OLD_CSENV_REP
data CSEnv = CS { cs_map :: CSEMap
, cs_subst :: Subst }
type CSEMap = UniqFM [(OutExpr, OutExpr)]
emptyCSEnv :: CSEnv
emptyCSEnv = CS { cs_map = emptyUFM, cs_subst = emptySubst }
lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr
lookupCSEnv (CS { cs_map = oldmap, cs_subst = sub}) expr
= case lookupUFM oldmap (hashExpr expr) of
Nothing -> Nothing
Just pairs -> lookup_list pairs
where
in_scope = substInScope sub
lookup_list :: [(OutExpr,OutExpr)] -> Maybe OutExpr
lookup_list ((e,e'):es)
| eqExpr in_scope e expr = Just e'
| otherwise = lookup_list es
lookup_list [] = Nothing
addCSEnvItem :: CSEnv -> OutExpr -> OutExpr -> CSEnv
addCSEnvItem env expr expr' | exprIsBig expr = env
| otherwise = extendCSEnv env expr expr'
extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv
extendCSEnv cse@(CS { cs_map = oldmap }) expr expr'
= cse { cs_map = addToUFM_C combine oldmap hash [(expr, expr')] }
where
hash = hashExpr expr
combine old new
= WARN( result `lengthExceeds` 4, short_msg $$ nest 2 long_msg ) result
where
result = new ++ old
short_msg = ptext (sLit "extendCSEnv: long list, length") <+> int (length result)
long_msg | opt_PprStyle_Debug = (text "hash code" <+> text (show hash)) $$ ppr result
| otherwise = empty
#else
data CSEnv = CS { cs_map :: CoreMap (OutExpr, OutExpr)
, cs_subst :: Subst }
emptyCSEnv :: CSEnv
emptyCSEnv = CS { cs_map = emptyCoreMap, cs_subst = emptySubst }
lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr
lookupCSEnv (CS { cs_map = csmap }) expr
= case lookupCoreMap csmap expr of
Just (_,e) -> Just e
Nothing -> Nothing
addCSEnvItem :: CSEnv -> OutExpr -> OutExpr -> CSEnv
addCSEnvItem = extendCSEnv
extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv
extendCSEnv cse expr expr'
= cse { cs_map = extendCoreMap (cs_map cse) expr (expr,expr') }
#endif
csEnvSubst :: CSEnv -> Subst
csEnvSubst = cs_subst
lookupSubst :: CSEnv -> Id -> OutExpr
lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst (text "CSE.lookupSubst") sub x
extendCSSubst :: CSEnv -> Id -> Id -> CSEnv
extendCSSubst cse x y = cse { cs_subst = extendIdSubst (cs_subst cse) x (Var y) }
addBinder :: CSEnv -> Var -> (CSEnv, Var)
addBinder cse v = (cse { cs_subst = sub' }, v')
where
(sub', v') = substBndr (cs_subst cse) v
addBinders :: CSEnv -> [Var] -> (CSEnv, [Var])
addBinders cse vs = (cse { cs_subst = sub' }, vs')
where
(sub', vs') = substBndrs (cs_subst cse) vs
addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
addRecBinders cse vs = (cse { cs_subst = sub' }, vs')
where
(sub', vs') = substRecBndrs (cs_subst cse) vs
\end{code}