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 , exprIsTrivial, exprOkForSpeculation
19 , stripTicksE, stripTicksT, mkTicks )
20 import Type ( tyConAppArgs, isUnliftedType )
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, implemnted by addBinding.
67 * Trivial RHS:
68 let x = y in ...(h x)....
70 Here we want to extend the /substitution/ with x -> y, so that the
71 (h x) in the body might CSE with an enclosing (let v = h y in ...).
72 NB: the substitution maps InIds, so we extend the substitution with
73 a biding for the original InId 'x'
75 How can we have a trivial RHS? Doens't the simplifier inline them?
77 - First, the original RHS might have been (g z) which has CSE'd
78 with an enclosing (let y = g z in ...). This is super-important.
79 See Trac #5996:
80 x1 = C a b
81 x2 = C x1 b
82 y1 = C a b
83 y2 = C y1 b
84 Here we CSE y1's rhs to 'x1', and then we must add (y1->x1) to
85 the substitution so that we can CSE the binding for y2.
87 - Second, we use cseRHS for case expression scrutinees too;
88 see Note [CSE for case expressions]
90 * Non-trivial RHS
91 let x = h y in ...(h y)...
93 Here we want to extend the /reverse mapping (cs_map)/ so that
94 we CSE the (h y) call to x.
96 Notice that
97 - The trivial-RHS situation extends the substitution (cs_subst)
98 - The non-trivial-RHS situation extends the reverse mapping (cs_map)
100 Notice also that in the trivial-RHS case we leave behind a binding
101 x = y
102 even though we /also/ carry a substitution x -> y. Can we just drop
103 the binding instead? Well, not at top level! See SimplUtils
104 Note [Top level and postInlineUnconditionally]; and in any case CSE
105 applies only to the /bindings/ of the program, and we leave it to the
106 simplifier to propate effects to the RULES. Finally, it doesn't seem
107 worth the effort to discard the nested bindings because the simplifier
108 will do it next.
110 Note [CSE for case expressions]
111 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
112 Consider
113 case scrut_expr of x { ...alts... }
114 This is very like a strict let-binding
115 let !x = scrut_expr in ...
116 So we use (addBinding x scrut_expr) to process scrut_expr and x, and as a
117 result all the stuff under Note [CSE for bindings] applies directly.
119 For example:
121 * Trivial scrutinee
122 f = \x -> case x of wild {
123 (a:as) -> case a of wild1 {
124 (p,q) -> ...(wild1:as)...
126 Here, (wild1:as) is morally the same as (a:as) and hence equal to
127 wild. But that's not quite obvious. In the rest of the compiler we
128 want to keep it as (wild1:as), but for CSE purpose that's a bad
129 idea.
131 By using addBinding we add the binding (wild1 -> a) to the substitution,
132 which does exactly the right thing.
134 (Notice this is exactly backwards to what the simplifier does, which
135 is to try to replaces uses of 'a' with uses of 'wild1'.)
137 This is the main reason that cseRHs is called with a trivial rhs.
139 * Non-trivial scrutinee
140 case (f x) of y { pat -> ...let y = f x in ... }
142 By using addBinding we'll add (f x :-> y) to the cs_map, and
143 thereby CSE the inner (f x) to y.
145 Note [CSE for INLINE and NOINLINE]
146 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
147 There are some subtle interactions of CSE with functions that the user
148 has marked as INLINE or NOINLINE. (Examples from Roman Leshchinskiy.)
149 Consider
151 yes :: Int {-# NOINLINE yes #-}
152 yes = undefined
154 no :: Int {-# NOINLINE no #-}
155 no = undefined
157 foo :: Int -> Int -> Int {-# NOINLINE foo #-}
158 foo m n = n
160 {-# RULES "foo/no" foo no = id #-}
162 bar :: Int -> Int
163 bar = foo yes
165 We do not expect the rule to fire. But if we do CSE, then we risk
166 getting yes=no, and the rule does fire. Actually, it won't because
167 NOINLINE means that 'yes' will never be inlined, not even if we have
168 yes=no. So that's fine (now; perhaps in the olden days, yes=no would
169 have substituted even if 'yes' was NOINLINE).
171 But we do need to take care. Consider
173 {-# NOINLINE bar #-}
174 bar = <rhs> -- Same rhs as foo
176 foo = <rhs>
178 If CSE produces
179 foo = bar
180 then foo will never be inlined to <rhs> (when it should be, if <rhs>
181 is small). The conclusion here is this:
184 <rhs> :-> bar
185 to the CSEnv if 'bar' has any constraints on when it can inline;
186 that is, if its 'activation' not always active. Otherwise we
187 might replace <rhs> by 'bar', and then later be unable to see that it
188 really was <rhs>.
190 Note that we do not (currently) do CSE on the unfolding stored inside
191 an Id, even if is a 'stable' unfolding. That means that when an
192 unfolding happens, it is always faithful to what the stable unfolding
193 originally was.
195 Note [CSE for stable unfoldings]
196 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
197 Consider
198 {-# Unf = Stable (\pq. build blah) #-}
199 foo = x
201 Here 'foo' has a stable unfolding, but its (optimised) RHS is trivial.
202 (Turns out that this actually happens for the enumFromTo method of
203 the Integer instance of Enum in GHC.Enum.) Then we obviously do NOT
204 want to extend the substitution with (foo->x)! See similar
205 SimplUtils Note [Stable unfoldings and postInlineUnconditionally].
207 Nor do we want to change the reverse mapping. Suppose we have
209 {-# Unf = Stable (\pq. build blah) #-}
210 foo = <expr>
211 bar = <expr>
213 There could conceivably be merit in rewriting the RHS of bar:
214 bar = foo
215 but now bar's inlining behaviour will change, and importing
216 modules might see that. So it seems dodgy and we don't do it.
218 Note [Corner case for case expressions]
219 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
220 Consdider
221 case x |> co of (y::Array# Int) { ... }
223 Is it ok to extend the substutition with (y -> x |> co)?
224 Because y is of unlifted type, this is only OK if (x |> co) is
225 ok-for-speculation, else we'll destroy the let/app invariant.
226 But surely it is ok-for-speculation, becasue it's a trivial
227 expression, and x's type is also unlifted, presumably.
229 Well, maybe not if you are using unsafe casts. I actually found
230 a case where we had
231 (x :: HValue) |> (UnsafeCo :: HValue ~ Array# Int)
232 This is a vanishingly strange corner case, but we still have
233 to check.
235 We do the check in addBinding, but it can't fire when addBinding is called
236 from a let-binding, because they are always ok-for-speculation. Never
237 mind!
240 ************************************************************************
241 * *
242 \section{Common subexpression}
243 * *
244 ************************************************************************
245 -}
247 cseProgram :: CoreProgram -> CoreProgram
248 cseProgram binds = snd (mapAccumL cseBind emptyCSEnv binds)
250 cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind)
251 cseBind env (NonRec b e)
252 = (env2, NonRec b2 e1)
253 where
254 e1 = tryForCSE env e
255 (env1, b1) = addBinder env b
256 (env2, b2) = addBinding env1 b b1 e1
258 cseBind env (Rec pairs)
259 = (env2, Rec pairs')
260 where
261 (bndrs, rhss) = unzip pairs
262 (env1, bndrs1) = addRecBinders env bndrs
263 rhss1 = map (tryForCSE env1) rhss
264 -- Process rhss in extended env1
265 (env2, pairs') = foldl do_one (env1, []) (zip3 bndrs bndrs1 rhss1)
266 do_one (env, pairs) (b, b1, e1)
267 = (env1, (b2, e1) : pairs)
268 where
269 (env1, b2) = addBinding env b b1 e1
271 addBinding :: CSEnv -- Includes InId->OutId cloning
272 -> InId
273 -> OutId -> OutExpr -- Processed binding
274 -> (CSEnv, OutId) -- Final env, final bndr
275 -- Extend the CSE env with a mapping [rhs -> out-id]
276 -- unless we can instead just substitute [in-id -> rhs]
277 addBinding env in_id out_id rhs'
278 | no_cse = (env, out_id)
279 | ok_to_subst = (extendCSSubst env in_id rhs', out_id)
280 | otherwise = (extendCSEnv env rhs' id_expr', zapped_id)
281 where
282 id_expr' = varToCoreExpr out_id
283 zapped_id = zapIdUsageInfo out_id
284 -- Putting the Id into the cs_map makes it possible that
285 -- it'll become shared more than it is now, which would
286 -- invalidate (the usage part of) its demand info.
287 -- This caused Trac #100218.
288 -- Easiest thing is to zap the usage info; subsequently
289 -- performing late demand-analysis will restore it. Don't zap
290 -- the strictness info; it's not necessary to do so, and losing
291 -- it is bad for performance if you don't do late demand
292 -- analysis
294 no_cse = not (isAlwaysActive (idInlineActivation out_id))
295 -- See Note [CSE for INLINE and NOINLINE]
296 || isStableUnfolding (idUnfolding out_id)
297 -- See Note [CSE for stable unfoldings]
299 -- See Note [CSE for bindings]
300 ok_to_subst = exprIsTrivial rhs'
301 && (not (isUnliftedType (idType out_id))
302 || exprOkForSpeculation rhs')
303 -- See Note [Corner case for case expressions]
305 tryForCSE :: CSEnv -> InExpr -> OutExpr
306 tryForCSE env expr
307 | exprIsTrivial expr' = expr' -- No point
308 | Just e <- lookupCSEnv env expr'' = mkTicks ticks e
309 | otherwise = expr'
310 -- The varToCoreExpr is needed if we have
311 -- case e of xco { ...case e of yco { ... } ... }
312 -- Then CSE will substitute yco -> xco;
313 -- but these are /coercion/ variables
314 where
315 expr' = cseExpr env expr
316 expr'' = stripTicksE tickishFloatable expr'
317 ticks = stripTicksT tickishFloatable expr'
318 -- We don't want to lose the source notes when a common sub
319 -- expression gets eliminated. Hence we push all (!) of them on
320 -- top of the replaced sub-expression. This is probably not too
321 -- useful in practice, but upholds our semantics.
323 cseExpr :: CSEnv -> InExpr -> OutExpr
324 cseExpr env (Type t) = Type (substTy (csEnvSubst env) t)
325 cseExpr env (Coercion c) = Coercion (substCo (csEnvSubst env) c)
326 cseExpr _ (Lit lit) = Lit lit
327 cseExpr env (Var v) = lookupSubst env v
328 cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a)
329 cseExpr env (Tick t e) = Tick t (cseExpr env e)
330 cseExpr env (Cast e co) = Cast (cseExpr env e) (substCo (csEnvSubst env) co)
331 cseExpr env (Lam b e) = let (env', b') = addBinder env b
332 in Lam b' (cseExpr env' e)
333 cseExpr env (Let bind e) = let (env', bind') = cseBind env bind
334 in Let bind' (cseExpr env' e)
335 cseExpr env (Case e bndr ty alts) = cseCase env e bndr ty alts
337 cseCase :: CSEnv -> InExpr -> InId -> InType -> [InAlt] -> OutExpr
338 cseCase env scrut bndr ty alts
339 = Case scrut1 bndr3 ty (map cse_alt alts)
340 where
341 scrut1 = tryForCSE env scrut
343 bndr1 = zapIdOccInfo bndr
344 -- Zapping the OccInfo is needed because the extendCSEnv
345 -- in cse_alt may mean that a dead case binder
346 -- becomes alive, and Lint rejects that
347 (env1, bndr2) = addBinder env bndr1
348 (alt_env, bndr3) = addBinding env1 bndr bndr2 scrut1
349 -- addBinding: see Note [CSE for case expressions]
351 con_target :: OutExpr
352 con_target = lookupSubst alt_env bndr
354 arg_tys :: [OutType]
355 arg_tys = tyConAppArgs (idType bndr3)
357 cse_alt (DataAlt con, args, rhs)
358 | not (null args)
359 -- Don't try CSE if there are no args; it just increases the number
360 -- of live vars. E.g.
361 -- case x of { True -> ....True.... }
362 -- Don't replace True by x!
363 -- Hence the 'null args', which also deal with literals and DEFAULT
364 = (DataAlt con, args', tryForCSE new_env rhs)
365 where
366 (env', args') = addBinders alt_env args
367 new_env = extendCSEnv env' con_expr con_target
368 con_expr = mkAltExpr (DataAlt con) args' arg_tys
370 cse_alt (con, args, rhs)
371 = (con, args', tryForCSE env' rhs)
372 where
373 (env', args') = addBinders alt_env args
375 {-
376 ************************************************************************
377 * *
378 \section{The CSE envt}
379 * *
380 ************************************************************************
381 -}
383 data CSEnv
384 = CS { cs_subst :: Subst -- Maps InBndrs to OutExprs
385 -- The substitution variables to
386 -- /trivial/ OutExprs, not arbitrary expressions
388 , cs_map :: CoreMap OutExpr -- The reverse mapping
389 -- Maps a OutExpr to a /trivial/ OutExpr
390 -- The key of cs_map is stripped of all Ticks
391 }
393 emptyCSEnv :: CSEnv
394 emptyCSEnv = CS { cs_map = emptyCoreMap, cs_subst = emptySubst }
396 lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr
397 lookupCSEnv (CS { cs_map = csmap }) expr
398 = lookupCoreMap csmap expr
400 extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv
401 extendCSEnv cse expr triv_expr
402 = cse { cs_map = extendCoreMap (cs_map cse) sexpr triv_expr }
403 where
404 sexpr = stripTicksE tickishFloatable expr
406 csEnvSubst :: CSEnv -> Subst
407 csEnvSubst = cs_subst
409 lookupSubst :: CSEnv -> Id -> OutExpr
410 lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst (text "CSE.lookupSubst") sub x
412 extendCSSubst :: CSEnv -> Id -> CoreExpr -> CSEnv
413 extendCSSubst cse x rhs = cse { cs_subst = extendSubst (cs_subst cse) x rhs }
415 addBinder :: CSEnv -> Var -> (CSEnv, Var)
416 addBinder cse v = (cse { cs_subst = sub' }, v')
417 where
418 (sub', v') = substBndr (cs_subst cse) v
420 addBinders :: CSEnv -> [Var] -> (CSEnv, [Var])
421 addBinders cse vs = (cse { cs_subst = sub' }, vs')
422 where
423 (sub', vs') = substBndrs (cs_subst cse) vs
425 addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
426 addRecBinders cse vs = (cse { cs_subst = sub' }, vs')
427 where
428 (sub', vs') = substRecBndrs (cs_subst cse) vs