2 % (c) The AQUA Project, Glasgow University, 1993-1998
4 \section{Common subexpression}
11 #include "HsVersions.h"
13 import DynFlags ( DynFlag(..), DynFlags )
14 import Id ( Id, idType, idInlinePragma )
15 import CoreUtils ( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr, exprIsCheap )
16 import DataCon ( isUnboxedTupleCon )
17 import Type ( tyConAppArgs )
20 import CoreLint ( showPass, endPass )
22 import BasicTypes ( isAlwaysActive )
23 import Util ( mapAccumL, lengthExceeds )
28 Simple common sub-expression
29 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
33 we build up a reverse mapping: C a b -> x1
35 and apply that to the rest of the program.
40 we replace the C a b with x1. But then we *dont* want to
41 add x1 -> y1 to the mapping. Rather, we want the reverse, y1 -> x1
42 so that a subsequent binding
44 will get transformed to C x1 b, and then to x2.
46 So we carry an extra var->var substitution which we apply *before* looking up in the
52 We have to be careful about shadowing.
54 f = \x -> let y = x+x in
58 Here we must *not* do CSE on the inner x+x! The simplifier used to guarantee no
59 shadowing, but it doesn't any more (it proved too hard), so we clone as we go.
60 We can simply add clones to the substitution already described.
62 However, we do NOT clone type variables. It's just too hard, because then we need
63 to run the substitution over types and IdInfo. No no no. Instead, we just throw
65 (In fact, I think the simplifier does guarantee no-shadowing for type variables.)
68 [Note: case binders 1]
69 ~~~~~~~~~~~~~~~~~~~~~~
72 f = \x -> case x of wild {
73 (a:as) -> case a of wild1 {
74 (p,q) -> ...(wild1:as)...
76 Here, (wild1:as) is morally the same as (a:as) and hence equal to wild.
77 But that's not quite obvious. In general we want to keep it as (wild1:as),
78 but for CSE purpose that's a bad idea.
80 So we add the binding (wild1 -> a) to the extra var->var mapping.
81 Notice this is exactly backwards to what the simplifier does, which is
82 to try to replaces uses of a with uses of wild1
84 [Note: case binders 2]
85 ~~~~~~~~~~~~~~~~~~~~~~
87 case (h x) of y -> ...(h x)...
89 We'd like to replace (h x) in the alternative, by y. But because of
90 the preceding [Note: case binders 1], we only want to add the mapping
91 scrutinee -> case binder
92 to the reverse CSE mapping if the scrutinee is a non-trivial expression.
93 (If the scrutinee is a simple variable we want to add the mapping
94 case binder -> scrutinee
97 [Note: unboxed tuple case binders]
98 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
100 case f x of t { (# a,b #) ->
105 We must not replace (f x) by t, because t is an unboxed-tuple binder.
106 Instead, we shoudl replace (f x) by (# a,b #). That is, the "reverse mapping" is
108 That is why the CSEMap has pairs of expressions.
110 Note [INLINE and NOINLINE]
111 ~~~~~~~~~~~~~~~~~~~~~~~~~~
112 We are careful to do no CSE inside functions that the user has marked as
113 INLINE or NOINLINE. In terms of Core, that means
115 a) we do not do CSE inside (Note InlineMe e)
117 b) we do not do CSE on the RHS of a binding b=e
118 unless b's InlinePragma is AlwaysActive
120 Here's why (examples from Roman Leshchinskiy). Consider
130 foo :: Int -> Int -> Int
134 {-# RULES "foo/no" foo no = id #-}
139 We do not expect the rule to fire. But if we do CSE, then we get
140 yes=no, and the rule does fire. Worse, whether we get yes=no or
141 no=yes depends on the order of the definitions.
143 In general, CSE should probably never touch things with INLINE pragmas
144 as this could lead to surprising results. Consider
150 bar = <rhs> -- Same rhs as foo
154 then foo will never be inlined (when it should be); but if it produces
156 bar will be inlined (when it should not be). Even if we remove INLINE foo,
157 we'd still like foo to be inlined if rhs is small. This won't happen
160 Not CSE-ing inside INLLINE also solves an annoying bug in CSE. Consider
161 a worker/wrapper, in which the worker has turned into a single variable:
164 Now CSE may transoform to
166 But the WorkerInfo for f still says $wf, which is now dead! This won't
167 happen now that we don't look inside INLINEs (which wrappers are).
170 %************************************************************************
172 \section{Common subexpression}
174 %************************************************************************
177 cseProgram :: DynFlags -> [CoreBind] -> IO [CoreBind]
179 cseProgram dflags binds
181 showPass dflags "Common sub-expression";
182 let { binds' = cseBinds emptyCSEnv binds };
183 endPass dflags "Common sub-expression" Opt_D_dump_cse binds'
186 cseBinds :: CSEnv -> [CoreBind] -> [CoreBind]
188 cseBinds env (b:bs) = (b':bs')
190 (env1, b') = cseBind env b
191 bs' = cseBinds env1 bs
193 cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind)
194 cseBind env (NonRec b e) = let (env', (b',e')) = do_one env (b, e)
195 in (env', NonRec b' e')
196 cseBind env (Rec pairs) = let (env', pairs') = mapAccumL do_one env pairs
197 in (env', Rec pairs')
201 = case lookupCSEnv env rhs' of
202 Just (Var other_id) -> (extendSubst env' id other_id, (id', Var other_id))
203 Just other_expr -> (env', (id', other_expr))
204 Nothing -> (addCSEnvItem env' rhs' (Var id'), (id', rhs'))
206 (env', id') = addBinder env id
207 rhs' | isAlwaysActive (idInlinePragma id) = cseExpr env' rhs
209 -- See Note [INLINE and NOINLINE]
211 tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
212 tryForCSE env (Type t) = Type t
213 tryForCSE env expr = case lookupCSEnv env expr' of
214 Just smaller_expr -> smaller_expr
217 expr' = cseExpr env expr
219 cseExpr :: CSEnv -> CoreExpr -> CoreExpr
220 cseExpr env (Type t) = Type t
221 cseExpr env (Lit lit) = Lit lit
222 cseExpr env (Var v) = Var (lookupSubst env v)
223 cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a)
224 cseExpr evn (Note InlineMe e) = Note InlineMe e -- See Note [INLINE and NOINLINE]
225 cseExpr env (Note n e) = Note n (cseExpr env e)
226 cseExpr env (Lam b e) = let (env', b') = addBinder env b
227 in Lam b' (cseExpr env' e)
228 cseExpr env (Let bind e) = let (env', bind') = cseBind env bind
229 in Let bind' (cseExpr env' e)
230 cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr' ty (cseAlts env' scrut' bndr bndr' alts)
232 scrut' = tryForCSE env scrut
233 (env', bndr') = addBinder env bndr
236 cseAlts env scrut' bndr bndr' [(DataAlt con, args, rhs)]
237 | isUnboxedTupleCon con
238 -- Unboxed tuples are special because the case binder isn't
239 -- a real values. See [Note: unboxed tuple case binders]
240 = [(DataAlt con, args', tryForCSE new_env rhs)]
242 (env', args') = addBinders env args
243 new_env | exprIsCheap scrut' = env'
244 | otherwise = extendCSEnv env' scrut' tup_value
245 tup_value = mkAltExpr (DataAlt con) args' (tyConAppArgs (idType bndr))
247 cseAlts env scrut' bndr bndr' alts
250 (con_target, alt_env)
252 Var v' -> (v', extendSubst env bndr v') -- See [Note: case binder 1]
255 other -> (bndr', extendCSEnv env scrut' (Var bndr')) -- See [Note: case binder 2]
256 -- map: scrut' -> bndr'
258 arg_tys = tyConAppArgs (idType bndr)
260 cse_alt (DataAlt con, args, rhs)
262 -- Don't try CSE if there are no args; it just increases the number
263 -- of live vars. E.g.
264 -- case x of { True -> ....True.... }
265 -- Don't replace True by x!
266 -- Hence the 'null args', which also deal with literals and DEFAULT
267 = (DataAlt con, args', tryForCSE new_env rhs)
269 (env', args') = addBinders alt_env args
270 new_env = extendCSEnv env' (mkAltExpr (DataAlt con) args' arg_tys)
273 cse_alt (con, args, rhs)
274 = (con, args', tryForCSE env' rhs)
276 (env', args') = addBinders alt_env args
280 %************************************************************************
282 \section{The CSE envt}
284 %************************************************************************
287 data CSEnv = CS CSEMap InScopeSet (IdEnv Id)
288 -- Simple substitution
290 type CSEMap = UniqFM [(CoreExpr, CoreExpr)] -- This is the reverse mapping
291 -- It maps the hash-code of an expression e to list of (e,e') pairs
292 -- This means that it's good to replace e by e'
293 -- INVARIANT: The expr in the range has already been CSE'd
295 emptyCSEnv = CS emptyUFM emptyInScopeSet emptyVarEnv
297 lookupCSEnv :: CSEnv -> CoreExpr -> Maybe CoreExpr
298 lookupCSEnv (CS cs _ _) expr
299 = case lookupUFM cs (hashExpr expr) of
301 Just pairs -> lookup_list pairs expr
303 lookup_list :: [(CoreExpr,CoreExpr)] -> CoreExpr -> Maybe CoreExpr
304 lookup_list [] expr = Nothing
305 lookup_list ((e,e'):es) expr | cheapEqExpr e expr = Just e'
306 | otherwise = lookup_list es expr
308 addCSEnvItem env expr expr' | exprIsBig expr = env
309 | otherwise = extendCSEnv env expr expr'
310 -- We don't try to CSE big expressions, because they are expensive to compare
311 -- (and are unlikely to be the same anyway)
313 extendCSEnv (CS cs in_scope sub) expr expr'
314 = CS (addToUFM_C combine cs hash [(expr, expr')]) in_scope sub
317 combine old new = WARN( result `lengthExceeds` 4, text "extendCSEnv: long list:" <+> ppr result )
322 lookupSubst (CS _ _ sub) x = case lookupVarEnv sub x of
326 extendSubst (CS cs in_scope sub) x y = CS cs in_scope (extendVarEnv sub x y)
328 addBinder :: CSEnv -> Id -> (CSEnv, Id)
329 addBinder env@(CS cs in_scope sub) v
330 | not (v `elemInScopeSet` in_scope) = (CS cs (extendInScopeSet in_scope v) sub, v)
331 | isId v = (CS cs (extendInScopeSet in_scope v') (extendVarEnv sub v v'), v')
332 | not (isId v) = WARN( True, ppr v )
333 (CS emptyUFM in_scope sub, v)
334 -- This last case is the unusual situation where we have shadowing of
335 -- a type variable; we have to discard the CSE mapping
336 -- See "IMPORTANT NOTE" at the top
338 v' = uniqAway in_scope v
340 addBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
341 addBinders env vs = mapAccumL addBinder env vs