2 % (c) The AQUA Project, Glasgow University, 1993-1998
4 \section{Common subexpression}
11 #include "HsVersions.h"
13 import CmdLineOpts ( opt_D_dump_cse, opt_D_verbose_core2core )
14 import Id ( Id, idType )
15 import CoreUtils ( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr )
16 import DataCon ( isUnboxedTupleCon )
17 import Type ( splitTyConApp_maybe )
20 import CoreLint ( beginPass, endPass )
22 import Util ( mapAccumL )
27 Simple common sub-expression
28 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
32 we build up a reverse mapping: C a b -> x1
34 and apply that to the rest of the program.
39 we replace the C a b with x1. But then we *dont* want to
40 add x1 -> y1 to the mapping. Rather, we want the reverse, y1 -> x1
41 so that a subsequent binding
43 will get transformed to C x1 b, and then to x2.
45 So we carry an extra var->var mapping which we apply *before* looking up in the
51 This pass relies on the no-shadowing invariant, so it must run
52 immediately after the simplifier.
55 f = \x -> let y = x+x in
59 Here we must *not* do CSE on the inner x+x!
62 Another important wrinkle
63 ~~~~~~~~~~~~~~~~~~~~~~~~~
66 f = \x -> case x of wild {
67 (a:as) -> case a of wild1 {
68 (p,q) -> ...(wild1:as)...
70 Here, (wild1:as) is morally the same as (a:as) and hence equal to wild.
71 But that's not quite obvious. In general we want to keep it as (wild1:as),
72 but for CSE purpose that's a bad idea.
74 So we add the binding (wild1 -> a) to the extra var->var mapping.
80 case (h x) of y -> ...(h x)...
82 We'd like to replace (h x) in the alternative, by y. But because of
83 the preceding "Another important wrinkle", we only want to add the mapping
84 scrutinee -> case binder
85 to the CSE mapping if the scrutinee is a non-trivial expression.
88 %************************************************************************
90 \section{Common subexpression}
92 %************************************************************************
95 cseProgram :: [CoreBind] -> IO [CoreBind]
99 beginPass "Common sub-expression";
100 let { binds' = cseBinds emptyCSEnv binds };
101 endPass "Common sub-expression"
102 (opt_D_dump_cse || opt_D_verbose_core2core)
106 cseBinds :: CSEnv -> [CoreBind] -> [CoreBind]
108 cseBinds env (b:bs) = (b':bs')
110 (env1, b') = cseBind env b
111 bs' = cseBinds env1 bs
113 cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind)
114 cseBind env (NonRec b e) = let (env', (_,e')) = do_one env (b, e)
115 in (env', NonRec b e')
116 cseBind env (Rec pairs) = let (env', pairs') = mapAccumL do_one env pairs
117 in (env', Rec pairs')
120 do_one env (id, rhs) = case lookupCSEnv env rhs' of
121 Just other_id -> (extendSubst env id other_id, (id, Var other_id))
122 Nothing -> (addCSEnvItem env id rhs', (id, rhs'))
124 rhs' = cseExpr env rhs
127 tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
128 tryForCSE env (Type t) = Type t
129 tryForCSE env expr = case lookupCSEnv env expr' of
133 expr' = cseExpr env expr
135 cseExpr :: CSEnv -> CoreExpr -> CoreExpr
136 cseExpr env (Type t) = Type t
137 cseExpr env (Lit lit) = Lit lit
138 cseExpr env (Var v) = Var (lookupSubst env v)
139 cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a)
140 cseExpr env (Note n e) = Note n (cseExpr env e)
141 cseExpr env (Lam b e) = Lam b (cseExpr env e)
142 cseExpr env (Let bind e) = let (env1, bind') = cseBind env bind
143 in Let bind' (cseExpr env1 e)
144 cseExpr env (Case scrut bndr alts) = Case scrut' bndr (cseAlts env scrut' bndr alts)
146 scrut' = tryForCSE env scrut
149 cseAlts env new_scrut bndr alts
152 (con_target, alt_env)
154 Var v -> (v, extendSubst env bndr v) -- See "another important wrinkle"
157 other -> (bndr, extendCSEnv env bndr new_scrut) -- See "yet another wrinkle"
158 -- map: new_scrut -> bndr
160 arg_tys = case splitTyConApp_maybe (idType bndr) of
161 Just (_, arg_tys) -> arg_tys
162 other -> pprPanic "cseAlts" (ppr bndr)
164 cse_alt (DataAlt con, args, rhs)
165 | not (null args || isUnboxedTupleCon con)
166 -- Don't try CSE if there are no args; it just increases the number
167 -- of live vars. E.g.
168 -- case x of { True -> ....True.... }
169 -- Don't replace True by x!
170 -- Hence the 'null args', which also deal with literals and DEFAULT
171 -- And we can't CSE on unboxed tuples
172 = (DataAlt con, args, tryForCSE new_env rhs)
174 new_env = extendCSEnv alt_env con_target (mkAltExpr (DataAlt con) args arg_tys)
176 cse_alt (con, args, rhs)
177 = (con, args, tryForCSE alt_env rhs)
181 %************************************************************************
183 \section{The CSE envt}
185 %************************************************************************
188 data CSEnv = CS (UniqFM [(Id, CoreExpr)]) -- The expr in the range has already been CSE'd
189 (IdEnv Id) -- Simple substitution
191 emptyCSEnv = CS emptyUFM emptyVarEnv
193 lookupCSEnv :: CSEnv -> CoreExpr -> Maybe Id
194 lookupCSEnv (CS cs _) expr
195 = case lookupUFM cs (hashExpr expr) of
197 Just pairs -> lookup_list pairs expr
199 lookup_list :: [(Id,CoreExpr)] -> CoreExpr -> Maybe Id
200 lookup_list [] expr = Nothing
201 lookup_list ((x,e):es) expr | cheapEqExpr e expr = Just x
202 | otherwise = lookup_list es expr
204 addCSEnvItem env id expr | exprIsBig expr = env
205 | otherwise = extendCSEnv env id expr
207 extendCSEnv (CS cs sub) id expr
208 = CS (addToUFM_C combine cs hash [(id, expr)]) sub
211 combine old new = WARN( length result > 4, text "extendCSEnv: long list:" <+> ppr result )
216 lookupSubst (CS _ sub) x = case lookupVarEnv sub x of
220 extendSubst (CS cs sub) x y = CS cs (extendVarEnv sub x y)