54fbc5008c8a2836590cf9324c310c06f9d008ee
1 {-
2 (c) The AQUA Project, Glasgow University, 1993-1998
4 \section{Common subexpression}
5 -}
7 {-# LANGUAGE CPP #-}
9 module CSE (cseProgram) where
11 #include "HsVersions.h"
13 import CoreSubst
14 import Var ( Var )
15 import Id ( Id, idType, idUnfolding, idInlineActivation
16 , zapIdOccInfo, zapIdUsageInfo )
17 import CoreUtils ( mkAltExpr
18 , stripTicksE, stripTicksT, mkTicks )
19 import Literal ( litIsTrivial )
20 import Type ( tyConAppArgs )
21 import CoreSyn
22 import Outputable
23 import BasicTypes ( isAlwaysActive )
24 import TrieMap
25 import Data.List ( mapAccumL )
27 {-
28 Simple common sub-expression
29 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
30 When we see
31 x1 = C a b
32 x2 = C x1 b
33 we build up a reverse mapping: C a b -> x1
34 C x1 b -> x2
35 and apply that to the rest of the program.
37 When we then see
38 y1 = C a b
39 y2 = C y1 b
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
43 y2 = C y1 b
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
47 reverse mapping.
51 ~~~~~~~~~~~~~~~~
53 For example, consider
54 f = \x -> let y = x+x in
55 h = \x -> x+x
56 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.
63 Note [CSE for bindings]
64 ~~~~~~~~~~~~~~~~~~~~~~~
65 Let-bindings have two cases, implemented by addBinding.
67 * SUBSTITUTE: applies when the RHS is a variable or literal
69 let x = y in ...(h x)....
71 Here we want to extend the /substitution/ with x -> y, so that the
72 (h x) in the body might CSE with an enclosing (let v = h y in ...).
73 NB: the substitution maps InIds, so we extend the substitution with
74 a biding for the original InId 'x'
76 How can we have a variable on the RHS? Doesn't the simplifier inline them?
78 - First, the original RHS might have been (g z) which has CSE'd
79 with an enclosing (let y = g z in ...). This is super-important.
80 See Trac #5996:
81 x1 = C a b
82 x2 = C x1 b
83 y1 = C a b
84 y2 = C y1 b
85 Here we CSE y1's rhs to 'x1', and then we must add (y1->x1) to
86 the substitution so that we can CSE the binding for y2.
88 - Second, we use cseRHS for case expression scrutinees too;
89 see Note [CSE for case expressions]
91 * EXTEND THE REVERSE MAPPING: applies in all other cases
93 let x = h y in ...(h y)...
95 Here we want to extend the /reverse mapping (cs_map)/ so that
96 we CSE the (h y) call to x.
98 Note that we use EXTEND even for a trivial expression, provided it
99 is not a variable or literal. In particular this /includes/ type
100 applications. This can be important (Trac #13156); e.g.
101 case f @ Int of { r1 ->
102 case f @ Int of { r2 -> ...
103 Here we want to common-up the two uses of (f @ Int) so we can
104 remove one of the case expressions.
107 reason not to use SUBSTITUTE for all trivial expressions.
109 Notice that
110 - The SUBSTITUTE situation extends the substitution (cs_subst)
111 - The EXTEND situation extends the reverse mapping (cs_map)
113 Notice also that in the SUBSTITUTE case we leave behind a binding
114 x = y
115 even though we /also/ carry a substitution x -> y. Can we just drop
116 the binding instead? Well, not at top level! See SimplUtils
117 Note [Top level and postInlineUnconditionally]; and in any case CSE
118 applies only to the /bindings/ of the program, and we leave it to the
119 simplifier to propate effects to the RULES. Finally, it doesn't seem
120 worth the effort to discard the nested bindings because the simplifier
121 will do it next.
123 Note [CSE for case expressions]
124 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
125 Consider
126 case scrut_expr of x { ...alts... }
127 This is very like a strict let-binding
128 let !x = scrut_expr in ...
129 So we use (addBinding x scrut_expr) to process scrut_expr and x, and as a
130 result all the stuff under Note [CSE for bindings] applies directly.
132 For example:
134 * Trivial scrutinee
135 f = \x -> case x of wild {
136 (a:as) -> case a of wild1 {
137 (p,q) -> ...(wild1:as)...
139 Here, (wild1:as) is morally the same as (a:as) and hence equal to
140 wild. But that's not quite obvious. In the rest of the compiler we
141 want to keep it as (wild1:as), but for CSE purpose that's a bad
142 idea.
144 By using addBinding we add the binding (wild1 -> a) to the substitution,
145 which does exactly the right thing.
147 (Notice this is exactly backwards to what the simplifier does, which
148 is to try to replaces uses of 'a' with uses of 'wild1'.)
150 This is the main reason that cseRHs is called with a trivial rhs.
152 * Non-trivial scrutinee
153 case (f x) of y { pat -> ...let y = f x in ... }
155 By using addBinding we'll add (f x :-> y) to the cs_map, and
156 thereby CSE the inner (f x) to y.
158 Note [CSE for INLINE and NOINLINE]
159 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
160 There are some subtle interactions of CSE with functions that the user
161 has marked as INLINE or NOINLINE. (Examples from Roman Leshchinskiy.)
162 Consider
164 yes :: Int {-# NOINLINE yes #-}
165 yes = undefined
167 no :: Int {-# NOINLINE no #-}
168 no = undefined
170 foo :: Int -> Int -> Int {-# NOINLINE foo #-}
171 foo m n = n
173 {-# RULES "foo/no" foo no = id #-}
175 bar :: Int -> Int
176 bar = foo yes
178 We do not expect the rule to fire. But if we do CSE, then we risk
179 getting yes=no, and the rule does fire. Actually, it won't because
180 NOINLINE means that 'yes' will never be inlined, not even if we have
181 yes=no. So that's fine (now; perhaps in the olden days, yes=no would
182 have substituted even if 'yes' was NOINLINE).
184 But we do need to take care. Consider
186 {-# NOINLINE bar #-}
187 bar = <rhs> -- Same rhs as foo
189 foo = <rhs>
191 If CSE produces
192 foo = bar
193 then foo will never be inlined to <rhs> (when it should be, if <rhs>
194 is small). The conclusion here is this:
197 <rhs> :-> bar
198 to the CSEnv if 'bar' has any constraints on when it can inline;
199 that is, if its 'activation' not always active. Otherwise we
200 might replace <rhs> by 'bar', and then later be unable to see that it
201 really was <rhs>.
203 Note that we do not (currently) do CSE on the unfolding stored inside
204 an Id, even if is a 'stable' unfolding. That means that when an
205 unfolding happens, it is always faithful to what the stable unfolding
206 originally was.
208 Note [CSE for stable unfoldings]
209 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
210 Consider
211 {-# Unf = Stable (\pq. build blah) #-}
212 foo = x
214 Here 'foo' has a stable unfolding, but its (optimised) RHS is trivial.
215 (Turns out that this actually happens for the enumFromTo method of
216 the Integer instance of Enum in GHC.Enum.) Then we obviously do NOT
217 want to extend the substitution with (foo->x)! See similar
218 SimplUtils Note [Stable unfoldings and postInlineUnconditionally].
220 Nor do we want to change the reverse mapping. Suppose we have
222 {-# Unf = Stable (\pq. build blah) #-}
223 foo = <expr>
224 bar = <expr>
226 There could conceivably be merit in rewriting the RHS of bar:
227 bar = foo
228 but now bar's inlining behaviour will change, and importing
229 modules might see that. So it seems dodgy and we don't do it.
231 Note [Corner case for case expressions]
232 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
233 Here is another reason that we do not use SUBSTITUTE for
234 all trivial expressions. Consider
235 case x |> co of (y::Array# Int) { ... }
237 We do not want to extend the substitution with (y -> x |> co); since y
238 is of unlifted type, this would desroy the let/app invariant if (x |>
239 co) was not ok-for-speculation.
241 But surely (x |> co) is ok-for-speculation, becasue it's a trivial
242 expression, and x's type is also unlifted, presumably. Well, maybe
243 not if you are using unsafe casts. I actually found a case where we
245 (x :: HValue) |> (UnsafeCo :: HValue ~ Array# Int)
248 ************************************************************************
249 * *
250 \section{Common subexpression}
251 * *
252 ************************************************************************
253 -}
255 cseProgram :: CoreProgram -> CoreProgram
256 cseProgram binds = snd (mapAccumL cseBind emptyCSEnv binds)
258 cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind)
259 cseBind env (NonRec b e)
260 = (env2, NonRec b2 e1)
261 where
262 e1 = tryForCSE env e
263 (env1, b1) = addBinder env b
264 (env2, b2) = addBinding env1 b b1 e1
266 cseBind env (Rec pairs)
267 = (env2, Rec pairs')
268 where
269 (bndrs, rhss) = unzip pairs
270 (env1, bndrs1) = addRecBinders env bndrs
271 rhss1 = map (tryForCSE env1) rhss
272 -- Process rhss in extended env1
273 (env2, pairs') = foldl do_one (env1, []) (zip3 bndrs bndrs1 rhss1)
274 do_one (env, pairs) (b, b1, e1)
275 = (env1, (b2, e1) : pairs)
276 where
277 (env1, b2) = addBinding env b b1 e1
279 addBinding :: CSEnv -- Includes InId->OutId cloning
280 -> InId
281 -> OutId -> OutExpr -- Processed binding
282 -> (CSEnv, OutId) -- Final env, final bndr
283 -- Extend the CSE env with a mapping [rhs -> out-id]
284 -- unless we can instead just substitute [in-id -> rhs]
285 addBinding env in_id out_id rhs'
286 | no_cse = (env, out_id)
287 | use_subst = (extendCSSubst env in_id rhs', out_id)
288 | otherwise = (extendCSEnv env rhs' id_expr', zapped_id)
289 where
290 id_expr' = varToCoreExpr out_id
291 zapped_id = zapIdUsageInfo out_id
292 -- Putting the Id into the cs_map makes it possible that
293 -- it'll become shared more than it is now, which would
294 -- invalidate (the usage part of) its demand info.
295 -- This caused Trac #100218.
296 -- Easiest thing is to zap the usage info; subsequently
297 -- performing late demand-analysis will restore it. Don't zap
298 -- the strictness info; it's not necessary to do so, and losing
299 -- it is bad for performance if you don't do late demand
300 -- analysis
302 no_cse = not (isAlwaysActive (idInlineActivation out_id))
303 -- See Note [CSE for INLINE and NOINLINE]
304 || isStableUnfolding (idUnfolding out_id)
305 -- See Note [CSE for stable unfoldings]
307 -- Should we use SUBSTITUTE or EXTEND?
308 -- See Note [CSE for bindings]
309 use_subst = case rhs' of
310 Var {} -> True
311 Lit l -> litIsTrivial l
312 _ -> False
314 tryForCSE :: CSEnv -> InExpr -> OutExpr
315 tryForCSE env expr
316 | Just e <- lookupCSEnv env expr'' = mkTicks ticks e
317 | otherwise = expr'
318 -- The varToCoreExpr is needed if we have
319 -- case e of xco { ...case e of yco { ... } ... }
320 -- Then CSE will substitute yco -> xco;
321 -- but these are /coercion/ variables
322 where
323 expr' = cseExpr env expr
324 expr'' = stripTicksE tickishFloatable expr'
325 ticks = stripTicksT tickishFloatable expr'
326 -- We don't want to lose the source notes when a common sub
327 -- expression gets eliminated. Hence we push all (!) of them on
328 -- top of the replaced sub-expression. This is probably not too
329 -- useful in practice, but upholds our semantics.
331 cseExpr :: CSEnv -> InExpr -> OutExpr
332 cseExpr env (Type t) = Type (substTy (csEnvSubst env) t)
333 cseExpr env (Coercion c) = Coercion (substCo (csEnvSubst env) c)
334 cseExpr _ (Lit lit) = Lit lit
335 cseExpr env (Var v) = lookupSubst env v
336 cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a)
337 cseExpr env (Tick t e) = Tick t (cseExpr env e)
338 cseExpr env (Cast e co) = Cast (cseExpr env e) (substCo (csEnvSubst env) co)
339 cseExpr env (Lam b e) = let (env', b') = addBinder env b
340 in Lam b' (cseExpr env' e)
341 cseExpr env (Let bind e) = let (env', bind') = cseBind env bind
342 in Let bind' (cseExpr env' e)
343 cseExpr env (Case e bndr ty alts) = cseCase env e bndr ty alts
345 cseCase :: CSEnv -> InExpr -> InId -> InType -> [InAlt] -> OutExpr
346 cseCase env scrut bndr ty alts
347 = Case scrut1 bndr3 ty (map cse_alt alts)
348 where
349 scrut1 = tryForCSE env scrut
351 bndr1 = zapIdOccInfo bndr
352 -- Zapping the OccInfo is needed because the extendCSEnv
353 -- in cse_alt may mean that a dead case binder
354 -- becomes alive, and Lint rejects that
355 (env1, bndr2) = addBinder env bndr1
356 (alt_env, bndr3) = addBinding env1 bndr bndr2 scrut1
357 -- addBinding: see Note [CSE for case expressions]
359 con_target :: OutExpr
360 con_target = lookupSubst alt_env bndr
362 arg_tys :: [OutType]
363 arg_tys = tyConAppArgs (idType bndr3)
365 cse_alt (DataAlt con, args, rhs)
366 | not (null args)
367 -- Don't try CSE if there are no args; it just increases the number
368 -- of live vars. E.g.
369 -- case x of { True -> ....True.... }
370 -- Don't replace True by x!
371 -- Hence the 'null args', which also deal with literals and DEFAULT
372 = (DataAlt con, args', tryForCSE new_env rhs)
373 where
374 (env', args') = addBinders alt_env args
375 new_env = extendCSEnv env' con_expr con_target
376 con_expr = mkAltExpr (DataAlt con) args' arg_tys
378 cse_alt (con, args, rhs)
379 = (con, args', tryForCSE env' rhs)
380 where
381 (env', args') = addBinders alt_env args
383 {-
384 ************************************************************************
385 * *
386 \section{The CSE envt}
387 * *
388 ************************************************************************
389 -}
391 data CSEnv
392 = CS { cs_subst :: Subst -- Maps InBndrs to OutExprs
393 -- The substitution variables to
394 -- /trivial/ OutExprs, not arbitrary expressions
396 , cs_map :: CoreMap OutExpr -- The reverse mapping
397 -- Maps a OutExpr to a /trivial/ OutExpr
398 -- The key of cs_map is stripped of all Ticks
399 }
401 emptyCSEnv :: CSEnv
402 emptyCSEnv = CS { cs_map = emptyCoreMap, cs_subst = emptySubst }
404 lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr
405 lookupCSEnv (CS { cs_map = csmap }) expr
406 = lookupCoreMap csmap expr
408 extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv
409 extendCSEnv cse expr triv_expr
410 = cse { cs_map = extendCoreMap (cs_map cse) sexpr triv_expr }
411 where
412 sexpr = stripTicksE tickishFloatable expr
414 csEnvSubst :: CSEnv -> Subst
415 csEnvSubst = cs_subst
417 lookupSubst :: CSEnv -> Id -> OutExpr
418 lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst (text "CSE.lookupSubst") sub x
420 extendCSSubst :: CSEnv -> Id -> CoreExpr -> CSEnv
421 extendCSSubst cse x rhs = cse { cs_subst = extendSubst (cs_subst cse) x rhs }
423 addBinder :: CSEnv -> Var -> (CSEnv, Var)
424 addBinder cse v = (cse { cs_subst = sub' }, v')
425 where
426 (sub', v') = substBndr (cs_subst cse) v
428 addBinders :: CSEnv -> [Var] -> (CSEnv, [Var])
429 addBinders cse vs = (cse { cs_subst = sub' }, vs')
430 where
431 (sub', vs') = substBndrs (cs_subst cse) vs
433 addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
434 addRecBinders cse vs = (cse { cs_subst = sub' }, vs')
435 where
436 (sub', vs') = substRecBndrs (cs_subst cse) vs