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, (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
202 rhs' = cseExpr env rhs
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.
211 always_active = isAlwaysActive (idInlineActivation id')
212 -- See Note [CSE for INLINE and NOINLINE]
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'
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]
247 cseAlts :: CSEnv -> OutExpr -> InBndr -> InBndr -> [InAlt] -> [OutAlt]
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'
258 _ -> (bndr', extendCSEnv env scrut' bndr') -- See Note [Case binders 2]
259 -- map: scrut' -> bndr'
261 arg_tys = tyConAppArgs (idType bndr)
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
276 cse_alt (con, args, rhs)
277 = (con, args', tryForCSE env' rhs)
278 where
279 (env', args') = addBinders alt_env args
281 {-
282 ************************************************************************
283 * *
284 \section{The CSE envt}
285 * *
286 ************************************************************************
287 -}
289 type InExpr = CoreExpr -- Pre-cloning
290 type InBndr = CoreBndr
291 type InAlt = CoreAlt
293 type OutExpr = CoreExpr -- Post-cloning
294 type OutBndr = CoreBndr
295 type OutAlt = CoreAlt
297 data CSEnv = CS { cs_map :: CoreMap (OutExpr, Id) -- Key, value
298 , cs_subst :: Subst }
300 emptyCSEnv :: CSEnv
301 emptyCSEnv = CS { cs_map = emptyCoreMap, cs_subst = emptySubst }
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
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
314 csEnvSubst :: CSEnv -> Subst
315 csEnvSubst = cs_subst
317 lookupSubst :: CSEnv -> Id -> OutExpr
318 lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst (text "CSE.lookupSubst") sub x
320 extendCSSubst :: CSEnv -> Id -> Id -> CSEnv
321 extendCSSubst cse x y = cse { cs_subst = extendIdSubst (cs_subst cse) x (Var y) }
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
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
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