2 % (c) The AQUA Project, Glasgow University, 1993-1998
4 \section{Common subexpression}
11 #include "HsVersions.h"
13 import CmdLineOpts ( DynFlag(..), DynFlags, dopt )
14 import Id ( Id, idType )
15 import CoreUtils ( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr )
16 import DataCon ( isUnboxedTupleCon )
17 import Type ( splitTyConApp_maybe )
18 import Subst ( InScopeSet, uniqAway, emptyInScopeSet,
19 extendInScopeSet, elemInScopeSet )
22 import CoreLint ( beginPass, 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 beginPass dflags "Common sub-expression";
111 let { binds' = cseBinds emptyCSEnv binds };
112 endPass dflags "Common sub-expression"
113 (dopt Opt_D_dump_cse dflags || dopt Opt_D_verbose_core2core dflags)
117 cseBinds :: CSEnv -> [CoreBind] -> [CoreBind]
119 cseBinds env (b:bs) = (b':bs')
121 (env1, b') = cseBind env b
122 bs' = cseBinds env1 bs
124 cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind)
125 cseBind env (NonRec b e) = let (env', (_,e')) = do_one env (b, e)
126 in (env', NonRec b e')
127 cseBind env (Rec pairs) = let (env', pairs') = mapAccumL do_one env pairs
128 in (env', Rec pairs')
131 do_one env (id, rhs) = 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' = cseExpr env' rhs
138 tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
139 tryForCSE env (Type t) = Type t
140 tryForCSE env expr = case lookupCSEnv env expr' of
144 expr' = cseExpr env expr
146 cseExpr :: CSEnv -> CoreExpr -> CoreExpr
147 cseExpr env (Type t) = Type t
148 cseExpr env (Lit lit) = Lit lit
149 cseExpr env (Var v) = Var (lookupSubst env v)
150 cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a)
151 cseExpr env (Note n e) = Note n (cseExpr env e)
152 cseExpr env (Lam b e) = let (env', b') = addBinder env b
153 in Lam b' (cseExpr env' e)
154 cseExpr env (Let bind e) = let (env', bind') = cseBind env bind
155 in Let bind' (cseExpr env' e)
156 cseExpr env (Case scrut bndr alts) = Case scrut' bndr' (cseAlts env' scrut' bndr bndr' alts)
158 scrut' = tryForCSE env scrut
159 (env', bndr') = addBinder env bndr
162 cseAlts env scrut' bndr bndr' alts
165 (con_target, alt_env)
167 Var v' -> (v', extendSubst env bndr v') -- See "another important wrinkle"
170 other -> (bndr', extendCSEnv env bndr' scrut') -- See "yet another wrinkle"
171 -- map: scrut' -> bndr'
173 arg_tys = case splitTyConApp_maybe (idType bndr) of
174 Just (_, arg_tys) -> arg_tys
175 other -> pprPanic "cseAlts" (ppr bndr)
177 cse_alt (DataAlt con, args, rhs)
178 | not (null args || isUnboxedTupleCon con)
179 -- Don't try CSE if there are no args; it just increases the number
180 -- of live vars. E.g.
181 -- case x of { True -> ....True.... }
182 -- Don't replace True by x!
183 -- Hence the 'null args', which also deal with literals and DEFAULT
184 -- And we can't CSE on unboxed tuples
185 = (DataAlt con, args', tryForCSE new_env rhs)
187 (env', args') = addBinders alt_env args
188 new_env = extendCSEnv env' con_target (mkAltExpr (DataAlt con) args' arg_tys)
190 cse_alt (con, args, rhs)
191 = (con, args', tryForCSE env' rhs)
193 (env', args') = addBinders alt_env args
197 %************************************************************************
199 \section{The CSE envt}
201 %************************************************************************
204 data CSEnv = CS CSEMap InScopeSet (IdEnv Id)
205 -- Simple substitution
207 type CSEMap = UniqFM [(Id, CoreExpr)] -- This is the reverse mapping
208 -- It maps the hash-code of an expression to list of (x,e) pairs
209 -- This means that it's good to replace e by x
210 -- INVARIANT: The expr in the range has already been CSE'd
212 emptyCSEnv = CS emptyUFM emptyInScopeSet emptyVarEnv
214 lookupCSEnv :: CSEnv -> CoreExpr -> Maybe Id
215 lookupCSEnv (CS cs _ _) expr
216 = case lookupUFM cs (hashExpr expr) of
218 Just pairs -> lookup_list pairs expr
220 lookup_list :: [(Id,CoreExpr)] -> CoreExpr -> Maybe Id
221 lookup_list [] expr = Nothing
222 lookup_list ((x,e):es) expr | cheapEqExpr e expr = Just x
223 | otherwise = lookup_list es expr
225 addCSEnvItem env id expr | exprIsBig expr = env
226 | otherwise = extendCSEnv env id expr
228 extendCSEnv (CS cs in_scope sub) id expr
229 = CS (addToUFM_C combine cs hash [(id, expr)]) in_scope sub
232 combine old new = WARN( length result > 4, text "extendCSEnv: long list:" <+> ppr result )
237 lookupSubst (CS _ _ sub) x = case lookupVarEnv sub x of
241 extendSubst (CS cs in_scope sub) x y = CS cs in_scope (extendVarEnv sub x y)
243 addBinder :: CSEnv -> Id -> (CSEnv, Id)
244 addBinder env@(CS cs in_scope sub) v
245 | not (v `elemInScopeSet` in_scope) = (CS cs (extendInScopeSet in_scope v) sub, v)
246 | isId v = (CS cs (extendInScopeSet in_scope v') (extendVarEnv sub v v'), v')
247 | not (isId v) = WARN( True, ppr v )
248 (CS emptyUFM in_scope sub, v)
249 -- This last case is the unusual situation where we have shadowing of
250 -- a type variable; we have to discard the CSE mapping
251 -- See "IMPORTANT NOTE" at the top
253 v' = uniqAway in_scope v
255 addBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
256 addBinders env vs = mapAccumL addBinder env vs