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 ( Type, tyConAppArgs, isUnliftedType )
21 import CoreSyn
22 import Outputable
23 import BasicTypes ( isAlwaysActive )
24 import TrieMap
26 import Data.List
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.
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, implemnted by cseRhs.
68 * Trivial RHS:
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 trivial RHS? Doens'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 * Non-trivial RHS
92 let x = h y in ...(h y)...
94 Here we want to extend the /reverse mapping (cs_map)/ so that
95 we CSE the (h y) call to x.
97 Notice that
98 - the trivial-RHS situation extends the substitution (cs_subst)
99 - the non-trivial-RHS situation extends the reverse mapping (cs_map)
101 Note [CSE for case expressions]
102 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
103 Consider
104 case scrut_expr of x { ...alts... }
105 This is very like a strict let-binding
106 let !x = scrut_expr in ...
107 So we use (cseRhs x scrut_expr) to process scrut_expr and x, and as a
108 result all the stuff under Note [CSE for bindings] applies directly.
110 For example:
112 * Trivial scrutinee
113 f = \x -> case x of wild {
114 (a:as) -> case a of wild1 {
115 (p,q) -> ...(wild1:as)...
117 Here, (wild1:as) is morally the same as (a:as) and hence equal to
118 wild. But that's not quite obvious. In the rest of the compiler we
119 want to keep it as (wild1:as), but for CSE purpose that's a bad
120 idea.
122 By using cseRhs we add the binding (wild1 -> a) to the substitution,
123 which does exactly the right thing.
125 (Notice this is exactly backwards to what the simplifier does, which
126 is to try to replaces uses of 'a' with uses of 'wild1'.)
128 This is the main reason that cseRHs is called with a trivial rhs.
130 * Non-trivial scrutinee
131 case (f x) of y { pat -> ...let y = f x in ... }
133 By using cseRhs we'll add (f x :-> y) to the cs_map, and
134 thereby CSE the inner (f x) to y.
136 Note [CSE for INLINE and NOINLINE]
137 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
138 There are some subtle interactions of CSE with functions that the user
139 has marked as INLINE or NOINLINE. (Examples from Roman Leshchinskiy.)
140 Consider
142 yes :: Int {-# NOINLINE yes #-}
143 yes = undefined
145 no :: Int {-# NOINLINE no #-}
146 no = undefined
148 foo :: Int -> Int -> Int {-# NOINLINE foo #-}
149 foo m n = n
151 {-# RULES "foo/no" foo no = id #-}
153 bar :: Int -> Int
154 bar = foo yes
156 We do not expect the rule to fire. But if we do CSE, then we risk
157 getting yes=no, and the rule does fire. Actually, it won't because
158 NOINLINE means that 'yes' will never be inlined, not even if we have
159 yes=no. So that's fine (now; perhaps in the olden days, yes=no would
160 have substituted even if 'yes' was NOINLINE).
162 But we do need to take care. Consider
164 {-# NOINLINE bar #-}
165 bar = <rhs> -- Same rhs as foo
167 foo = <rhs>
169 If CSE produces
170 foo = bar
171 then foo will never be inlined to <rhs> (when it should be, if <rhs>
172 is small). The conclusion here is this:
174 We should not add
175 <rhs> :-> bar
176 to the CSEnv if 'bar' has any constraints on when it can inline;
177 that is, if its 'activation' not always active. Otherwise we
178 might replace <rhs> by 'bar', and then later be unable to see that it
179 really was <rhs>.
181 Note that we do not (currently) do CSE on the unfolding stored inside
182 an Id, even if is a 'stable' unfolding. That means that when an
183 unfolding happens, it is always faithful to what the stable unfolding
184 originally was.
186 Note [CSE for stable unfoldings]
187 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
188 Consider
189 {-# Unf = Stable (\pq. build blah) #-}
190 foo = x
192 Here 'foo' has a stable unfolding, but its (optimised) RHS is trivial.
193 (Turns out that this actually happens for the enumFromTo method of
194 the Integer instance of Enum in GHC.Enum.) Then we obviously do NOT
195 want to extend the substitution with (foo->x)! See similar
196 SimplUtils Note [Stable unfoldings and postInlineUnconditionally].
198 Nor do we want to change the reverse mapping. Suppose we have
200 {-# Unf = Stable (\pq. build blah) #-}
201 foo = <expr>
202 bar = <expr>
204 There could conceivably be merit in rewriting the RHS of bar:
205 bar = foo
206 but now bar's inlining behaviour will change, and importing
207 modules might see that. So it seems dodgy and we don't do it.
209 Note [Corner case for case expressions]
210 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
211 Consdider
212 case x |> co of (y::Array# Int) { ... }
214 Is it ok to extend the substutition with (y -> x |> co)?
215 Because y is of unlifted type, this is only OK if (x |> co) is
216 ok-for-speculation, else we'll destroy the let/app invariant.
217 But surely it is ok-for-speculation, becasue it's a trivial
218 expression, and x's type is also unlifted, presumably.
220 Well, maybe not if you are using unsafe casts. I actually found
221 a case where we had
222 (x :: HValue) |> (UnsafeCo :: HValue ~ Array# Int)
223 This is a vanishingly strange corner case, but we still have
224 to check.
226 We do the check in cseRhs, but it can't fire when cseRhs is called
227 from a let-binding, becuase they are always ok-for-speculation. Never
228 mind!
231 ************************************************************************
232 * *
233 \section{Common subexpression}
234 * *
235 ************************************************************************
236 -}
238 cseProgram :: CoreProgram -> CoreProgram
239 cseProgram binds = snd (mapAccumL cseBind emptyCSEnv binds)
241 cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind)
242 cseBind env (NonRec b e)
243 = (env2, NonRec b'' e')
244 where
245 (env1, b') = addBinder env b
246 (env2, (b'', e')) = cseRhs env1 b b' e
248 cseBind env (Rec pairs)
249 = (env2, Rec pairs')
250 where
251 (env1, bs') = addRecBinders env (map fst pairs)
252 (env2, pairs') = mapAccumL cse_rhs env1 (bs' `zip` pairs)
253 cse_rhs env (b', (b,e)) = cseRhs env b b' e
255 cseRhs :: CSEnv -> InId -> OutId -> InExpr -> (CSEnv, (OutId, OutExpr))
256 cseRhs env in_id out_id rhs
257 | no_cse = (env, (out_id, rhs'))
258 | ok_to_subst = (extendCSSubst env in_id rhs', (out_id, rhs'))
259 | otherwise = (extendCSEnv env rhs' id_expr', (zapped_id, rhs'))
260 where
261 id_expr' = varToCoreExpr out_id
262 rhs' = tryForCSE env rhs
263 zapped_id = zapIdUsageInfo out_id
264 -- Putting the Id into the cs_map makes it possible that
265 -- it'll become shared more than it is now, which would
266 -- invalidate (the usage part of) its demand info.
267 -- This caused Trac #100218.
268 -- Easiest thing is to zap the usage info; subsequently
269 -- performing late demand-analysis will restore it. Don't zap
270 -- the strictness info; it's not necessary to do so, and losing
271 -- it is bad for performance if you don't do late demand
272 -- analysis
274 no_cse = not (isAlwaysActive (idInlineActivation out_id))
275 -- See Note [CSE for INLINE and NOINLINE]
276 || isStableUnfolding (idUnfolding out_id)
277 -- See Note [CSE for stable unfoldings]
279 -- See Note [CSE for bindings]
280 ok_to_subst = exprIsTrivial rhs'
281 && (not (isUnliftedType (idType out_id))
282 || exprOkForSpeculation rhs')
283 -- See Note [Corner case for case expressions]
285 tryForCSE :: CSEnv -> InExpr -> OutExpr
286 tryForCSE env expr
287 | exprIsTrivial expr' = expr' -- No point
288 | Just e <- lookupCSEnv env expr'' = mkTicks ticks e
289 | otherwise = expr'
290 -- The varToCoreExpr is needed if we have
291 -- case e of xco { ...case e of yco { ... } ... }
292 -- Then CSE will substitute yco -> xco;
293 -- but these are /coercion/ variables
294 where
295 expr' = cseExpr env expr
296 expr'' = stripTicksE tickishFloatable expr'
297 ticks = stripTicksT tickishFloatable expr'
298 -- We don't want to lose the source notes when a common sub
299 -- expression gets eliminated. Hence we push all (!) of them on
300 -- top of the replaced sub-expression. This is probably not too
301 -- useful in practice, but upholds our semantics.
303 cseExpr :: CSEnv -> InExpr -> OutExpr
304 cseExpr env (Type t) = Type (substTy (csEnvSubst env) t)
305 cseExpr env (Coercion c) = Coercion (substCo (csEnvSubst env) c)
306 cseExpr _ (Lit lit) = Lit lit
307 cseExpr env (Var v) = lookupSubst env v
308 cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a)
309 cseExpr env (Tick t e) = Tick t (cseExpr env e)
310 cseExpr env (Cast e co) = Cast (cseExpr env e) (substCo (csEnvSubst env) co)
311 cseExpr env (Lam b e) = let (env', b') = addBinder env b
312 in Lam b' (cseExpr env' e)
313 cseExpr env (Let bind e) = let (env', bind') = cseBind env bind
314 in Let bind' (cseExpr env' e)
315 cseExpr env (Case e bndr ty alts) = cseCase env e bndr ty alts
317 cseCase :: CSEnv -> InExpr -> InId -> InType -> [InAlt] -> OutExpr
318 cseCase env scrut bndr ty alts
319 = Case scrut' bndr3 ty (map cse_alt alts)
320 where
321 bndr1 = zapIdOccInfo bndr
322 -- Zapping the OccInfo is needed because the extendCSEnv
323 -- in cse_alt may mean that a dead case binder
324 -- becomes alive, and Lint rejects that
325 (env1, bndr2) = addBinder env bndr1
326 (alt_env, (bndr3, scrut')) = cseRhs env1 bndr bndr2 scrut
327 -- cseRhs: see Note [CSE for case expressions]
329 con_target :: OutExpr
330 con_target = lookupSubst alt_env bndr
332 arg_tys :: [OutType]
333 arg_tys = tyConAppArgs (idType bndr3)
335 cse_alt (DataAlt con, args, rhs)
336 | not (null args)
337 -- Don't try CSE if there are no args; it just increases the number
338 -- of live vars. E.g.
339 -- case x of { True -> ....True.... }
340 -- Don't replace True by x!
341 -- Hence the 'null args', which also deal with literals and DEFAULT
342 = (DataAlt con, args', tryForCSE new_env rhs)
343 where
344 (env', args') = addBinders alt_env args
345 new_env = extendCSEnv env' con_expr con_target
346 con_expr = mkAltExpr (DataAlt con) args' arg_tys
348 cse_alt (con, args, rhs)
349 = (con, args', tryForCSE env' rhs)
350 where
351 (env', args') = addBinders alt_env args
353 {-
354 ************************************************************************
355 * *
356 \section{The CSE envt}
357 * *
358 ************************************************************************
359 -}
361 type InExpr = CoreExpr -- Pre-cloning
362 type InId = Id
363 type InAlt = CoreAlt
364 type InType = Type
366 type OutExpr = CoreExpr -- Post-cloning
367 type OutId = Id
368 type OutType = Type
370 data CSEnv
371 = CS { cs_subst :: Subst -- Maps InBndrs to OutExprs
372 -- The substitution variables to
373 -- /trivial/ OutExprs, not arbitrary expressions
375 , cs_map :: CoreMap OutExpr -- The reverse mapping
376 -- Maps a OutExpr to a /trivial/ OutExpr
377 -- The key of cs_map is stripped of all Ticks
378 }
380 emptyCSEnv :: CSEnv
381 emptyCSEnv = CS { cs_map = emptyCoreMap, cs_subst = emptySubst }
383 lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr
384 lookupCSEnv (CS { cs_map = csmap }) expr
385 = lookupCoreMap csmap expr
387 extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv
388 extendCSEnv cse expr triv_expr
389 = cse { cs_map = extendCoreMap (cs_map cse) sexpr triv_expr }
390 where
391 sexpr = stripTicksE tickishFloatable expr
393 csEnvSubst :: CSEnv -> Subst
394 csEnvSubst = cs_subst
396 lookupSubst :: CSEnv -> Id -> OutExpr
397 lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst (text "CSE.lookupSubst") sub x
399 extendCSSubst :: CSEnv -> Id -> CoreExpr -> CSEnv
400 extendCSSubst cse x rhs = cse { cs_subst = extendSubst (cs_subst cse) x rhs }
402 addBinder :: CSEnv -> Var -> (CSEnv, Var)
403 addBinder cse v = (cse { cs_subst = sub' }, v')
404 where
405 (sub', v') = substBndr (cs_subst cse) v
407 addBinders :: CSEnv -> [Var] -> (CSEnv, [Var])
408 addBinders cse vs = (cse { cs_subst = sub' }, vs')
409 where
410 (sub', vs') = substBndrs (cs_subst cse) vs
412 addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
413 addRecBinders cse vs = (cse { cs_subst = sub' }, vs')
414 where
415 (sub', vs') = substRecBndrs (cs_subst cse) vs