#include "HsVersions.h"
-import CmdLineOpts ( opt_D_dump_cse, opt_D_verbose_core2core )
-import Id ( Id, idType )
-import CoreUtils ( hashExpr, cheapEqExpr, exprIsBig )
-import Const ( Con(..) )
+import CmdLineOpts ( DynFlag(..), DynFlags )
+import Id ( Id, idType, idWorkerInfo )
+import IdInfo ( workerExists )
+import CoreUtils ( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr )
import DataCon ( isUnboxedTupleCon )
-import Type ( splitTyConApp_maybe )
+import Type ( tyConAppArgs )
+import Subst ( InScopeSet, uniqAway, emptyInScopeSet,
+ extendInScopeSet, elemInScopeSet )
import CoreSyn
import VarEnv
-import CoreLint ( beginPass, endPass )
+import CoreLint ( showPass, endPass )
import Outputable
-import Util ( mapAccumL )
+import Util ( mapAccumL, lengthExceeds )
import UniqFM
\end{code}
Simple common sub-expression
-
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we see
x1 = C a b
x2 = C x1 b
y1 = C a b
y2 = C y1 b
we replace the C a b with x1. But then we *dont* want to
-add x1 -> y to the mapping. Rather, we want the reverse, y -> x1
+add x1 -> y1 to the mapping. Rather, we want the reverse, y1 -> x1
so that a subsequent binding
- z = C y b
+ y2 = C y1 b
will get transformed to C x1 b, and then to x2.
-So we carry an extra var->var mapping which we apply before looking up in the
+So we carry an extra var->var substitution which we apply *before* looking up in the
reverse mapping.
IMPORTANT NOTE
~~~~~~~~~~~~~~
-This pass relies on the no-shadowing invariant, so it must run
-immediately after the simplifier.
-
+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 x+x!
+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.
+
+However, we do NOT clone type variables. It's just too hard, because then we need
+to run the substitution over types and IdInfo. No no no. Instead, we just throw
+away the entire reverse mapping if this unusual situation ever shows up.
+(In fact, I think the simplifier does guarantee no-shadowing for type variables.)
+
+
+Another important wrinkle
+~~~~~~~~~~~~~~~~~~~~~~~~~
+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
+
+Yet another wrinkle
+~~~~~~~~~~~~~~~~~~~
+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 "Another important wrinkle", we only want to add the mapping
+ scrutinee -> case binder
+to the reverse CSE mapping if the scrutinee is a non-trivial expression.
+(If the scrutinee is a simple variable we want to add the mapping
+ case binder -> scrutinee
+to the substitution
%************************************************************************
%************************************************************************
\begin{code}
-cseProgram :: [CoreBind] -> IO [CoreBind]
+cseProgram :: DynFlags -> [CoreBind] -> IO [CoreBind]
-cseProgram binds
+cseProgram dflags binds
= do {
- beginPass "Common sub-expression";
+ showPass dflags "Common sub-expression";
let { binds' = cseBinds emptyCSEnv binds };
- endPass "Common sub-expression"
- (opt_D_dump_cse || opt_D_verbose_core2core)
- binds'
+ endPass dflags "Common sub-expression" Opt_D_dump_cse binds'
}
cseBinds :: CSEnv -> [CoreBind] -> [CoreBind]
in (env', Rec pairs')
-do_one env (id, rhs) = case lookupCSEnv env rhs' of
- Just other_id -> (extendSubst env id other_id, (id, Var other_id))
- Nothing -> (addCSEnvItem env id rhs', (id, rhs'))
- where
- rhs' = cseExpr env rhs
+do_one env (id, rhs)
+ = case lookupCSEnv env rhs' of
+ Just other_id -> (extendSubst env' id other_id, (id', Var other_id))
+ Nothing -> (addCSEnvItem env' id' rhs', (id', rhs'))
+ where
+ (env', id') = addBinder env id
+ rhs' | not (workerExists (idWorkerInfo id)) = cseExpr env' rhs
+
+ -- Hack alert: don't do CSE on wrapper RHSs.
+ -- Otherwise we find:
+ -- $wf = h
+ -- f = \x -> ...$wf...
+ -- ===>
+ -- f = \x -> ...h...
+ -- But the WorkerInfo for f still says $wf, which is now dead!
+ | otherwise = rhs
tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
where
expr' = cseExpr env expr
-
cseExpr :: CSEnv -> CoreExpr -> CoreExpr
+cseExpr env (Type t) = Type t
+cseExpr env (Lit lit) = Lit lit
cseExpr env (Var v) = Var (lookupSubst env v)
-cseExpr env (App f (Type t)) = App (cseExpr env f) (Type t)
cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a)
-cseExpr env expr@(Con con args) = case lookupCSEnv env expr of
- Just id -> Var id
- Nothing -> Con con [tryForCSE env arg | arg <- args]
cseExpr env (Note n e) = Note n (cseExpr env e)
-cseExpr env (Lam b e) = Lam b (cseExpr env e)
-cseExpr env (Let bind e) = let (env1, bind') = cseBind env bind
- in Let bind' (cseExpr env1 e)
-cseExpr env (Type t) = Type t
-cseExpr env (Case scrut bndr alts) = Case (tryForCSE env scrut) bndr (cseAlts env bndr alts)
+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 alts) = Case scrut' bndr' (cseAlts env' scrut' bndr bndr' alts)
+ where
+ scrut' = tryForCSE env scrut
+ (env', bndr') = addBinder env bndr
-cseAlts env bndr alts
+cseAlts env scrut' bndr bndr' alts
= map cse_alt alts
where
- arg_tys = case splitTyConApp_maybe (idType bndr) of
- Just (_, arg_tys) -> map Type arg_tys
- other -> pprPanic "cseAlts" (ppr bndr)
+ (con_target, alt_env)
+ = case scrut' of
+ Var v' -> (v', extendSubst env bndr v') -- See "another important wrinkle"
+ -- map: bndr -> v'
+
+ other -> (bndr', extendCSEnv env bndr' scrut') -- See "yet another wrinkle"
+ -- map: scrut' -> bndr'
+
+ arg_tys = tyConAppArgs (idType bndr)
+
+ cse_alt (DataAlt con, args, rhs)
+ | not (null args || isUnboxedTupleCon con)
+ -- Don't try CSE if there are no args; it just increases the number
+ -- of live vars. E.g.
+ -- case x of { True -> ....True.... }
+ -- Don't replace True by x!
+ -- Hence the 'null args', which also deal with literals and DEFAULT
+ -- And we can't CSE on unboxed tuples
+ = (DataAlt con, args', tryForCSE new_env rhs)
+ where
+ (env', args') = addBinders alt_env args
+ new_env = extendCSEnv env' con_target (mkAltExpr (DataAlt con) args' arg_tys)
cse_alt (con, args, rhs)
- | ok_for_cse con = (con, args, cseExpr (extendCSEnv env bndr (Con con (arg_tys ++ (map varToCoreExpr args)))) rhs)
- | otherwise = (con, args, cseExpr env rhs)
-
- ok_for_cse DEFAULT = False
- ok_for_cse (Literal l) = True
- ok_for_cse (DataCon dc) = not (isUnboxedTupleCon dc)
- -- Unboxed tuples aren't shared
+ = (con, args', tryForCSE env' rhs)
+ where
+ (env', args') = addBinders alt_env args
\end{code}
%************************************************************************
\begin{code}
-data CSEnv = CS (UniqFM [(Id, CoreExpr)]) -- The expr in the range has already been CSE'd
- (IdEnv Id) -- Simple substitution
+data CSEnv = CS CSEMap InScopeSet (IdEnv Id)
+ -- Simple substitution
-emptyCSEnv = CS emptyUFM emptyVarEnv
+type CSEMap = UniqFM [(Id, CoreExpr)] -- This is the reverse mapping
+ -- It maps the hash-code of an expression to list of (x,e) pairs
+ -- This means that it's good to replace e by x
+ -- INVARIANT: The expr in the range has already been CSE'd
+
+emptyCSEnv = CS emptyUFM emptyInScopeSet emptyVarEnv
lookupCSEnv :: CSEnv -> CoreExpr -> Maybe Id
-lookupCSEnv (CS cs _) expr
+lookupCSEnv (CS cs _ _) expr
= case lookupUFM cs (hashExpr expr) of
Nothing -> Nothing
Just pairs -> lookup_list pairs expr
addCSEnvItem env id expr | exprIsBig expr = env
| otherwise = extendCSEnv env id expr
+ -- We don't try to CSE big expressions, because they are expensive to compare
+ -- (and are unlikely to be the same anyway)
-extendCSEnv (CS cs sub) id expr
- = CS (addToUFM_C combine cs hash [(id, expr)]) sub
+extendCSEnv (CS cs in_scope sub) id expr
+ = CS (addToUFM_C combine cs hash [(id, expr)]) in_scope sub
where
hash = hashExpr expr
- combine old new = WARN( length result > 4, text "extendCSEnv: long list:" <+> ppr result )
+ combine old new = WARN( result `lengthExceeds` 4, text "extendCSEnv: long list:" <+> ppr result )
result
where
result = new ++ old
-lookupSubst (CS _ sub) x = case lookupVarEnv sub x of
- Just y -> y
- Nothing -> x
+lookupSubst (CS _ _ sub) x = case lookupVarEnv sub x of
+ Just y -> y
+ Nothing -> x
+
+extendSubst (CS cs in_scope sub) x y = CS cs in_scope (extendVarEnv sub x y)
+
+addBinder :: CSEnv -> Id -> (CSEnv, Id)
+addBinder env@(CS cs in_scope sub) v
+ | not (v `elemInScopeSet` in_scope) = (CS cs (extendInScopeSet in_scope v) sub, v)
+ | isId v = (CS cs (extendInScopeSet in_scope v') (extendVarEnv sub v v'), v')
+ | not (isId v) = WARN( True, ppr v )
+ (CS emptyUFM in_scope sub, v)
+ -- This last case is the unusual situation where we have shadowing of
+ -- a type variable; we have to discard the CSE mapping
+ -- See "IMPORTANT NOTE" at the top
+ where
+ v' = uniqAway in_scope v
-extendSubst (CS cs sub) x y = CS cs (extendVarEnv sub x y)
+addBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
+addBinders env vs = mapAccumL addBinder env vs
\end{code}