Filter out BuiltinRules in occurrence analysis
[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, (id', mkTicks ticks $ varToCoreExpr id))
181 | otherwise -> (env, (id', mkTicks ticks $ varToCoreExpr id))
182 -- In the Just case, we have
183 -- x = rhs
184 -- ...
185 -- x' = rhs
186 -- We are replacing the second binding with x'=x
187 -- and so must record that in the substitution so
188 -- that subsequent uses of x' are replaced with x,
189 -- See Trac #5996
190 where
191 zapped_id = zapIdUsageInfo id'
192 -- Putting the Id into the environment makes it possible that
193 -- it'll become shared more than it is now, which would
194 -- invalidate (the usage part of) its demand info. This caused
195 -- Trac #100218.
196 -- Easiest thing is to zap the usage info; subsequently
197 -- performing late demand-analysis will restore it. Don't zap
198 -- the strictness info; it's not necessary to do so, and losing
199 -- it is bad for performance if you don't do late demand
200 -- analysis
201
202 rhs' = cseExpr env rhs
203
204 ticks = stripTicksT tickishFloatable rhs'
205 rhs'' = stripTicksE tickishFloatable rhs'
206 -- We don't want to lose the source notes when a common sub
207 -- expression gets eliminated. Hence we push all (!) of them on
208 -- top of the replaced sub-expression. This is probably not too
209 -- useful in practice, but upholds our semantics.
210
211 always_active = isAlwaysActive (idInlineActivation id')
212 -- See Note [CSE for INLINE and NOINLINE]
213
214 tryForCSE :: CSEnv -> InExpr -> OutExpr
215 tryForCSE env expr
216 | exprIsTrivial expr' = expr' -- No point
217 | Just smaller <- lookupCSEnv env expr'' = foldr mkTick (Var smaller) ticks
218 | otherwise = expr'
219 where
220 expr' = cseExpr env expr
221 expr'' = stripTicksE tickishFloatable expr'
222 ticks = stripTicksT tickishFloatable expr'
223
224 cseExpr :: CSEnv -> InExpr -> OutExpr
225 cseExpr env (Type t) = Type (substTy (csEnvSubst env) t)
226 cseExpr env (Coercion c) = Coercion (substCo (csEnvSubst env) c)
227 cseExpr _ (Lit lit) = Lit lit
228 cseExpr env (Var v) = lookupSubst env v
229 cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a)
230 cseExpr env (Tick t e) = Tick t (cseExpr env e)
231 cseExpr env (Cast e co) = Cast (cseExpr env e) (substCo (csEnvSubst env) co)
232 cseExpr env (Lam b e) = let (env', b') = addBinder env b
233 in Lam b' (cseExpr env' e)
234 cseExpr env (Let bind e) = let (env', bind') = cseBind env bind
235 in Let bind' (cseExpr env' e)
236 cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr''' ty alts'
237 where
238 alts' = cseAlts env2 scrut' bndr bndr'' alts
239 (env1, bndr') = addBinder env bndr
240 bndr'' = zapIdOccInfo bndr'
241 -- The swizzling from Note [Case binders 2] may
242 -- cause a dead case binder to be alive, so we
243 -- play safe here and bring them all to life
244 (env2, (bndr''', scrut')) = cseRhs env1 (bndr'', scrut)
245 -- Note [CSE for case expressions]
246
247 cseAlts :: CSEnv -> OutExpr -> InBndr -> InBndr -> [InAlt] -> [OutAlt]
248
249 cseAlts env scrut' bndr bndr' alts
250 = map cse_alt alts
251 where
252 scrut'' = stripTicksTopE tickishFloatable scrut'
253 (con_target, alt_env)
254 = case scrut'' of
255 Var v' -> (v', extendCSSubst env bndr v') -- See Note [Case binders 1]
256 -- map: bndr -> v'
257
258 _ -> (bndr', extendCSEnv env scrut' bndr') -- See Note [Case binders 2]
259 -- map: scrut' -> bndr'
260
261 arg_tys = tyConAppArgs (idType bndr)
262
263 cse_alt (DataAlt con, args, rhs)
264 | not (null args)
265 -- Don't try CSE if there are no args; it just increases the number
266 -- of live vars. E.g.
267 -- case x of { True -> ....True.... }
268 -- Don't replace True by x!
269 -- Hence the 'null args', which also deal with literals and DEFAULT
270 = (DataAlt con, args', tryForCSE new_env rhs)
271 where
272 (env', args') = addBinders alt_env args
273 new_env = extendCSEnv env' con_expr con_target
274 con_expr = mkAltExpr (DataAlt con) args' arg_tys
275
276 cse_alt (con, args, rhs)
277 = (con, args', tryForCSE env' rhs)
278 where
279 (env', args') = addBinders alt_env args
280
281 {-
282 ************************************************************************
283 * *
284 \section{The CSE envt}
285 * *
286 ************************************************************************
287 -}
288
289 type InExpr = CoreExpr -- Pre-cloning
290 type InBndr = CoreBndr
291 type InAlt = CoreAlt
292
293 type OutExpr = CoreExpr -- Post-cloning
294 type OutBndr = CoreBndr
295 type OutAlt = CoreAlt
296
297 data CSEnv = CS { cs_map :: CoreMap (OutExpr, Id) -- Key, value
298 , cs_subst :: Subst }
299
300 emptyCSEnv :: CSEnv
301 emptyCSEnv = CS { cs_map = emptyCoreMap, cs_subst = emptySubst }
302
303 lookupCSEnv :: CSEnv -> OutExpr -> Maybe Id
304 lookupCSEnv (CS { cs_map = csmap }) expr
305 = case lookupCoreMap csmap expr of
306 Just (_,e) -> Just e
307 Nothing -> Nothing
308
309 extendCSEnv :: CSEnv -> OutExpr -> Id -> CSEnv
310 extendCSEnv cse expr id
311 = cse { cs_map = extendCoreMap (cs_map cse) sexpr (sexpr,id) }
312 where sexpr = stripTicksE tickishFloatable expr
313
314 csEnvSubst :: CSEnv -> Subst
315 csEnvSubst = cs_subst
316
317 lookupSubst :: CSEnv -> Id -> OutExpr
318 lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst (text "CSE.lookupSubst") sub x
319
320 extendCSSubst :: CSEnv -> Id -> Id -> CSEnv
321 extendCSSubst cse x y = cse { cs_subst = extendIdSubst (cs_subst cse) x (Var y) }
322
323 addBinder :: CSEnv -> Var -> (CSEnv, Var)
324 addBinder cse v = (cse { cs_subst = sub' }, v')
325 where
326 (sub', v') = substBndr (cs_subst cse) v
327
328 addBinders :: CSEnv -> [Var] -> (CSEnv, [Var])
329 addBinders cse vs = (cse { cs_subst = sub' }, vs')
330 where
331 (sub', vs') = substBndrs (cs_subst cse) vs
332
333 addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
334 addRecBinders cse vs = (cse { cs_subst = sub' }, vs')
335 where
336 (sub', vs') = substRecBndrs (cs_subst cse) vs