2 % (c) The AQUA Project, Glasgow University, 1993-1998
4 \section{Common subexpression}
11 #include "HsVersions.h"
13 import CmdLineOpts ( DynFlag(..), DynFlags )
14 import Id ( Id, idType, idWorkerInfo )
15 import IdInfo ( workerExists )
16 import CoreUtils ( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr, exprIsCheap )
17 import DataCon ( isUnboxedTupleCon )
18 import Type ( tyConAppArgs )
19 import Subst ( InScopeSet, uniqAway, emptyInScopeSet,
20 extendInScopeSet, elemInScopeSet )
23 import CoreLint ( showPass, endPass )
25 import Util ( mapAccumL, lengthExceeds )
30 Simple common sub-expression
31 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
35 we build up a reverse mapping: C a b -> x1
37 and apply that to the rest of the program.
42 we replace the C a b with x1. But then we *dont* want to
43 add x1 -> y1 to the mapping. Rather, we want the reverse, y1 -> x1
44 so that a subsequent binding
46 will get transformed to C x1 b, and then to x2.
48 So we carry an extra var->var substitution which we apply *before* looking up in the
54 We have to be careful about shadowing.
56 f = \x -> let y = x+x in
60 Here we must *not* do CSE on the inner x+x! The simplifier used to guarantee no
61 shadowing, but it doesn't any more (it proved too hard), so we clone as we go.
62 We can simply add clones to the substitution already described.
64 However, we do NOT clone type variables. It's just too hard, because then we need
65 to run the substitution over types and IdInfo. No no no. Instead, we just throw
67 (In fact, I think the simplifier does guarantee no-shadowing for type variables.)
70 [Note: case binders 1]
71 ~~~~~~~~~~~~~~~~~~~~~~
74 f = \x -> case x of wild {
75 (a:as) -> case a of wild1 {
76 (p,q) -> ...(wild1:as)...
78 Here, (wild1:as) is morally the same as (a:as) and hence equal to wild.
79 But that's not quite obvious. In general we want to keep it as (wild1:as),
80 but for CSE purpose that's a bad idea.
82 So we add the binding (wild1 -> a) to the extra var->var mapping.
83 Notice this is exactly backwards to what the simplifier does, which is
84 to try to replaces uses of a with uses of wild1
86 [Note: case binders 2]
87 ~~~~~~~~~~~~~~~~~~~~~~
89 case (h x) of y -> ...(h x)...
91 We'd like to replace (h x) in the alternative, by y. But because of
92 the preceding [Note: case binders 1], we only want to add the mapping
93 scrutinee -> case binder
94 to the reverse CSE mapping if the scrutinee is a non-trivial expression.
95 (If the scrutinee is a simple variable we want to add the mapping
96 case binder -> scrutinee
99 [Note: unboxed tuple case binders]
100 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
102 case f x of t { (# a,b #) ->
107 We must not replace (f x) by t, because t is an unboxed-tuple binder.
108 Instead, we shoudl replace (f x) by (# a,b #). That is, the "reverse mapping" is
110 That is why the CSEMap has pairs of expressions.
113 %************************************************************************
115 \section{Common subexpression}
117 %************************************************************************
120 cseProgram :: DynFlags -> [CoreBind] -> IO [CoreBind]
122 cseProgram dflags binds
124 showPass dflags "Common sub-expression";
125 let { binds' = cseBinds emptyCSEnv binds };
126 endPass dflags "Common sub-expression" Opt_D_dump_cse binds'
129 cseBinds :: CSEnv -> [CoreBind] -> [CoreBind]
131 cseBinds env (b:bs) = (b':bs')
133 (env1, b') = cseBind env b
134 bs' = cseBinds env1 bs
136 cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind)
137 cseBind env (NonRec b e) = let (env', (_,e')) = do_one env (b, e)
138 in (env', NonRec b e')
139 cseBind env (Rec pairs) = let (env', pairs') = mapAccumL do_one env pairs
140 in (env', Rec pairs')
144 = case lookupCSEnv env rhs' of
145 Just (Var other_id) -> (extendSubst env' id other_id, (id', Var other_id))
146 Just other_expr -> (env', (id', other_expr))
147 Nothing -> (addCSEnvItem env' rhs' (Var id'), (id', rhs'))
149 (env', id') = addBinder env id
150 rhs' | not (workerExists (idWorkerInfo id)) = cseExpr env' rhs
152 -- Hack alert: don't do CSE on wrapper RHSs.
153 -- Otherwise we find:
155 -- f = \x -> ...$wf...
158 -- But the WorkerInfo for f still says $wf, which is now dead!
162 tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
163 tryForCSE env (Type t) = Type t
164 tryForCSE env expr = case lookupCSEnv env expr' of
165 Just smaller_expr -> smaller_expr
168 expr' = cseExpr env expr
170 cseExpr :: CSEnv -> CoreExpr -> CoreExpr
171 cseExpr env (Type t) = Type t
172 cseExpr env (Lit lit) = Lit lit
173 cseExpr env (Var v) = Var (lookupSubst env v)
174 cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a)
175 cseExpr env (Note n e) = Note n (cseExpr env e)
176 cseExpr env (Lam b e) = let (env', b') = addBinder env b
177 in Lam b' (cseExpr env' e)
178 cseExpr env (Let bind e) = let (env', bind') = cseBind env bind
179 in Let bind' (cseExpr env' e)
180 cseExpr env (Case scrut bndr alts) = Case scrut' bndr' (cseAlts env' scrut' bndr bndr' alts)
182 scrut' = tryForCSE env scrut
183 (env', bndr') = addBinder env bndr
186 cseAlts env scrut' bndr bndr' [(DataAlt con, args, rhs)]
187 | isUnboxedTupleCon con
188 -- Unboxed tuples are special because the case binder isn't
189 -- a real values. See [Note: unboxed tuple case binders]
190 = [(DataAlt con, args', tryForCSE new_env rhs)]
192 (env', args') = addBinders env args
193 new_env | exprIsCheap scrut' = env'
194 | otherwise = extendCSEnv env' scrut' tup_value
195 tup_value = mkAltExpr (DataAlt con) args' (tyConAppArgs (idType bndr))
197 cseAlts env scrut' bndr bndr' alts
200 (con_target, alt_env)
202 Var v' -> (v', extendSubst env bndr v') -- See [Note: case binder 1]
205 other -> (bndr', extendCSEnv env scrut' (Var bndr')) -- See [Note: case binder 2]
206 -- map: scrut' -> bndr'
208 arg_tys = tyConAppArgs (idType bndr)
210 cse_alt (DataAlt con, args, rhs)
212 -- Don't try CSE if there are no args; it just increases the number
213 -- of live vars. E.g.
214 -- case x of { True -> ....True.... }
215 -- Don't replace True by x!
216 -- Hence the 'null args', which also deal with literals and DEFAULT
217 = (DataAlt con, args', tryForCSE new_env rhs)
219 (env', args') = addBinders alt_env args
220 new_env = extendCSEnv env' (mkAltExpr (DataAlt con) args' arg_tys)
223 cse_alt (con, args, rhs)
224 = (con, args', tryForCSE env' rhs)
226 (env', args') = addBinders alt_env args
230 %************************************************************************
232 \section{The CSE envt}
234 %************************************************************************
237 data CSEnv = CS CSEMap InScopeSet (IdEnv Id)
238 -- Simple substitution
240 type CSEMap = UniqFM [(CoreExpr, CoreExpr)] -- This is the reverse mapping
241 -- It maps the hash-code of an expression e to list of (e,e') pairs
242 -- This means that it's good to replace e by e'
243 -- INVARIANT: The expr in the range has already been CSE'd
245 emptyCSEnv = CS emptyUFM emptyInScopeSet emptyVarEnv
247 lookupCSEnv :: CSEnv -> CoreExpr -> Maybe CoreExpr
248 lookupCSEnv (CS cs _ _) expr
249 = case lookupUFM cs (hashExpr expr) of
251 Just pairs -> lookup_list pairs expr
253 lookup_list :: [(CoreExpr,CoreExpr)] -> CoreExpr -> Maybe CoreExpr
254 lookup_list [] expr = Nothing
255 lookup_list ((e,e'):es) expr | cheapEqExpr e expr = Just e'
256 | otherwise = lookup_list es expr
258 addCSEnvItem env expr expr' | exprIsBig expr = env
259 | otherwise = extendCSEnv env expr expr'
260 -- We don't try to CSE big expressions, because they are expensive to compare
261 -- (and are unlikely to be the same anyway)
263 extendCSEnv (CS cs in_scope sub) expr expr'
264 = CS (addToUFM_C combine cs hash [(expr, expr')]) in_scope sub
267 combine old new = WARN( result `lengthExceeds` 4, text "extendCSEnv: long list:" <+> ppr result )
272 lookupSubst (CS _ _ sub) x = case lookupVarEnv sub x of
276 extendSubst (CS cs in_scope sub) x y = CS cs in_scope (extendVarEnv sub x y)
278 addBinder :: CSEnv -> Id -> (CSEnv, Id)
279 addBinder env@(CS cs in_scope sub) v
280 | not (v `elemInScopeSet` in_scope) = (CS cs (extendInScopeSet in_scope v) sub, v)
281 | isId v = (CS cs (extendInScopeSet in_scope v') (extendVarEnv sub v v'), v')
282 | not (isId v) = WARN( True, ppr v )
283 (CS emptyUFM in_scope sub, v)
284 -- This last case is the unusual situation where we have shadowing of
285 -- a type variable; we have to discard the CSE mapping
286 -- See "IMPORTANT NOTE" at the top
288 v' = uniqAway in_scope v
290 addBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
291 addBinders env vs = mapAccumL addBinder env vs