2 % (c) The AQUA Project, Glasgow University, 1993-1998
4 \section{Common subexpression}
8 -- The above warning supression flag is a temporary kludge.
9 -- While working on this module you are encouraged to remove it and fix
10 -- any warnings in the module. See
11 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
18 #include "HsVersions.h"
20 import DynFlags ( DynFlag(..), DynFlags )
21 import Id ( Id, idType, idInlinePragma )
22 import CoreUtils ( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr, exprIsCheap )
23 import DataCon ( isUnboxedTupleCon )
24 import Type ( tyConAppArgs )
27 import CoreLint ( showPass, endPass )
29 import StaticFlags ( opt_PprStyle_Debug )
30 import BasicTypes ( isAlwaysActive )
31 import Util ( lengthExceeds )
38 Simple common sub-expression
39 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
43 we build up a reverse mapping: C a b -> x1
45 and apply that to the rest of the program.
50 we replace the C a b with x1. But then we *dont* want to
51 add x1 -> y1 to the mapping. Rather, we want the reverse, y1 -> x1
52 so that a subsequent binding
54 will get transformed to C x1 b, and then to x2.
56 So we carry an extra var->var substitution which we apply *before* looking up in the
62 We have to be careful about shadowing.
64 f = \x -> let y = x+x in
68 Here we must *not* do CSE on the inner x+x! The simplifier used to guarantee no
69 shadowing, but it doesn't any more (it proved too hard), so we clone as we go.
70 We can simply add clones to the substitution already described.
72 However, we do NOT clone type variables. It's just too hard, because then we need
73 to run the substitution over types and IdInfo. No no no. Instead, we just throw
75 (In fact, I think the simplifier does guarantee no-shadowing for type variables.)
78 [Note: case binders 1]
79 ~~~~~~~~~~~~~~~~~~~~~~
82 f = \x -> case x of wild {
83 (a:as) -> case a of wild1 {
84 (p,q) -> ...(wild1:as)...
86 Here, (wild1:as) is morally the same as (a:as) and hence equal to wild.
87 But that's not quite obvious. In general we want to keep it as (wild1:as),
88 but for CSE purpose that's a bad idea.
90 So we add the binding (wild1 -> a) to the extra var->var mapping.
91 Notice this is exactly backwards to what the simplifier does, which is
92 to try to replaces uses of a with uses of wild1
94 [Note: case binders 2]
95 ~~~~~~~~~~~~~~~~~~~~~~
97 case (h x) of y -> ...(h x)...
99 We'd like to replace (h x) in the alternative, by y. But because of
100 the preceding [Note: case binders 1], we only want to add the mapping
101 scrutinee -> case binder
102 to the reverse CSE mapping if the scrutinee is a non-trivial expression.
103 (If the scrutinee is a simple variable we want to add the mapping
104 case binder -> scrutinee
107 [Note: unboxed tuple case binders]
108 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
110 case f x of t { (# a,b #) ->
115 We must not replace (f x) by t, because t is an unboxed-tuple binder.
116 Instead, we shoudl replace (f x) by (# a,b #). That is, the "reverse mapping" is
118 That is why the CSEMap has pairs of expressions.
120 Note [INLINE and NOINLINE]
121 ~~~~~~~~~~~~~~~~~~~~~~~~~~
122 We are careful to do no CSE inside functions that the user has marked as
123 INLINE or NOINLINE. In terms of Core, that means
125 a) we do not do CSE inside (Note InlineMe e)
127 b) we do not do CSE on the RHS of a binding b=e
128 unless b's InlinePragma is AlwaysActive
130 Here's why (examples from Roman Leshchinskiy). Consider
140 foo :: Int -> Int -> Int
144 {-# RULES "foo/no" foo no = id #-}
149 We do not expect the rule to fire. But if we do CSE, then we get
150 yes=no, and the rule does fire. Worse, whether we get yes=no or
151 no=yes depends on the order of the definitions.
153 In general, CSE should probably never touch things with INLINE pragmas
154 as this could lead to surprising results. Consider
160 bar = <rhs> -- Same rhs as foo
164 then foo will never be inlined (when it should be); but if it produces
166 bar will be inlined (when it should not be). Even if we remove INLINE foo,
167 we'd still like foo to be inlined if rhs is small. This won't happen
170 Not CSE-ing inside INLINE also solves an annoying bug in CSE. Consider
171 a worker/wrapper, in which the worker has turned into a single variable:
174 Now CSE may transoform to
176 But the WorkerInfo for f still says $wf, which is now dead! This won't
177 happen now that we don't look inside INLINEs (which wrappers are).
180 %************************************************************************
182 \section{Common subexpression}
184 %************************************************************************
187 cseProgram :: DynFlags -> [CoreBind] -> IO [CoreBind]
189 cseProgram dflags binds
191 showPass dflags "Common sub-expression";
192 let { binds' = cseBinds emptyCSEnv binds };
193 endPass dflags "Common sub-expression" Opt_D_dump_cse binds'
196 cseBinds :: CSEnv -> [CoreBind] -> [CoreBind]
198 cseBinds env (b:bs) = (b':bs')
200 (env1, b') = cseBind env b
201 bs' = cseBinds env1 bs
203 cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind)
204 cseBind env (NonRec b e) = let (env', (b',e')) = do_one env (b, e)
205 in (env', NonRec b' e')
206 cseBind env (Rec pairs) = let (env', pairs') = mapAccumL do_one env pairs
207 in (env', Rec pairs')
211 = case lookupCSEnv env rhs' of
212 Just (Var other_id) -> (extendSubst env' id other_id, (id', Var other_id))
213 Just other_expr -> (env', (id', other_expr))
214 Nothing -> (addCSEnvItem env' rhs' (Var id'), (id', rhs'))
216 (env', id') = addBinder env id
217 rhs' | isAlwaysActive (idInlinePragma id) = cseExpr env' rhs
219 -- See Note [INLINE and NOINLINE]
221 tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
222 tryForCSE env (Type t) = Type t
223 tryForCSE env expr = case lookupCSEnv env expr' of
224 Just smaller_expr -> smaller_expr
227 expr' = cseExpr env expr
229 cseExpr :: CSEnv -> CoreExpr -> CoreExpr
230 cseExpr env (Type t) = Type t
231 cseExpr env (Lit lit) = Lit lit
232 cseExpr env (Var v) = Var (lookupSubst env v)
233 cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a)
234 cseExpr evn (Note InlineMe e) = Note InlineMe e -- See Note [INLINE and NOINLINE]
235 cseExpr env (Note n e) = Note n (cseExpr env e)
236 cseExpr env (Cast e co) = Cast (cseExpr env e) co
237 cseExpr env (Lam b e) = let (env', b') = addBinder env b
238 in Lam b' (cseExpr env' e)
239 cseExpr env (Let bind e) = let (env', bind') = cseBind env bind
240 in Let bind' (cseExpr env' e)
241 cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr' ty (cseAlts env' scrut' bndr bndr' alts)
243 scrut' = tryForCSE env scrut
244 (env', bndr') = addBinder env bndr
247 cseAlts env scrut' bndr bndr' [(DataAlt con, args, rhs)]
248 | isUnboxedTupleCon con
249 -- Unboxed tuples are special because the case binder isn't
250 -- a real values. See [Note: unboxed tuple case binders]
251 = [(DataAlt con, args', tryForCSE new_env rhs)]
253 (env', args') = addBinders env args
254 new_env | exprIsCheap scrut' = env'
255 | otherwise = extendCSEnv env' scrut' tup_value
256 tup_value = mkAltExpr (DataAlt con) args' (tyConAppArgs (idType bndr))
258 cseAlts env scrut' bndr bndr' alts
261 (con_target, alt_env)
263 Var v' -> (v', extendSubst env bndr v') -- See [Note: case binder 1]
266 other -> (bndr', extendCSEnv env scrut' (Var bndr')) -- See [Note: case binder 2]
267 -- map: scrut' -> bndr'
269 arg_tys = tyConAppArgs (idType bndr)
271 cse_alt (DataAlt con, args, rhs)
273 -- Don't try CSE if there are no args; it just increases the number
274 -- of live vars. E.g.
275 -- case x of { True -> ....True.... }
276 -- Don't replace True by x!
277 -- Hence the 'null args', which also deal with literals and DEFAULT
278 = (DataAlt con, args', tryForCSE new_env rhs)
280 (env', args') = addBinders alt_env args
281 new_env = extendCSEnv env' (mkAltExpr (DataAlt con) args' arg_tys)
284 cse_alt (con, args, rhs)
285 = (con, args', tryForCSE env' rhs)
287 (env', args') = addBinders alt_env args
291 %************************************************************************
293 \section{The CSE envt}
295 %************************************************************************
298 data CSEnv = CS CSEMap InScopeSet (IdEnv Id)
299 -- Simple substitution
301 type CSEMap = UniqFM [(CoreExpr, CoreExpr)] -- This is the reverse mapping
302 -- It maps the hash-code of an expression e to list of (e,e') pairs
303 -- This means that it's good to replace e by e'
304 -- INVARIANT: The expr in the range has already been CSE'd
306 emptyCSEnv = CS emptyUFM emptyInScopeSet emptyVarEnv
308 lookupCSEnv :: CSEnv -> CoreExpr -> Maybe CoreExpr
309 lookupCSEnv (CS cs _ _) expr
310 = case lookupUFM cs (hashExpr expr) of
312 Just pairs -> lookup_list pairs expr
314 lookup_list :: [(CoreExpr,CoreExpr)] -> CoreExpr -> Maybe CoreExpr
315 lookup_list [] expr = Nothing
316 lookup_list ((e,e'):es) expr | cheapEqExpr e expr = Just e'
317 | otherwise = lookup_list es expr
319 addCSEnvItem env expr expr' | exprIsBig expr = env
320 | otherwise = extendCSEnv env expr expr'
321 -- We don't try to CSE big expressions, because they are expensive to compare
322 -- (and are unlikely to be the same anyway)
324 extendCSEnv (CS cs in_scope sub) expr expr'
325 = CS (addToUFM_C combine cs hash [(expr, expr')]) in_scope sub
329 = WARN( result `lengthExceeds` 4, short_msg $$ nest 2 long_msg ) result
332 short_msg = ptext SLIT("extendCSEnv: long list, length") <+> int (length result)
333 long_msg | opt_PprStyle_Debug = (text "hash code" <+> text (show hash)) $$ ppr result
336 lookupSubst (CS _ _ sub) x = case lookupVarEnv sub x of
340 extendSubst (CS cs in_scope sub) x y = CS cs in_scope (extendVarEnv sub x y)
342 addBinder :: CSEnv -> Id -> (CSEnv, Id)
343 addBinder env@(CS cs in_scope sub) v
344 | not (v `elemInScopeSet` in_scope) = (CS cs (extendInScopeSet in_scope v) sub, v)
345 | isId v = (CS cs (extendInScopeSet in_scope v') (extendVarEnv sub v v'), v')
346 | otherwise = WARN( True, ppr v )
347 (CS emptyUFM in_scope sub, v)
348 -- This last case is the unusual situation where we have shadowing of
349 -- a type variable; we have to discard the CSE mapping
350 -- See "IMPORTANT NOTE" at the top
352 v' = uniqAway in_scope v
354 addBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
355 addBinders env vs = mapAccumL addBinder env vs