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 ( lengthExceeds )
31 Simple common sub-expression
32 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
36 we build up a reverse mapping: C a b -> x1
38 and apply that to the rest of the program.
43 we replace the C a b with x1. But then we *dont* want to
44 add x1 -> y1 to the mapping. Rather, we want the reverse, y1 -> x1
45 so that a subsequent binding
47 will get transformed to C x1 b, and then to x2.
49 So we carry an extra var->var substitution which we apply *before* looking up in the
55 We have to be careful about shadowing.
57 f = \x -> let y = x+x in
61 Here we must *not* do CSE on the inner x+x! The simplifier used to guarantee no
62 shadowing, but it doesn't any more (it proved too hard), so we clone as we go.
63 We can simply add clones to the substitution already described.
65 However, we do NOT clone type variables. It's just too hard, because then we need
66 to run the substitution over types and IdInfo. No no no. Instead, we just throw
68 (In fact, I think the simplifier does guarantee no-shadowing for type variables.)
71 [Note: case binders 1]
72 ~~~~~~~~~~~~~~~~~~~~~~
75 f = \x -> case x of wild {
76 (a:as) -> case a of wild1 {
77 (p,q) -> ...(wild1:as)...
79 Here, (wild1:as) is morally the same as (a:as) and hence equal to wild.
80 But that's not quite obvious. In general we want to keep it as (wild1:as),
81 but for CSE purpose that's a bad idea.
83 So we add the binding (wild1 -> a) to the extra var->var mapping.
84 Notice this is exactly backwards to what the simplifier does, which is
85 to try to replaces uses of a with uses of wild1
87 [Note: case binders 2]
88 ~~~~~~~~~~~~~~~~~~~~~~
90 case (h x) of y -> ...(h x)...
92 We'd like to replace (h x) in the alternative, by y. But because of
93 the preceding [Note: case binders 1], we only want to add the mapping
94 scrutinee -> case binder
95 to the reverse CSE mapping if the scrutinee is a non-trivial expression.
96 (If the scrutinee is a simple variable we want to add the mapping
97 case binder -> scrutinee
100 [Note: unboxed tuple case binders]
101 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
103 case f x of t { (# a,b #) ->
108 We must not replace (f x) by t, because t is an unboxed-tuple binder.
109 Instead, we shoudl replace (f x) by (# a,b #). That is, the "reverse mapping" is
111 That is why the CSEMap has pairs of expressions.
113 Note [CSE for INLINE and NOINLINE]
114 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
115 We are careful to do no CSE inside functions that the user has marked as
116 INLINE or NOINLINE. In terms of Core, that means
118 a) we do not do CSE inside (Note InlineMe e)
120 b) we do not do CSE on the RHS of a binding b=e
121 unless b's InlinePragma is AlwaysActive
123 Here's why (examples from Roman Leshchinskiy). Consider
133 foo :: Int -> Int -> Int
137 {-# RULES "foo/no" foo no = id #-}
142 We do not expect the rule to fire. But if we do CSE, then we get
143 yes=no, and the rule does fire. Worse, whether we get yes=no or
144 no=yes depends on the order of the definitions.
146 In general, CSE should probably never touch things with INLINE pragmas
147 as this could lead to surprising results. Consider
153 bar = <rhs> -- Same rhs as foo
157 then foo will never be inlined (when it should be); but if it produces
159 bar will be inlined (when it should not be). Even if we remove INLINE foo,
160 we'd still like foo to be inlined if rhs is small. This won't happen
163 Not CSE-ing inside INLINE also solves an annoying bug in CSE. Consider
164 a worker/wrapper, in which the worker has turned into a single variable:
167 Now CSE may transform to
169 But the WorkerInfo for f still says $wf, which is now dead! This won't
170 happen now that we don't look inside INLINEs (which wrappers are).
173 %************************************************************************
175 \section{Common subexpression}
177 %************************************************************************
180 cseProgram :: DynFlags -> [CoreBind] -> IO [CoreBind]
182 cseProgram dflags binds
184 showPass dflags "Common sub-expression";
185 let { binds' = cseBinds emptyCSEnv binds };
186 endPass dflags "Common sub-expression" Opt_D_dump_cse binds'
189 cseBinds :: CSEnv -> [CoreBind] -> [CoreBind]
191 cseBinds env (b:bs) = (b':bs')
193 (env1, b') = cseBind env b
194 bs' = cseBinds env1 bs
196 cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind)
197 cseBind env (NonRec b e) = let (env', (b',e')) = do_one env (b, e)
198 in (env', NonRec b' e')
199 cseBind env (Rec pairs) = let (env', pairs') = mapAccumL do_one env pairs
200 in (env', Rec pairs')
203 do_one :: CSEnv -> (Id, CoreExpr) -> (CSEnv, (Id, CoreExpr))
205 = case lookupCSEnv env rhs' of
206 Just (Var other_id) -> (extendSubst env' id other_id, (id', Var other_id))
207 Just other_expr -> (env', (id', other_expr))
208 Nothing -> (addCSEnvItem env' rhs' (Var id'), (id', rhs'))
210 (env', id') = addBinder env id
211 rhs' | isAlwaysActive (idInlinePragma id) = cseExpr env' rhs
213 -- See Note [CSE for INLINE and NOINLINE]
215 tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
216 tryForCSE _ (Type t) = Type t
217 tryForCSE env expr = case lookupCSEnv env expr' of
218 Just smaller_expr -> smaller_expr
221 expr' = cseExpr env expr
223 cseExpr :: CSEnv -> CoreExpr -> CoreExpr
224 cseExpr _ (Type t) = Type t
225 cseExpr _ (Lit lit) = Lit lit
226 cseExpr env (Var v) = Var (lookupSubst env v)
227 cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a)
228 cseExpr _ (Note InlineMe e) = Note InlineMe e -- See Note [CSE for INLINE and NOINLINE]
229 cseExpr env (Note n e) = Note n (cseExpr env e)
230 cseExpr env (Cast e co) = Cast (cseExpr env e) co
231 cseExpr env (Lam b e) = let (env', b') = addBinder env b
232 in Lam b' (cseExpr env' e)
233 cseExpr env (Let bind e) = let (env', bind') = cseBind env bind
234 in Let bind' (cseExpr env' e)
235 cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr' ty (cseAlts env' scrut' bndr bndr' alts)
237 scrut' = tryForCSE env scrut
238 (env', bndr') = addBinder env bndr
241 cseAlts :: CSEnv -> CoreExpr -> CoreBndr -> CoreBndr -> [CoreAlt] -> [CoreAlt]
243 cseAlts env scrut' bndr _bndr' [(DataAlt con, args, rhs)]
244 | isUnboxedTupleCon con
245 -- Unboxed tuples are special because the case binder isn't
246 -- a real values. See [Note: unboxed tuple case binders]
247 = [(DataAlt con, args', tryForCSE new_env rhs)]
249 (env', args') = addBinders env args
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 binder 1]
262 _ -> (bndr', extendCSEnv env scrut' (Var bndr')) -- See [Note: case binder 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 _ _) expr
307 = case lookupUFM cs (hashExpr expr) of
309 Just pairs -> lookup_list pairs expr
311 lookup_list :: [(CoreExpr,CoreExpr)] -> CoreExpr -> Maybe CoreExpr
312 lookup_list [] _ = Nothing
313 lookup_list ((e,e'):es) expr | cheapEqExpr e expr = Just e'
314 | otherwise = lookup_list es expr
316 addCSEnvItem :: CSEnv -> CoreExpr -> CoreExpr -> CSEnv
317 addCSEnvItem env expr expr' | exprIsBig expr = env
318 | otherwise = extendCSEnv env expr expr'
319 -- We don't try to CSE big expressions, because they are expensive to compare
320 -- (and are unlikely to be the same anyway)
322 extendCSEnv :: CSEnv -> CoreExpr -> CoreExpr -> CSEnv
323 extendCSEnv (CS cs in_scope sub) expr expr'
324 = CS (addToUFM_C combine cs hash [(expr, expr')]) in_scope sub
328 = WARN( result `lengthExceeds` 4, short_msg $$ nest 2 long_msg ) result
331 short_msg = ptext SLIT("extendCSEnv: long list, length") <+> int (length result)
332 long_msg | opt_PprStyle_Debug = (text "hash code" <+> text (show hash)) $$ ppr result
335 lookupSubst :: CSEnv -> Id -> Id
336 lookupSubst (CS _ _ sub) x = case lookupVarEnv sub x of
340 extendSubst :: CSEnv -> Id -> Id -> CSEnv
341 extendSubst (CS cs in_scope sub) x y = CS cs in_scope (extendVarEnv sub x y)
343 addBinder :: CSEnv -> Id -> (CSEnv, Id)
344 addBinder (CS cs in_scope sub) v
345 | not (v `elemInScopeSet` in_scope) = (CS cs (extendInScopeSet in_scope v) sub, v)
346 | isId v = (CS cs (extendInScopeSet in_scope v') (extendVarEnv sub v v'), v')
347 | otherwise = WARN( True, ppr v )
348 (CS emptyUFM in_scope sub, v)
349 -- This last case is the unusual situation where we have shadowing of
350 -- a type variable; we have to discard the CSE mapping
351 -- See "IMPORTANT NOTE" at the top
353 v' = uniqAway in_scope v
355 addBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
356 addBinders env vs = mapAccumL addBinder env vs