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 , exprIsLiteralString
19 , stripTicksE, stripTicksT, mkTicks )
20 import Literal ( litIsTrivial )
21 import Type ( tyConAppArgs )
22 import CoreSyn
23 import Outputable
24 import BasicTypes ( isAlwaysActive )
25 import TrieMap
26 import Data.List ( mapAccumL )
28 {-
29 Simple common sub-expression
30 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
31 When we see
32 x1 = C a b
33 x2 = C x1 b
34 we build up a reverse mapping: C a b -> x1
35 C x1 b -> x2
36 and apply that to the rest of the program.
38 When we then see
39 y1 = C a b
40 y2 = C y1 b
41 we replace the C a b with x1. But then we *dont* want to
42 add x1 -> y1 to the mapping. Rather, we want the reverse, y1 -> x1
43 so that a subsequent binding
44 y2 = C y1 b
45 will get transformed to C x1 b, and then to x2.
47 So we carry an extra var->var substitution which we apply *before* looking up in the
48 reverse mapping.
51 Note [Shadowing]
52 ~~~~~~~~~~~~~~~~
53 We have to be careful about shadowing.
54 For example, consider
55 f = \x -> let y = x+x in
56 h = \x -> x+x
57 in ...
59 Here we must *not* do CSE on the inner x+x! The simplifier used to guarantee no
60 shadowing, but it doesn't any more (it proved too hard), so we clone as we go.
61 We can simply add clones to the substitution already described.
64 Note [CSE for bindings]
65 ~~~~~~~~~~~~~~~~~~~~~~~
66 Let-bindings have two cases, implemented by addBinding.
68 * SUBSTITUTE: applies when the RHS is a variable or literal
70 let x = y in ...(h x)....
72 Here we want to extend the /substitution/ with x -> y, so that the
73 (h x) in the body might CSE with an enclosing (let v = h y in ...).
74 NB: the substitution maps InIds, so we extend the substitution with
75 a biding for the original InId 'x'
77 How can we have a variable on the RHS? Doesn't the simplifier inline them?
79 - First, the original RHS might have been (g z) which has CSE'd
80 with an enclosing (let y = g z in ...). This is super-important.
81 See Trac #5996:
82 x1 = C a b
83 x2 = C x1 b
84 y1 = C a b
85 y2 = C y1 b
86 Here we CSE y1's rhs to 'x1', and then we must add (y1->x1) to
87 the substitution so that we can CSE the binding for y2.
89 - Second, we use cseRHS for case expression scrutinees too;
90 see Note [CSE for case expressions]
92 * EXTEND THE REVERSE MAPPING: applies in all other cases
94 let x = h y in ...(h y)...
96 Here we want to extend the /reverse mapping (cs_map)/ so that
97 we CSE the (h y) call to x.
99 Note that we use EXTEND even for a trivial expression, provided it
100 is not a variable or literal. In particular this /includes/ type
101 applications. This can be important (Trac #13156); e.g.
102 case f @ Int of { r1 ->
103 case f @ Int of { r2 -> ...
104 Here we want to common-up the two uses of (f @ Int) so we can
105 remove one of the case expressions.
107 See also Note [Corner case for case expressions] for another
108 reason not to use SUBSTITUTE for all trivial expressions.
110 Notice that
111 - The SUBSTITUTE situation extends the substitution (cs_subst)
112 - The EXTEND situation extends the reverse mapping (cs_map)
114 Notice also that in the SUBSTITUTE case we leave behind a binding
115 x = y
116 even though we /also/ carry a substitution x -> y. Can we just drop
117 the binding instead? Well, not at top level! See SimplUtils
118 Note [Top level and postInlineUnconditionally]; and in any case CSE
119 applies only to the /bindings/ of the program, and we leave it to the
120 simplifier to propate effects to the RULES. Finally, it doesn't seem
121 worth the effort to discard the nested bindings because the simplifier
122 will do it next.
124 Note [CSE for case expressions]
125 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
126 Consider
127 case scrut_expr of x { ...alts... }
128 This is very like a strict let-binding
129 let !x = scrut_expr in ...
130 So we use (addBinding x scrut_expr) to process scrut_expr and x, and as a
131 result all the stuff under Note [CSE for bindings] applies directly.
133 For example:
135 * Trivial scrutinee
136 f = \x -> case x of wild {
137 (a:as) -> case a of wild1 {
138 (p,q) -> ...(wild1:as)...
140 Here, (wild1:as) is morally the same as (a:as) and hence equal to
141 wild. But that's not quite obvious. In the rest of the compiler we
142 want to keep it as (wild1:as), but for CSE purpose that's a bad
143 idea.
145 By using addBinding we add the binding (wild1 -> a) to the substitution,
146 which does exactly the right thing.
148 (Notice this is exactly backwards to what the simplifier does, which
149 is to try to replaces uses of 'a' with uses of 'wild1'.)
151 This is the main reason that cseRHs is called with a trivial rhs.
153 * Non-trivial scrutinee
154 case (f x) of y { pat -> ...let y = f x in ... }
156 By using addBinding we'll add (f x :-> y) to the cs_map, and
157 thereby CSE the inner (f x) to y.
159 Note [CSE for INLINE and NOINLINE]
160 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
161 There are some subtle interactions of CSE with functions that the user
162 has marked as INLINE or NOINLINE. (Examples from Roman Leshchinskiy.)
163 Consider
165 yes :: Int {-# NOINLINE yes #-}
166 yes = undefined
168 no :: Int {-# NOINLINE no #-}
169 no = undefined
171 foo :: Int -> Int -> Int {-# NOINLINE foo #-}
172 foo m n = n
174 {-# RULES "foo/no" foo no = id #-}
176 bar :: Int -> Int
177 bar = foo yes
179 We do not expect the rule to fire. But if we do CSE, then we risk
180 getting yes=no, and the rule does fire. Actually, it won't because
181 NOINLINE means that 'yes' will never be inlined, not even if we have
182 yes=no. So that's fine (now; perhaps in the olden days, yes=no would
183 have substituted even if 'yes' was NOINLINE).
185 But we do need to take care. Consider
187 {-# NOINLINE bar #-}
188 bar = <rhs> -- Same rhs as foo
190 foo = <rhs>
192 If CSE produces
193 foo = bar
194 then foo will never be inlined to <rhs> (when it should be, if <rhs>
195 is small). The conclusion here is this:
197 We should not add
198 <rhs> :-> bar
199 to the CSEnv if 'bar' has any constraints on when it can inline;
200 that is, if its 'activation' not always active. Otherwise we
201 might replace <rhs> by 'bar', and then later be unable to see that it
202 really was <rhs>.
204 Note that we do not (currently) do CSE on the unfolding stored inside
205 an Id, even if is a 'stable' unfolding. That means that when an
206 unfolding happens, it is always faithful to what the stable unfolding
207 originally was.
209 Note [CSE for stable unfoldings]
210 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
211 Consider
212 {-# Unf = Stable (\pq. build blah) #-}
213 foo = x
215 Here 'foo' has a stable unfolding, but its (optimised) RHS is trivial.
216 (Turns out that this actually happens for the enumFromTo method of
217 the Integer instance of Enum in GHC.Enum.) Then we obviously do NOT
218 want to extend the substitution with (foo->x)! See similar
219 SimplUtils Note [Stable unfoldings and postInlineUnconditionally].
221 Nor do we want to change the reverse mapping. Suppose we have
223 {-# Unf = Stable (\pq. build blah) #-}
224 foo = <expr>
225 bar = <expr>
227 There could conceivably be merit in rewriting the RHS of bar:
228 bar = foo
229 but now bar's inlining behaviour will change, and importing
230 modules might see that. So it seems dodgy and we don't do it.
232 Note [Corner case for case expressions]
233 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
234 Here is another reason that we do not use SUBSTITUTE for
235 all trivial expressions. Consider
236 case x |> co of (y::Array# Int) { ... }
238 We do not want to extend the substitution with (y -> x |> co); since y
239 is of unlifted type, this would desroy the let/app invariant if (x |>
240 co) was not ok-for-speculation.
242 But surely (x |> co) is ok-for-speculation, becasue it's a trivial
243 expression, and x's type is also unlifted, presumably. Well, maybe
244 not if you are using unsafe casts. I actually found a case where we
245 had
246 (x :: HValue) |> (UnsafeCo :: HValue ~ Array# Int)
249 ************************************************************************
250 * *
251 \section{Common subexpression}
252 * *
253 ************************************************************************
254 -}
256 cseProgram :: CoreProgram -> CoreProgram
257 cseProgram binds = snd (mapAccumL (cseBind True) emptyCSEnv binds)
259 cseBind :: Bool -> CSEnv -> CoreBind -> (CSEnv, CoreBind)
260 cseBind toplevel env (NonRec b e)
261 = (env2, NonRec b2 e1)
262 where
263 e1 = tryForCSE toplevel env e
264 (env1, b1) = addBinder env b
265 (env2, b2) = addBinding env1 b b1 e1
267 cseBind toplevel env (Rec pairs)
268 = (env2, Rec pairs')
269 where
270 (bndrs, rhss) = unzip pairs
271 (env1, bndrs1) = addRecBinders env bndrs
272 rhss1 = map (tryForCSE toplevel env1) rhss
273 -- Process rhss in extended env1
274 (env2, pairs') = foldl do_one (env1, []) (zip3 bndrs bndrs1 rhss1)
275 do_one (env, pairs) (b, b1, e1)
276 = (env1, (b2, e1) : pairs)
277 where
278 (env1, b2) = addBinding env b b1 e1
280 addBinding :: CSEnv -- Includes InId->OutId cloning
281 -> InId
282 -> OutId -> OutExpr -- Processed binding
283 -> (CSEnv, OutId) -- Final env, final bndr
284 -- Extend the CSE env with a mapping [rhs -> out-id]
285 -- unless we can instead just substitute [in-id -> rhs]
286 addBinding env in_id out_id rhs'
287 | no_cse = (env, out_id)
288 | use_subst = (extendCSSubst env in_id rhs', out_id)
289 | otherwise = (extendCSEnv env rhs' id_expr', zapped_id)
290 where
291 id_expr' = varToCoreExpr out_id
292 zapped_id = zapIdUsageInfo out_id
293 -- Putting the Id into the cs_map makes it possible that
294 -- it'll become shared more than it is now, which would
295 -- invalidate (the usage part of) its demand info.
296 -- This caused Trac #100218.
297 -- Easiest thing is to zap the usage info; subsequently
298 -- performing late demand-analysis will restore it. Don't zap
299 -- the strictness info; it's not necessary to do so, and losing
300 -- it is bad for performance if you don't do late demand
301 -- analysis
303 no_cse = not (isAlwaysActive (idInlineActivation out_id))
304 -- See Note [CSE for INLINE and NOINLINE]
305 || isStableUnfolding (idUnfolding out_id)
306 -- See Note [CSE for stable unfoldings]
308 -- Should we use SUBSTITUTE or EXTEND?
309 -- See Note [CSE for bindings]
310 use_subst = case rhs' of
311 Var {} -> True
312 Lit l -> litIsTrivial l
313 _ -> False
315 {-
316 Note [Take care with literal strings]
317 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
319 Consider this example:
321 x = "foo"#
322 y = "foo"#
323 ...x...y...x...y....
325 We would normally turn this into:
327 x = "foo"#
328 y = x
329 ...x...x...x...x....
331 But this breaks an invariant of Core, namely that the RHS of a top-level binding
332 of type Addr# must be a string literal, not another variable. See Note
333 [CoreSyn top-level string literals] in CoreSyn.
335 For this reason, we special case top-level bindings to literal strings and leave
336 the original RHS unmodified. This produces:
338 x = "foo"#
339 y = "foo"#
340 ...x...x...x...x....
341 -}
343 tryForCSE :: Bool -> CSEnv -> InExpr -> OutExpr
344 tryForCSE toplevel env expr
345 | toplevel && exprIsLiteralString expr = expr
346 -- See Note [Take care with literal strings]
347 | Just e <- lookupCSEnv env expr'' = mkTicks ticks e
348 | otherwise = expr'
349 -- The varToCoreExpr is needed if we have
350 -- case e of xco { ...case e of yco { ... } ... }
351 -- Then CSE will substitute yco -> xco;
352 -- but these are /coercion/ variables
353 where
354 expr' = cseExpr env expr
355 expr'' = stripTicksE tickishFloatable expr'
356 ticks = stripTicksT tickishFloatable expr'
357 -- We don't want to lose the source notes when a common sub
358 -- expression gets eliminated. Hence we push all (!) of them on
359 -- top of the replaced sub-expression. This is probably not too
360 -- useful in practice, but upholds our semantics.
362 cseExpr :: CSEnv -> InExpr -> OutExpr
363 cseExpr env (Type t) = Type (substTy (csEnvSubst env) t)
364 cseExpr env (Coercion c) = Coercion (substCo (csEnvSubst env) c)
365 cseExpr _ (Lit lit) = Lit lit
366 cseExpr env (Var v) = lookupSubst env v
367 cseExpr env (App f a) = App (cseExpr env f) (tryForCSE False env a)
368 cseExpr env (Tick t e) = Tick t (cseExpr env e)
369 cseExpr env (Cast e co) = Cast (cseExpr env e) (substCo (csEnvSubst env) co)
370 cseExpr env (Lam b e) = let (env', b') = addBinder env b
371 in Lam b' (cseExpr env' e)
372 cseExpr env (Let bind e) = let (env', bind') = cseBind False env bind
373 in Let bind' (cseExpr env' e)
374 cseExpr env (Case e bndr ty alts) = cseCase env e bndr ty alts
376 cseCase :: CSEnv -> InExpr -> InId -> InType -> [InAlt] -> OutExpr
377 cseCase env scrut bndr ty alts
378 = Case scrut1 bndr3 ty (map cse_alt alts)
379 where
380 scrut1 = tryForCSE False env scrut
382 bndr1 = zapIdOccInfo bndr
383 -- Zapping the OccInfo is needed because the extendCSEnv
384 -- in cse_alt may mean that a dead case binder
385 -- becomes alive, and Lint rejects that
386 (env1, bndr2) = addBinder env bndr1
387 (alt_env, bndr3) = addBinding env1 bndr bndr2 scrut1
388 -- addBinding: see Note [CSE for case expressions]
390 con_target :: OutExpr
391 con_target = lookupSubst alt_env bndr
393 arg_tys :: [OutType]
394 arg_tys = tyConAppArgs (idType bndr3)
396 cse_alt (DataAlt con, args, rhs)
397 | not (null args)
398 -- Don't try CSE if there are no args; it just increases the number
399 -- of live vars. E.g.
400 -- case x of { True -> ....True.... }
401 -- Don't replace True by x!
402 -- Hence the 'null args', which also deal with literals and DEFAULT
403 = (DataAlt con, args', tryForCSE False new_env rhs)
404 where
405 (env', args') = addBinders alt_env args
406 new_env = extendCSEnv env' con_expr con_target
407 con_expr = mkAltExpr (DataAlt con) args' arg_tys
409 cse_alt (con, args, rhs)
410 = (con, args', tryForCSE False env' rhs)
411 where
412 (env', args') = addBinders alt_env args
414 {-
415 ************************************************************************
416 * *
417 \section{The CSE envt}
418 * *
419 ************************************************************************
420 -}
422 data CSEnv
423 = CS { cs_subst :: Subst -- Maps InBndrs to OutExprs
424 -- The substitution variables to
425 -- /trivial/ OutExprs, not arbitrary expressions
427 , cs_map :: CoreMap OutExpr -- The reverse mapping
428 -- Maps a OutExpr to a /trivial/ OutExpr
429 -- The key of cs_map is stripped of all Ticks
430 }
432 emptyCSEnv :: CSEnv
433 emptyCSEnv = CS { cs_map = emptyCoreMap, cs_subst = emptySubst }
435 lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr
436 lookupCSEnv (CS { cs_map = csmap }) expr
437 = lookupCoreMap csmap expr
439 extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv
440 extendCSEnv cse expr triv_expr
441 = cse { cs_map = extendCoreMap (cs_map cse) sexpr triv_expr }
442 where
443 sexpr = stripTicksE tickishFloatable expr
445 csEnvSubst :: CSEnv -> Subst
446 csEnvSubst = cs_subst
448 lookupSubst :: CSEnv -> Id -> OutExpr
449 lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst (text "CSE.lookupSubst") sub x
451 extendCSSubst :: CSEnv -> Id -> CoreExpr -> CSEnv
452 extendCSSubst cse x rhs = cse { cs_subst = extendSubst (cs_subst cse) x rhs }
454 addBinder :: CSEnv -> Var -> (CSEnv, Var)
455 addBinder cse v = (cse { cs_subst = sub' }, v')
456 where
457 (sub', v') = substBndr (cs_subst cse) v
459 addBinders :: CSEnv -> [Var] -> (CSEnv, [Var])
460 addBinders cse vs = (cse { cs_subst = sub' }, vs')
461 where
462 (sub', vs') = substBndrs (cs_subst cse) vs
464 addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
465 addRecBinders cse vs = (cse { cs_subst = sub' }, vs')
466 where
467 (sub', vs') = substRecBndrs (cs_subst cse) vs