2 % (c) The AQUA Project, Glasgow University, 1993-1998
4 \section{Common subexpression}
11 #include "HsVersions.h"
13 import CmdLineOpts ( DynFlag(..), DynFlags )
14 import Id ( Id, idType, idWorkerInfo )
15 import IdInfo ( workerExists )
16 import CoreUtils ( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr )
17 import DataCon ( isUnboxedTupleCon )
18 import Type ( tyConAppArgs )
19 import Subst ( InScopeSet, uniqAway, emptyInScopeSet,
20 extendInScopeSet, elemInScopeSet )
23 import CoreLint ( showPass, endPass )
25 import Util ( mapAccumL, 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
66 away the entire reverse mapping if this unusual situation ever shows up.
67 (In fact, I think the simplifier does guarantee no-shadowing for type variables.)
70 Another important wrinkle
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
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 "Another important wrinkle", 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
100 %************************************************************************
102 \section{Common subexpression}
104 %************************************************************************
107 cseProgram :: DynFlags -> [CoreBind] -> IO [CoreBind]
109 cseProgram dflags binds
111 showPass dflags "Common sub-expression";
112 let { binds' = cseBinds emptyCSEnv binds };
113 endPass dflags "Common sub-expression" Opt_D_dump_cse binds'
116 cseBinds :: CSEnv -> [CoreBind] -> [CoreBind]
118 cseBinds env (b:bs) = (b':bs')
120 (env1, b') = cseBind env b
121 bs' = cseBinds env1 bs
123 cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind)
124 cseBind env (NonRec b e) = let (env', (_,e')) = do_one env (b, e)
125 in (env', NonRec b e')
126 cseBind env (Rec pairs) = let (env', pairs') = mapAccumL do_one env pairs
127 in (env', Rec pairs')
131 = case lookupCSEnv env rhs' of
132 Just other_id -> (extendSubst env' id other_id, (id', Var other_id))
133 Nothing -> (addCSEnvItem env' id' rhs', (id', rhs'))
135 (env', id') = addBinder env id
136 rhs' | not (workerExists (idWorkerInfo id)) = cseExpr env' rhs
138 -- Hack alert: don't do CSE on wrapper RHSs.
139 -- Otherwise we find:
141 -- f = \x -> ...$wf...
144 -- But the WorkerInfo for f still says $wf, which is now dead!
148 tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
149 tryForCSE env (Type t) = Type t
150 tryForCSE env expr = case lookupCSEnv env expr' of
154 expr' = cseExpr env expr
156 cseExpr :: CSEnv -> CoreExpr -> CoreExpr
157 cseExpr env (Type t) = Type t
158 cseExpr env (Lit lit) = Lit lit
159 cseExpr env (Var v) = Var (lookupSubst env v)
160 cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a)
161 cseExpr env (Note n e) = Note n (cseExpr env e)
162 cseExpr env (Lam b e) = let (env', b') = addBinder env b
163 in Lam b' (cseExpr env' e)
164 cseExpr env (Let bind e) = let (env', bind') = cseBind env bind
165 in Let bind' (cseExpr env' e)
166 cseExpr env (Case scrut bndr alts) = Case scrut' bndr' (cseAlts env' scrut' bndr bndr' alts)
168 scrut' = tryForCSE env scrut
169 (env', bndr') = addBinder env bndr
172 cseAlts env scrut' bndr bndr' alts
175 (con_target, alt_env)
177 Var v' -> (v', extendSubst env bndr v') -- See "another important wrinkle"
180 other -> (bndr', extendCSEnv env bndr' scrut') -- See "yet another wrinkle"
181 -- map: scrut' -> bndr'
183 arg_tys = tyConAppArgs (idType bndr)
185 cse_alt (DataAlt con, args, rhs)
186 | not (null args || isUnboxedTupleCon con)
187 -- Don't try CSE if there are no args; it just increases the number
188 -- of live vars. E.g.
189 -- case x of { True -> ....True.... }
190 -- Don't replace True by x!
191 -- Hence the 'null args', which also deal with literals and DEFAULT
192 -- And we can't CSE on unboxed tuples
193 = (DataAlt con, args', tryForCSE new_env rhs)
195 (env', args') = addBinders alt_env args
196 new_env = extendCSEnv env' con_target (mkAltExpr (DataAlt con) args' arg_tys)
198 cse_alt (con, args, rhs)
199 = (con, args', tryForCSE env' rhs)
201 (env', args') = addBinders alt_env args
205 %************************************************************************
207 \section{The CSE envt}
209 %************************************************************************
212 data CSEnv = CS CSEMap InScopeSet (IdEnv Id)
213 -- Simple substitution
215 type CSEMap = UniqFM [(Id, CoreExpr)] -- This is the reverse mapping
216 -- It maps the hash-code of an expression to list of (x,e) pairs
217 -- This means that it's good to replace e by x
218 -- INVARIANT: The expr in the range has already been CSE'd
220 emptyCSEnv = CS emptyUFM emptyInScopeSet emptyVarEnv
222 lookupCSEnv :: CSEnv -> CoreExpr -> Maybe Id
223 lookupCSEnv (CS cs _ _) expr
224 = case lookupUFM cs (hashExpr expr) of
226 Just pairs -> lookup_list pairs expr
228 lookup_list :: [(Id,CoreExpr)] -> CoreExpr -> Maybe Id
229 lookup_list [] expr = Nothing
230 lookup_list ((x,e):es) expr | cheapEqExpr e expr = Just x
231 | otherwise = lookup_list es expr
233 addCSEnvItem env id expr | exprIsBig expr = env
234 | otherwise = extendCSEnv env id expr
235 -- We don't try to CSE big expressions, because they are expensive to compare
236 -- (and are unlikely to be the same anyway)
238 extendCSEnv (CS cs in_scope sub) id expr
239 = CS (addToUFM_C combine cs hash [(id, expr)]) in_scope sub
242 combine old new = WARN( result `lengthExceeds` 4, text "extendCSEnv: long list:" <+> ppr result )
247 lookupSubst (CS _ _ sub) x = case lookupVarEnv sub x of
251 extendSubst (CS cs in_scope sub) x y = CS cs in_scope (extendVarEnv sub x y)
253 addBinder :: CSEnv -> Id -> (CSEnv, Id)
254 addBinder env@(CS cs in_scope sub) v
255 | not (v `elemInScopeSet` in_scope) = (CS cs (extendInScopeSet in_scope v) sub, v)
256 | isId v = (CS cs (extendInScopeSet in_scope v') (extendVarEnv sub v v'), v')
257 | not (isId v) = WARN( True, ppr v )
258 (CS emptyUFM in_scope sub, v)
259 -- This last case is the unusual situation where we have shadowing of
260 -- a type variable; we have to discard the CSE mapping
261 -- See "IMPORTANT NOTE" at the top
263 v' = uniqAway in_scope v
265 addBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
266 addBinders env vs = mapAccumL addBinder env vs