2 % (c) The AQUA Project, Glasgow University, 1993-1998
4 \section{Common subexpression}
11 #include "HsVersions.h"
13 import Id ( Id, idType, idInlineActivation, zapIdOccInfo )
14 import CoreUtils ( hashExpr, eqExpr, exprIsBig, mkAltExpr, exprIsCheap )
15 import DataCon ( isUnboxedTupleCon )
16 import Type ( tyConAppArgs )
20 import StaticFlags ( opt_PprStyle_Debug )
21 import BasicTypes ( isAlwaysActive )
22 import Util ( lengthExceeds )
30 Simple common sub-expression
31 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
35 we build up a reverse mapping: C a b -> x1
37 and apply that to the rest of the program.
42 we replace the C a b with x1. But then we *dont* want to
43 add x1 -> y1 to the mapping. Rather, we want the reverse, y1 -> x1
44 so that a subsequent binding
46 will get transformed to C x1 b, and then to x2.
48 So we carry an extra var->var substitution which we apply *before* looking up in the
54 We have to be careful about shadowing.
56 f = \x -> let y = x+x in
60 Here we must *not* do CSE on the inner x+x! The simplifier used to guarantee no
61 shadowing, but it doesn't any more (it proved too hard), so we clone as we go.
62 We can simply add clones to the substitution already described.
64 However, we do NOT clone type variables. It's just too hard, because then we need
65 to run the substitution over types and IdInfo. No no no. Instead, we just throw
67 (In fact, I think the simplifier does guarantee no-shadowing for type variables.)
71 ~~~~~~~~~~~~~~~~~~~~~~
74 f = \x -> case x of wild {
75 (a:as) -> case a of wild1 {
76 (p,q) -> ...(wild1:as)...
78 Here, (wild1:as) is morally the same as (a:as) and hence equal to wild.
79 But that's not quite obvious. In general we want to keep it as (wild1:as),
80 but for CSE purpose that's a bad idea.
82 So we add the binding (wild1 -> a) to the extra var->var mapping.
83 Notice this is exactly backwards to what the simplifier does, which is
84 to try to replaces uses of 'a' with uses of 'wild1'
87 ~~~~~~~~~~~~~~~~~~~~~~
89 case (h x) of y -> ...(h x)...
91 We'd like to replace (h x) in the alternative, by y. But because of
92 the preceding [Note: case binders 1], we only want to add the mapping
93 scrutinee -> case binder
94 to the reverse CSE mapping if the scrutinee is a non-trivial expression.
95 (If the scrutinee is a simple variable we want to add the mapping
96 case binder -> scrutinee
99 Note [Unboxed tuple case binders]
100 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
102 case f x of t { (# a,b #) ->
107 We must not replace (f x) by t, because t is an unboxed-tuple binder.
108 Instead, we shoudl replace (f x) by (# a,b #). That is, the "reverse mapping" is
110 That is why the CSEMap has pairs of expressions.
112 Note [CSE for INLINE and NOINLINE]
113 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
114 We are careful to do no CSE inside functions that the user has marked as
115 INLINE or NOINLINE. In terms of Core, that means
117 a) we do not do CSE inside an InlineRule
119 b) we do not do CSE on the RHS of a binding b=e
120 unless b's InlinePragma is AlwaysActive
122 Here's why (examples from Roman Leshchinskiy). Consider
132 foo :: Int -> Int -> Int
136 {-# RULES "foo/no" foo no = id #-}
141 We do not expect the rule to fire. But if we do CSE, then we get
142 yes=no, and the rule does fire. Worse, whether we get yes=no or
143 no=yes depends on the order of the definitions.
145 In general, CSE should probably never touch things with INLINE pragmas
146 as this could lead to surprising results. Consider
152 bar = <rhs> -- Same rhs as foo
156 then foo will never be inlined (when it should be); but if it produces
158 bar will be inlined (when it should not be). Even if we remove INLINE foo,
159 we'd still like foo to be inlined if rhs is small. This won't happen
162 Not CSE-ing inside INLINE also solves an annoying bug in CSE. Consider
163 a worker/wrapper, in which the worker has turned into a single variable:
166 Now CSE may transform to
168 But the WorkerInfo for f still says $wf, which is now dead! This won't
169 happen now that we don't look inside INLINEs (which wrappers are).
172 %************************************************************************
174 \section{Common subexpression}
176 %************************************************************************
179 cseProgram :: [CoreBind] -> [CoreBind]
180 cseProgram binds = cseBinds emptyCSEnv binds
182 cseBinds :: CSEnv -> [CoreBind] -> [CoreBind]
184 cseBinds env (b:bs) = (b':bs')
186 (env1, b') = cseBind env b
187 bs' = cseBinds env1 bs
189 cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind)
190 cseBind env (NonRec b e) = let (env', (b',e')) = do_one env (b, e)
191 in (env', NonRec b' e')
192 cseBind env (Rec pairs) = let (env', pairs') = mapAccumL do_one env pairs
193 in (env', Rec pairs')
196 do_one :: CSEnv -> (Id, CoreExpr) -> (CSEnv, (Id, CoreExpr))
198 = case lookupCSEnv env rhs' of
199 Just (Var other_id) -> (extendSubst env' id other_id, (id', Var other_id))
200 Just other_expr -> (env', (id', other_expr))
201 Nothing -> (addCSEnvItem env' rhs' (Var id'), (id', rhs'))
203 (env', id') = addBinder env id
204 rhs' | isAlwaysActive (idInlineActivation id) = cseExpr env' rhs
206 -- See Note [CSE for INLINE and NOINLINE]
208 tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
209 tryForCSE _ (Type t) = Type t
210 tryForCSE _ (Coercion c) = Coercion c
211 tryForCSE env expr = case lookupCSEnv env expr' of
212 Just smaller_expr -> smaller_expr
215 expr' = cseExpr env expr
217 cseExpr :: CSEnv -> CoreExpr -> CoreExpr
218 cseExpr _ (Type t) = Type t
219 cseExpr _ (Coercion co) = Coercion co
220 cseExpr _ (Lit lit) = Lit lit
221 cseExpr env (Var v) = Var (lookupSubst env v)
222 cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a)
223 cseExpr env (Note n e) = Note n (cseExpr env e)
224 cseExpr env (Cast e co) = Cast (cseExpr env e) co
225 cseExpr env (Lam b e) = let (env', b') = addBinder env b
226 in Lam b' (cseExpr env' e)
227 cseExpr env (Let bind e) = let (env', bind') = cseBind env bind
228 in Let bind' (cseExpr env' e)
229 cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr'' ty (cseAlts env' scrut' bndr bndr'' alts)
231 scrut' = tryForCSE env scrut
232 (env', bndr') = addBinder env bndr
233 bndr'' = zapIdOccInfo bndr'
234 -- The swizzling from Note [Case binders 2] may
235 -- cause a dead case binder to be alive, so we
236 -- play safe here and bring them all to life
238 cseAlts :: CSEnv -> CoreExpr -> CoreBndr -> CoreBndr -> [CoreAlt] -> [CoreAlt]
240 cseAlts env scrut' bndr _bndr' [(DataAlt con, args, rhs)]
241 | isUnboxedTupleCon con
242 -- Unboxed tuples are special because the case binder isn't
243 -- a real value. See Note [Unboxed tuple case binders]
244 = [(DataAlt con, args'', tryForCSE new_env rhs)]
246 (env', args') = addBinders env args
247 args'' = map zapIdOccInfo args' -- They should all be ids
248 -- Same motivation for zapping as [Case binders 2] only this time
249 -- it's Note [Unboxed tuple case binders]
250 new_env | exprIsCheap scrut' = env'
251 | otherwise = extendCSEnv env' scrut' tup_value
252 tup_value = mkAltExpr (DataAlt con) args'' (tyConAppArgs (idType bndr))
254 cseAlts env scrut' bndr bndr' alts
257 (con_target, alt_env)
259 Var v' -> (v', extendSubst env bndr v') -- See Note [Case binders 1]
262 _ -> (bndr', extendCSEnv env scrut' (Var bndr')) -- See Note [Case binders 2]
263 -- map: scrut' -> bndr'
265 arg_tys = tyConAppArgs (idType bndr)
267 cse_alt (DataAlt con, args, rhs)
269 -- Don't try CSE if there are no args; it just increases the number
270 -- of live vars. E.g.
271 -- case x of { True -> ....True.... }
272 -- Don't replace True by x!
273 -- Hence the 'null args', which also deal with literals and DEFAULT
274 = (DataAlt con, args', tryForCSE new_env rhs)
276 (env', args') = addBinders alt_env args
277 new_env = extendCSEnv env' (mkAltExpr (DataAlt con) args' arg_tys)
280 cse_alt (con, args, rhs)
281 = (con, args', tryForCSE env' rhs)
283 (env', args') = addBinders alt_env args
287 %************************************************************************
289 \section{The CSE envt}
291 %************************************************************************
294 data CSEnv = CS CSEMap InScopeSet (IdEnv Id)
295 -- Simple substitution
297 type CSEMap = UniqFM [(CoreExpr, CoreExpr)] -- This is the reverse mapping
298 -- It maps the hash-code of an expression e to list of (e,e') pairs
299 -- This means that it's good to replace e by e'
300 -- INVARIANT: The expr in the range has already been CSE'd
303 emptyCSEnv = CS emptyUFM emptyInScopeSet emptyVarEnv
305 lookupCSEnv :: CSEnv -> CoreExpr -> Maybe CoreExpr
306 lookupCSEnv (CS cs in_scope _) expr
307 = case lookupUFM cs (hashExpr expr) of
309 Just pairs -> lookup_list pairs
311 -- In this lookup we use full expression equality
312 -- Reason: when expressions differ we generally find out quickly
313 -- but I found that cheapEqExpr was saying (\x.x) /= (\y.y),
314 -- and this kind of thing happened in real programs
315 lookup_list :: [(CoreExpr,CoreExpr)] -> Maybe CoreExpr
316 lookup_list [] = Nothing
317 lookup_list ((e,e'):es) | eqExpr in_scope e expr = Just e'
318 | otherwise = lookup_list es
320 addCSEnvItem :: CSEnv -> CoreExpr -> CoreExpr -> CSEnv
321 addCSEnvItem env expr expr' | exprIsBig expr = env
322 | otherwise = extendCSEnv env expr expr'
323 -- We don't try to CSE big expressions, because they are expensive to compare
324 -- (and are unlikely to be the same anyway)
326 extendCSEnv :: CSEnv -> CoreExpr -> CoreExpr -> CSEnv
327 extendCSEnv (CS cs in_scope sub) expr expr'
328 = CS (addToUFM_C combine cs hash [(expr, expr')]) in_scope sub
332 = WARN( result `lengthExceeds` 4, short_msg $$ nest 2 long_msg ) result
335 short_msg = ptext (sLit "extendCSEnv: long list, length") <+> int (length result)
336 long_msg | opt_PprStyle_Debug = (text "hash code" <+> text (show hash)) $$ ppr result
339 lookupSubst :: CSEnv -> Id -> Id
340 lookupSubst (CS _ _ sub) x = case lookupVarEnv sub x of
344 extendSubst :: CSEnv -> Id -> Id -> CSEnv
345 extendSubst (CS cs in_scope sub) x y = CS cs in_scope (extendVarEnv sub x y)
347 addBinder :: CSEnv -> Id -> (CSEnv, Id)
348 addBinder (CS cs in_scope sub) v
349 | not (v `elemInScopeSet` in_scope) = (CS cs (extendInScopeSet in_scope v) sub, v)
350 | isId v = (CS cs (extendInScopeSet in_scope v') (extendVarEnv sub v v'), v')
351 | otherwise = WARN( True, ppr v )
352 (CS emptyUFM in_scope sub, v)
353 -- This last case is the unusual situation where we have shadowing of
354 -- a type variable; we have to discard the CSE mapping
355 -- See Note [Shadowing]
357 v' = uniqAway in_scope v
359 addBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
360 addBinders env vs = mapAccumL addBinder env vs