b4e6e1499164c52f15133b13b086fd294ce8e51b
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, 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
25 import Data.List
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.
62 Note [Case binders 1]
63 ~~~~~~~~~~~~~~~~~~~~~~
64 Consider
66 f = \x -> case x of wild {
67 (a:as) -> case a of wild1 {
68 (p,q) -> ...(wild1:as)...
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.
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'
78 Note [Case binders 2]
79 ~~~~~~~~~~~~~~~~~~~~~~
80 Consider
81 case (h x) of y -> ...(h x)...
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
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
97 yes :: Int {-# NOINLINE yes #-}
98 yes = undefined
100 no :: Int {-# NOINLINE no #-}
101 no = undefined
103 foo :: Int -> Int -> Int {-# NOINLINE foo #-}
104 foo m n = n
106 {-# RULES "foo/no" foo no = id #-}
108 bar :: Int -> Int
109 bar = foo yes
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).
117 But we do need to take care. Consider
119 {-# NOINLINE bar #-}
120 bar = <rhs> -- Same rhs as foo
122 foo = <rhs>
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:
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>.
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.
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.
149 ************************************************************************
150 * *
151 \section{Common subexpression}
152 * *
153 ************************************************************************
154 -}
156 cseProgram :: CoreProgram -> CoreProgram
157 cseProgram binds = snd (mapAccumL cseBind emptyCSEnv binds)
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)
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)
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
204 rhs' = cseExpr env rhs
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.
213 always_active = isAlwaysActive (idInlineActivation id')
214 -- See Note [CSE for INLINE and NOINLINE]
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'
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]
249 cseAlts :: CSEnv -> OutExpr -> InBndr -> InBndr -> [InAlt] -> [OutAlt]
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'
260 _ -> (bndr', extendCSEnv env scrut' bndr') -- See Note [Case binders 2]
261 -- map: scrut' -> bndr'
263 arg_tys = tyConAppArgs (idType bndr)
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
278 cse_alt (con, args, rhs)
279 = (con, args', tryForCSE env' rhs)
280 where
281 (env', args') = addBinders alt_env args
283 {-
284 ************************************************************************
285 * *
286 \section{The CSE envt}
287 * *
288 ************************************************************************
289 -}
291 type InExpr = CoreExpr -- Pre-cloning
292 type InBndr = CoreBndr
293 type InAlt = CoreAlt
295 type OutExpr = CoreExpr -- Post-cloning
296 type OutBndr = CoreBndr
297 type OutAlt = CoreAlt
299 data CSEnv = CS { cs_map :: CoreMap (OutExpr, Id) -- Key, value
300 , cs_subst :: Subst }
302 emptyCSEnv :: CSEnv
303 emptyCSEnv = CS { cs_map = emptyCoreMap, cs_subst = emptySubst }
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
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
316 csEnvSubst :: CSEnv -> Subst
317 csEnvSubst = cs_subst
319 lookupSubst :: CSEnv -> Id -> OutExpr
320 lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst (text "CSE.lookupSubst") sub x
322 extendCSSubst :: CSEnv -> Id -> CoreExpr -> CSEnv
323 extendCSSubst cse x rhs = cse { cs_subst = extendSubst (cs_subst cse) x rhs }
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
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
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