2 % (c) The AQUA Project, Glasgow University, 1993-1998
4 \section{Common subexpression}
11 #include "HsVersions.h"
13 import DynFlags ( DynFlag(..), DynFlags )
14 import Id ( Id, idType, idInlinePragma )
15 import CoreUtils ( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr, exprIsCheap )
16 import DataCon ( isUnboxedTupleCon )
17 import Type ( tyConAppArgs )
20 import CoreLint ( showPass, endPass )
22 import StaticFlags ( opt_PprStyle_Debug )
23 import BasicTypes ( isAlwaysActive )
24 import Util ( mapAccumL, lengthExceeds )
29 Simple common sub-expression
30 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
34 we build up a reverse mapping: C a b -> x1
36 and apply that to the rest of the program.
41 we replace the C a b with x1. But then we *dont* want to
42 add x1 -> y1 to the mapping. Rather, we want the reverse, y1 -> x1
43 so that a subsequent binding
45 will get transformed to C x1 b, and then to x2.
47 So we carry an extra var->var substitution which we apply *before* looking up in the
53 We have to be careful about shadowing.
55 f = \x -> let y = x+x in
59 Here we must *not* do CSE on the inner x+x! The simplifier used to guarantee no
60 shadowing, but it doesn't any more (it proved too hard), so we clone as we go.
61 We can simply add clones to the substitution already described.
63 However, we do NOT clone type variables. It's just too hard, because then we need
64 to run the substitution over types and IdInfo. No no no. Instead, we just throw
66 (In fact, I think the simplifier does guarantee no-shadowing for type variables.)
69 [Note: case binders 1]
70 ~~~~~~~~~~~~~~~~~~~~~~
73 f = \x -> case x of wild {
74 (a:as) -> case a of wild1 {
75 (p,q) -> ...(wild1:as)...
77 Here, (wild1:as) is morally the same as (a:as) and hence equal to wild.
78 But that's not quite obvious. In general we want to keep it as (wild1:as),
79 but for CSE purpose that's a bad idea.
81 So we add the binding (wild1 -> a) to the extra var->var mapping.
82 Notice this is exactly backwards to what the simplifier does, which is
83 to try to replaces uses of a with uses of wild1
85 [Note: case binders 2]
86 ~~~~~~~~~~~~~~~~~~~~~~
88 case (h x) of y -> ...(h x)...
90 We'd like to replace (h x) in the alternative, by y. But because of
91 the preceding [Note: case binders 1], we only want to add the mapping
92 scrutinee -> case binder
93 to the reverse CSE mapping if the scrutinee is a non-trivial expression.
94 (If the scrutinee is a simple variable we want to add the mapping
95 case binder -> scrutinee
98 [Note: unboxed tuple case binders]
99 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
101 case f x of t { (# a,b #) ->
106 We must not replace (f x) by t, because t is an unboxed-tuple binder.
107 Instead, we shoudl replace (f x) by (# a,b #). That is, the "reverse mapping" is
109 That is why the CSEMap has pairs of expressions.
111 Note [INLINE and NOINLINE]
112 ~~~~~~~~~~~~~~~~~~~~~~~~~~
113 We are careful to do no CSE inside functions that the user has marked as
114 INLINE or NOINLINE. In terms of Core, that means
116 a) we do not do CSE inside (Note InlineMe e)
118 b) we do not do CSE on the RHS of a binding b=e
119 unless b's InlinePragma is AlwaysActive
121 Here's why (examples from Roman Leshchinskiy). Consider
131 foo :: Int -> Int -> Int
135 {-# RULES "foo/no" foo no = id #-}
140 We do not expect the rule to fire. But if we do CSE, then we get
141 yes=no, and the rule does fire. Worse, whether we get yes=no or
142 no=yes depends on the order of the definitions.
144 In general, CSE should probably never touch things with INLINE pragmas
145 as this could lead to surprising results. Consider
151 bar = <rhs> -- Same rhs as foo
155 then foo will never be inlined (when it should be); but if it produces
157 bar will be inlined (when it should not be). Even if we remove INLINE foo,
158 we'd still like foo to be inlined if rhs is small. This won't happen
161 Not CSE-ing inside INLINE also solves an annoying bug in CSE. Consider
162 a worker/wrapper, in which the worker has turned into a single variable:
165 Now CSE may transoform to
167 But the WorkerInfo for f still says $wf, which is now dead! This won't
168 happen now that we don't look inside INLINEs (which wrappers are).
171 %************************************************************************
173 \section{Common subexpression}
175 %************************************************************************
178 cseProgram :: DynFlags -> [CoreBind] -> IO [CoreBind]
180 cseProgram dflags binds
182 showPass dflags "Common sub-expression";
183 let { binds' = cseBinds emptyCSEnv binds };
184 endPass dflags "Common sub-expression" Opt_D_dump_cse binds'
187 cseBinds :: CSEnv -> [CoreBind] -> [CoreBind]
189 cseBinds env (b:bs) = (b':bs')
191 (env1, b') = cseBind env b
192 bs' = cseBinds env1 bs
194 cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind)
195 cseBind env (NonRec b e) = let (env', (b',e')) = do_one env (b, e)
196 in (env', NonRec b' e')
197 cseBind env (Rec pairs) = let (env', pairs') = mapAccumL do_one env pairs
198 in (env', Rec pairs')
202 = case lookupCSEnv env rhs' of
203 Just (Var other_id) -> (extendSubst env' id other_id, (id', Var other_id))
204 Just other_expr -> (env', (id', other_expr))
205 Nothing -> (addCSEnvItem env' rhs' (Var id'), (id', rhs'))
207 (env', id') = addBinder env id
208 rhs' | isAlwaysActive (idInlinePragma id) = cseExpr env' rhs
210 -- See Note [INLINE and NOINLINE]
212 tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
213 tryForCSE env (Type t) = Type t
214 tryForCSE env expr = case lookupCSEnv env expr' of
215 Just smaller_expr -> smaller_expr
218 expr' = cseExpr env expr
220 cseExpr :: CSEnv -> CoreExpr -> CoreExpr
221 cseExpr env (Type t) = Type t
222 cseExpr env (Lit lit) = Lit lit
223 cseExpr env (Var v) = Var (lookupSubst env v)
224 cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a)
225 cseExpr evn (Note InlineMe e) = Note InlineMe e -- See Note [INLINE and NOINLINE]
226 cseExpr env (Note n e) = Note n (cseExpr env e)
227 cseExpr env (Cast e co) = Cast (cseExpr env e) co
228 cseExpr env (Lam b e) = let (env', b') = addBinder env b
229 in Lam b' (cseExpr env' e)
230 cseExpr env (Let bind e) = let (env', bind') = cseBind env bind
231 in Let bind' (cseExpr env' e)
232 cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr' ty (cseAlts env' scrut' bndr bndr' alts)
234 scrut' = tryForCSE env scrut
235 (env', bndr') = addBinder env bndr
238 cseAlts env scrut' bndr bndr' [(DataAlt con, args, rhs)]
239 | isUnboxedTupleCon con
240 -- Unboxed tuples are special because the case binder isn't
241 -- a real values. See [Note: unboxed tuple case binders]
242 = [(DataAlt con, args', tryForCSE new_env rhs)]
244 (env', args') = addBinders env args
245 new_env | exprIsCheap scrut' = env'
246 | otherwise = extendCSEnv env' scrut' tup_value
247 tup_value = mkAltExpr (DataAlt con) args' (tyConAppArgs (idType bndr))
249 cseAlts env scrut' bndr bndr' alts
252 (con_target, alt_env)
254 Var v' -> (v', extendSubst env bndr v') -- See [Note: case binder 1]
257 other -> (bndr', extendCSEnv env scrut' (Var bndr')) -- See [Note: case binder 2]
258 -- map: scrut' -> bndr'
260 arg_tys = tyConAppArgs (idType bndr)
262 cse_alt (DataAlt con, args, rhs)
264 -- Don't try CSE if there are no args; it just increases the number
265 -- of live vars. E.g.
266 -- case x of { True -> ....True.... }
267 -- Don't replace True by x!
268 -- Hence the 'null args', which also deal with literals and DEFAULT
269 = (DataAlt con, args', tryForCSE new_env rhs)
271 (env', args') = addBinders alt_env args
272 new_env = extendCSEnv env' (mkAltExpr (DataAlt con) args' arg_tys)
275 cse_alt (con, args, rhs)
276 = (con, args', tryForCSE env' rhs)
278 (env', args') = addBinders alt_env args
282 %************************************************************************
284 \section{The CSE envt}
286 %************************************************************************
289 data CSEnv = CS CSEMap InScopeSet (IdEnv Id)
290 -- Simple substitution
292 type CSEMap = UniqFM [(CoreExpr, CoreExpr)] -- This is the reverse mapping
293 -- It maps the hash-code of an expression e to list of (e,e') pairs
294 -- This means that it's good to replace e by e'
295 -- INVARIANT: The expr in the range has already been CSE'd
297 emptyCSEnv = CS emptyUFM emptyInScopeSet emptyVarEnv
299 lookupCSEnv :: CSEnv -> CoreExpr -> Maybe CoreExpr
300 lookupCSEnv (CS cs _ _) expr
301 = case lookupUFM cs (hashExpr expr) of
303 Just pairs -> lookup_list pairs expr
305 lookup_list :: [(CoreExpr,CoreExpr)] -> CoreExpr -> Maybe CoreExpr
306 lookup_list [] expr = Nothing
307 lookup_list ((e,e'):es) expr | cheapEqExpr e expr = Just e'
308 | otherwise = lookup_list es expr
310 addCSEnvItem env expr expr' | exprIsBig expr = env
311 | otherwise = extendCSEnv env expr expr'
312 -- We don't try to CSE big expressions, because they are expensive to compare
313 -- (and are unlikely to be the same anyway)
315 extendCSEnv (CS cs in_scope sub) expr expr'
316 = CS (addToUFM_C combine cs hash [(expr, expr')]) in_scope sub
320 = WARN( result `lengthExceeds` 4, short_msg $$ nest 2 long_msg ) result
323 short_msg = ptext SLIT("extendCSEnv: long list, length") <+> int (length result)
324 long_msg | opt_PprStyle_Debug = (text "hash code" <+> text (show hash)) $$ ppr result
327 lookupSubst (CS _ _ sub) x = case lookupVarEnv sub x of
331 extendSubst (CS cs in_scope sub) x y = CS cs in_scope (extendVarEnv sub x y)
333 addBinder :: CSEnv -> Id -> (CSEnv, Id)
334 addBinder env@(CS cs in_scope sub) v
335 | not (v `elemInScopeSet` in_scope) = (CS cs (extendInScopeSet in_scope v) sub, v)
336 | isId v = (CS cs (extendInScopeSet in_scope v') (extendVarEnv sub v v'), v')
337 | otherwise = WARN( True, ppr v )
338 (CS emptyUFM in_scope sub, v)
339 -- This last case is the unusual situation where we have shadowing of
340 -- a type variable; we have to discard the CSE mapping
341 -- See "IMPORTANT NOTE" at the top
343 v' = uniqAway in_scope v
345 addBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
346 addBinders env vs = mapAccumL addBinder env vs