b4e6e1499164c52f15133b13b086fd294ce8e51b
[ghc.git] / compiler / simplCore / CSE.hs
1 {-
2 (c) The AQUA Project, Glasgow University, 1993-1998
3
4 \section{Common subexpression}
5 -}
6
7 {-# LANGUAGE CPP #-}
8
9 module CSE (cseProgram) where
10
11 #include "HsVersions.h"
12
13 import CoreSubst
14 import Var ( Var )
15 import Id ( Id, idType, idInlineActivation, zapIdOccInfo, zapIdUsageInfo )
16 import CoreUtils ( mkAltExpr
17 , exprIsTrivial
18 , stripTicksE, stripTicksT, stripTicksTopE, mkTick, mkTicks )
19 import Type ( tyConAppArgs )
20 import CoreSyn
21 import Outputable
22 import BasicTypes ( isAlwaysActive )
23 import TrieMap
24
25 import Data.List
26
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.
36
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.
45
46 So we carry an extra var->var substitution which we apply *before* looking up in the
47 reverse mapping.
48
49
50 Note [Shadowing]
51 ~~~~~~~~~~~~~~~~
52 We have to be careful about shadowing.
53 For example, consider
54 f = \x -> let y = x+x in
55 h = \x -> x+x
56 in ...
57
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.
61
62 Note [Case binders 1]
63 ~~~~~~~~~~~~~~~~~~~~~~
64 Consider
65
66 f = \x -> case x of wild {
67 (a:as) -> case a of wild1 {
68 (p,q) -> ...(wild1:as)...
69
70 Here, (wild1:as) is morally the same as (a:as) and hence equal to wild.
71 But that's not quite obvious. In general we want to keep it as (wild1:as),
72 but for CSE purpose that's a bad idea.
73
74 So we add the binding (wild1 -> a) to the extra var->var mapping.
75 Notice this is exactly backwards to what the simplifier does, which is
76 to try to replaces uses of 'a' with uses of 'wild1'
77
78 Note [Case binders 2]
79 ~~~~~~~~~~~~~~~~~~~~~~
80 Consider
81 case (h x) of y -> ...(h x)...
82
83 We'd like to replace (h x) in the alternative, by y. But because of
84 the preceding [Note: case binders 1], we only want to add the mapping
85 scrutinee -> case binder
86 to the reverse CSE mapping if the scrutinee is a non-trivial expression.
87 (If the scrutinee is a simple variable we want to add the mapping
88 case binder -> scrutinee
89 to the substitution
90
91 Note [CSE for INLINE and NOINLINE]
92 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
93 There are some subtle interactions of CSE with functions that the user
94 has marked as INLINE or NOINLINE. (Examples from Roman Leshchinskiy.)
95 Consider
96
97 yes :: Int {-# NOINLINE yes #-}
98 yes = undefined
99
100 no :: Int {-# NOINLINE no #-}
101 no = undefined
102
103 foo :: Int -> Int -> Int {-# NOINLINE foo #-}
104 foo m n = n
105
106 {-# RULES "foo/no" foo no = id #-}
107
108 bar :: Int -> Int
109 bar = foo yes
110
111 We do not expect the rule to fire. But if we do CSE, then we risk
112 getting yes=no, and the rule does fire. Actually, it won't because
113 NOINLINE means that 'yes' will never be inlined, not even if we have
114 yes=no. So that's fine (now; perhaps in the olden days, yes=no would
115 have substituted even if 'yes' was NOINLINE).
116
117 But we do need to take care. Consider
118
119 {-# NOINLINE bar #-}
120 bar = <rhs> -- Same rhs as foo
121
122 foo = <rhs>
123
124 If CSE produces
125 foo = bar
126 then foo will never be inlined to <rhs> (when it should be, if <rhs>
127 is small). The conclusion here is this:
128
129 We should not add
130 <rhs> :-> bar
131 to the CSEnv if 'bar' has any constraints on when it can inline;
132 that is, if its 'activation' not always active. Otherwise we
133 might replace <rhs> by 'bar', and then later be unable to see that it
134 really was <rhs>.
135
136 Note that we do not (currently) do CSE on the unfolding stored inside
137 an Id, even if is a 'stable' unfolding. That means that when an
138 unfolding happens, it is always faithful to what the stable unfolding
139 originally was.
140
141
142 Note [CSE for case expressions]
143 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
144 Consider
145 case f x of y { pat -> ...let y = f x in ... }
146 Then we can CSE the inner (f x) to y. In fact 'case' is like a strict
147 let-binding, and we can use cseRhs for dealing with the scrutinee.
148
149 ************************************************************************
150 * *
151 \section{Common subexpression}
152 * *
153 ************************************************************************
154 -}
155
156 cseProgram :: CoreProgram -> CoreProgram
157 cseProgram binds = snd (mapAccumL cseBind emptyCSEnv binds)
158
159 cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind)
160 cseBind env (NonRec b e)
161 = (env2, NonRec b'' e')
162 where
163 (env1, b') = addBinder env b
164 (env2, (b'', e')) = cseRhs env1 (b',e)
165
166 cseBind env (Rec pairs)
167 = (env2, Rec pairs')
168 where
169 (bs,es) = unzip pairs
170 (env1, bs') = addRecBinders env bs
171 (env2, pairs') = mapAccumL cseRhs env1 (bs' `zip` es)
172
173 cseRhs :: CSEnv -> (OutBndr, InExpr) -> (CSEnv, (OutBndr, OutExpr))
174 cseRhs env (id',rhs)
175 = case lookupCSEnv env rhs'' of
176 Nothing
177 | always_active -> (extendCSEnv env rhs' id', (zapped_id, rhs'))
178 | otherwise -> (env, (id', rhs'))
179 Just id
180 | always_active -> (extendCSSubst env id' id_expr, (id', mkTicks ticks id_expr))
181 | otherwise -> (env, (id', mkTicks ticks id_expr))
182 where
183 id_expr = varToCoreExpr id -- Could be a CoVar
184 -- In the Just case, we have
185 -- x = rhs
186 -- ...
187 -- x' = rhs
188 -- We are replacing the second binding with x'=x
189 -- and so must record that in the substitution so
190 -- that subsequent uses of x' are replaced with x,
191 -- See Trac #5996
192 where
193 zapped_id = zapIdUsageInfo id'
194 -- Putting the Id into the environment makes it possible that
195 -- it'll become shared more than it is now, which would
196 -- invalidate (the usage part of) its demand info. This caused
197 -- Trac #100218.
198 -- Easiest thing is to zap the usage info; subsequently
199 -- performing late demand-analysis will restore it. Don't zap
200 -- the strictness info; it's not necessary to do so, and losing
201 -- it is bad for performance if you don't do late demand
202 -- analysis
203
204 rhs' = cseExpr env rhs
205
206 ticks = stripTicksT tickishFloatable rhs'
207 rhs'' = stripTicksE tickishFloatable rhs'
208 -- We don't want to lose the source notes when a common sub
209 -- expression gets eliminated. Hence we push all (!) of them on
210 -- top of the replaced sub-expression. This is probably not too
211 -- useful in practice, but upholds our semantics.
212
213 always_active = isAlwaysActive (idInlineActivation id')
214 -- See Note [CSE for INLINE and NOINLINE]
215
216 tryForCSE :: CSEnv -> InExpr -> OutExpr
217 tryForCSE env expr
218 | exprIsTrivial expr' = expr' -- No point
219 | Just smaller <- lookupCSEnv env expr'' = foldr mkTick (Var smaller) ticks
220 | otherwise = expr'
221 where
222 expr' = cseExpr env expr
223 expr'' = stripTicksE tickishFloatable expr'
224 ticks = stripTicksT tickishFloatable expr'
225
226 cseExpr :: CSEnv -> InExpr -> OutExpr
227 cseExpr env (Type t) = Type (substTy (csEnvSubst env) t)
228 cseExpr env (Coercion c) = Coercion (substCo (csEnvSubst env) c)
229 cseExpr _ (Lit lit) = Lit lit
230 cseExpr env (Var v) = lookupSubst env v
231 cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a)
232 cseExpr env (Tick t e) = Tick t (cseExpr env e)
233 cseExpr env (Cast e co) = Cast (cseExpr env e) (substCo (csEnvSubst env) co)
234 cseExpr env (Lam b e) = let (env', b') = addBinder env b
235 in Lam b' (cseExpr env' e)
236 cseExpr env (Let bind e) = let (env', bind') = cseBind env bind
237 in Let bind' (cseExpr env' e)
238 cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr''' ty alts'
239 where
240 alts' = cseAlts env2 scrut' bndr bndr'' alts
241 (env1, bndr') = addBinder env bndr
242 bndr'' = zapIdOccInfo bndr'
243 -- The swizzling from Note [Case binders 2] may
244 -- cause a dead case binder to be alive, so we
245 -- play safe here and bring them all to life
246 (env2, (bndr''', scrut')) = cseRhs env1 (bndr'', scrut)
247 -- Note [CSE for case expressions]
248
249 cseAlts :: CSEnv -> OutExpr -> InBndr -> InBndr -> [InAlt] -> [OutAlt]
250
251 cseAlts env scrut' bndr bndr' alts
252 = map cse_alt alts
253 where
254 scrut'' = stripTicksTopE tickishFloatable scrut'
255 (con_target, alt_env)
256 = case scrut'' of
257 Var v' -> (v', extendCSSubst env bndr scrut'') -- See Note [Case binders 1]
258 -- map: bndr -> v'
259
260 _ -> (bndr', extendCSEnv env scrut' bndr') -- See Note [Case binders 2]
261 -- map: scrut' -> bndr'
262
263 arg_tys = tyConAppArgs (idType bndr)
264
265 cse_alt (DataAlt con, args, rhs)
266 | not (null args)
267 -- Don't try CSE if there are no args; it just increases the number
268 -- of live vars. E.g.
269 -- case x of { True -> ....True.... }
270 -- Don't replace True by x!
271 -- Hence the 'null args', which also deal with literals and DEFAULT
272 = (DataAlt con, args', tryForCSE new_env rhs)
273 where
274 (env', args') = addBinders alt_env args
275 new_env = extendCSEnv env' con_expr con_target
276 con_expr = mkAltExpr (DataAlt con) args' arg_tys
277
278 cse_alt (con, args, rhs)
279 = (con, args', tryForCSE env' rhs)
280 where
281 (env', args') = addBinders alt_env args
282
283 {-
284 ************************************************************************
285 * *
286 \section{The CSE envt}
287 * *
288 ************************************************************************
289 -}
290
291 type InExpr = CoreExpr -- Pre-cloning
292 type InBndr = CoreBndr
293 type InAlt = CoreAlt
294
295 type OutExpr = CoreExpr -- Post-cloning
296 type OutBndr = CoreBndr
297 type OutAlt = CoreAlt
298
299 data CSEnv = CS { cs_map :: CoreMap (OutExpr, Id) -- Key, value
300 , cs_subst :: Subst }
301
302 emptyCSEnv :: CSEnv
303 emptyCSEnv = CS { cs_map = emptyCoreMap, cs_subst = emptySubst }
304
305 lookupCSEnv :: CSEnv -> OutExpr -> Maybe Id
306 lookupCSEnv (CS { cs_map = csmap }) expr
307 = case lookupCoreMap csmap expr of
308 Just (_,e) -> Just e
309 Nothing -> Nothing
310
311 extendCSEnv :: CSEnv -> OutExpr -> Id -> CSEnv
312 extendCSEnv cse expr id
313 = cse { cs_map = extendCoreMap (cs_map cse) sexpr (sexpr,id) }
314 where sexpr = stripTicksE tickishFloatable expr
315
316 csEnvSubst :: CSEnv -> Subst
317 csEnvSubst = cs_subst
318
319 lookupSubst :: CSEnv -> Id -> OutExpr
320 lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst (text "CSE.lookupSubst") sub x
321
322 extendCSSubst :: CSEnv -> Id -> CoreExpr -> CSEnv
323 extendCSSubst cse x rhs = cse { cs_subst = extendSubst (cs_subst cse) x rhs }
324
325 addBinder :: CSEnv -> Var -> (CSEnv, Var)
326 addBinder cse v = (cse { cs_subst = sub' }, v')
327 where
328 (sub', v') = substBndr (cs_subst cse) v
329
330 addBinders :: CSEnv -> [Var] -> (CSEnv, [Var])
331 addBinders cse vs = (cse { cs_subst = sub' }, vs')
332 where
333 (sub', vs') = substBndrs (cs_subst cse) vs
334
335 addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
336 addRecBinders cse vs = (cse { cs_subst = sub' }, vs')
337 where
338 (sub', vs') = substRecBndrs (cs_subst cse) vs