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 )
15 import CoreUtils ( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr )
16 import DataCon ( isUnboxedTupleCon )
17 import Type ( tyConAppArgs )
18 import Subst ( InScopeSet, uniqAway, emptyInScopeSet,
19 extendInScopeSet, elemInScopeSet )
22 import CoreLint ( showPass, endPass )
24 import Util ( mapAccumL )
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
65 away the entire reverse mapping if this unusual situation ever shows up.
66 (In fact, I think the simplifier does guarantee no-shadowing for type variables.)
69 Another important wrinkle
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
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 "Another important wrinkle", 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
99 %************************************************************************
101 \section{Common subexpression}
103 %************************************************************************
106 cseProgram :: DynFlags -> [CoreBind] -> IO [CoreBind]
108 cseProgram dflags binds
110 showPass dflags "Common sub-expression";
111 let { binds' = cseBinds emptyCSEnv binds };
112 endPass dflags "Common sub-expression" Opt_D_dump_cse binds'
115 cseBinds :: CSEnv -> [CoreBind] -> [CoreBind]
117 cseBinds env (b:bs) = (b':bs')
119 (env1, b') = cseBind env b
120 bs' = cseBinds env1 bs
122 cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind)
123 cseBind env (NonRec b e) = let (env', (_,e')) = do_one env (b, e)
124 in (env', NonRec b e')
125 cseBind env (Rec pairs) = let (env', pairs') = mapAccumL do_one env pairs
126 in (env', Rec pairs')
129 do_one env (id, rhs) = case lookupCSEnv env rhs' of
130 Just other_id -> (extendSubst env' id other_id, (id', Var other_id))
131 Nothing -> (addCSEnvItem env' id' rhs', (id', rhs'))
133 (env', id') = addBinder env id
134 rhs' = cseExpr env' rhs
136 tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
137 tryForCSE env (Type t) = Type t
138 tryForCSE env expr = case lookupCSEnv env expr' of
142 expr' = cseExpr env expr
144 cseExpr :: CSEnv -> CoreExpr -> CoreExpr
145 cseExpr env (Type t) = Type t
146 cseExpr env (Lit lit) = Lit lit
147 cseExpr env (Var v) = Var (lookupSubst env v)
148 cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a)
149 cseExpr env (Note n e) = Note n (cseExpr env e)
150 cseExpr env (Lam b e) = let (env', b') = addBinder env b
151 in Lam b' (cseExpr env' e)
152 cseExpr env (Let bind e) = let (env', bind') = cseBind env bind
153 in Let bind' (cseExpr env' e)
154 cseExpr env (Case scrut bndr alts) = Case scrut' bndr' (cseAlts env' scrut' bndr bndr' alts)
156 scrut' = tryForCSE env scrut
157 (env', bndr') = addBinder env bndr
160 cseAlts env scrut' bndr bndr' alts
163 (con_target, alt_env)
165 Var v' -> (v', extendSubst env bndr v') -- See "another important wrinkle"
168 other -> (bndr', extendCSEnv env bndr' scrut') -- See "yet another wrinkle"
169 -- map: scrut' -> bndr'
171 arg_tys = tyConAppArgs (idType bndr)
173 cse_alt (DataAlt con, args, rhs)
174 | not (null args || isUnboxedTupleCon con)
175 -- Don't try CSE if there are no args; it just increases the number
176 -- of live vars. E.g.
177 -- case x of { True -> ....True.... }
178 -- Don't replace True by x!
179 -- Hence the 'null args', which also deal with literals and DEFAULT
180 -- And we can't CSE on unboxed tuples
181 = (DataAlt con, args', tryForCSE new_env rhs)
183 (env', args') = addBinders alt_env args
184 new_env = extendCSEnv env' con_target (mkAltExpr (DataAlt con) args' arg_tys)
186 cse_alt (con, args, rhs)
187 = (con, args', tryForCSE env' rhs)
189 (env', args') = addBinders alt_env args
193 %************************************************************************
195 \section{The CSE envt}
197 %************************************************************************
200 data CSEnv = CS CSEMap InScopeSet (IdEnv Id)
201 -- Simple substitution
203 type CSEMap = UniqFM [(Id, CoreExpr)] -- This is the reverse mapping
204 -- It maps the hash-code of an expression to list of (x,e) pairs
205 -- This means that it's good to replace e by x
206 -- INVARIANT: The expr in the range has already been CSE'd
208 emptyCSEnv = CS emptyUFM emptyInScopeSet emptyVarEnv
210 lookupCSEnv :: CSEnv -> CoreExpr -> Maybe Id
211 lookupCSEnv (CS cs _ _) expr
212 = case lookupUFM cs (hashExpr expr) of
214 Just pairs -> lookup_list pairs expr
216 lookup_list :: [(Id,CoreExpr)] -> CoreExpr -> Maybe Id
217 lookup_list [] expr = Nothing
218 lookup_list ((x,e):es) expr | cheapEqExpr e expr = Just x
219 | otherwise = lookup_list es expr
221 addCSEnvItem env id expr | exprIsBig expr = env
222 | otherwise = extendCSEnv env id expr
223 -- We don't try to CSE big expressions, because they are expensive to compare
224 -- (and are unlikely to be the same anyway)
226 extendCSEnv (CS cs in_scope sub) id expr
227 = CS (addToUFM_C combine cs hash [(id, expr)]) in_scope sub
230 combine old new = WARN( length result > 4, text "extendCSEnv: long list:" <+> ppr result )
235 lookupSubst (CS _ _ sub) x = case lookupVarEnv sub x of
239 extendSubst (CS cs in_scope sub) x y = CS cs in_scope (extendVarEnv sub x y)
241 addBinder :: CSEnv -> Id -> (CSEnv, Id)
242 addBinder env@(CS cs in_scope sub) v
243 | not (v `elemInScopeSet` in_scope) = (CS cs (extendInScopeSet in_scope v) sub, v)
244 | isId v = (CS cs (extendInScopeSet in_scope v') (extendVarEnv sub v v'), v')
245 | not (isId v) = WARN( True, ppr v )
246 (CS emptyUFM in_scope sub, v)
247 -- This last case is the unusual situation where we have shadowing of
248 -- a type variable; we have to discard the CSE mapping
249 -- See "IMPORTANT NOTE" at the top
251 v' = uniqAway in_scope v
253 addBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
254 addBinders env vs = mapAccumL addBinder env vs