Follow the integer package changes
[ghc-hetmet.git] / compiler / simplCore / CSE.lhs
1 %
2 % (c) The AQUA Project, Glasgow University, 1993-1998
3 %
4 \section{Common subexpression}
5
6 \begin{code}
7 module CSE (
8         cseProgram
9     ) where
10
11 #include "HsVersions.h"
12
13 import DynFlags ( DynFlag(..), DynFlags )
14 import Id               ( Id, idType, idInlinePragma, zapIdOccInfo )
15 import CoreUtils        ( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr, exprIsCheap )
16 import DataCon          ( isUnboxedTupleCon )
17 import Type             ( tyConAppArgs )
18 import CoreSyn
19 import VarEnv   
20 import CoreLint         ( showPass, endPass )
21 import Outputable
22 import StaticFlags      ( opt_PprStyle_Debug )
23 import BasicTypes       ( isAlwaysActive )
24 import Util             ( lengthExceeds )
25 import UniqFM
26 import FastString
27
28 import Data.List
29 \end{code}
30
31
32                         Simple common sub-expression
33                         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
34 When we see
35         x1 = C a b
36         x2 = C x1 b
37 we build up a reverse mapping:   C a b  -> x1
38                                  C x1 b -> x2
39 and apply that to the rest of the program.
40
41 When we then see
42         y1 = C a b
43         y2 = C y1 b
44 we replace the C a b with x1.  But then we *dont* want to
45 add   x1 -> y1  to the mapping.  Rather, we want the reverse, y1 -> x1
46 so that a subsequent binding
47         y2 = C y1 b
48 will get transformed to C x1 b, and then to x2.  
49
50 So we carry an extra var->var substitution which we apply *before* looking up in the
51 reverse mapping.
52
53
54 [Note: SHADOWING]
55 ~~~~~~~~~~~~~~~~~
56 We have to be careful about shadowing.
57 For example, consider
58         f = \x -> let y = x+x in
59                       h = \x -> x+x
60                   in ...
61
62 Here we must *not* do CSE on the inner x+x!  The simplifier used to guarantee no
63 shadowing, but it doesn't any more (it proved too hard), so we clone as we go.
64 We can simply add clones to the substitution already described.
65
66 However, we do NOT clone type variables.  It's just too hard, because then we need
67 to run the substitution over types and IdInfo.  No no no.  Instead, we just throw
68
69 (In fact, I think the simplifier does guarantee no-shadowing for type variables.)
70
71
72 Note [Case binders 1]
73 ~~~~~~~~~~~~~~~~~~~~~~
74 Consider
75
76         f = \x -> case x of wild { 
77                         (a:as) -> case a of wild1 {
78                                     (p,q) -> ...(wild1:as)...
79
80 Here, (wild1:as) is morally the same as (a:as) and hence equal to wild.
81 But that's not quite obvious.  In general we want to keep it as (wild1:as),
82 but for CSE purpose that's a bad idea.
83
84 So we add the binding (wild1 -> a) to the extra var->var mapping.
85 Notice this is exactly backwards to what the simplifier does, which is
86 to try to replaces uses of 'a' with uses of 'wild1'
87
88 Note [Case binders 2]
89 ~~~~~~~~~~~~~~~~~~~~~~
90 Consider
91         case (h x) of y -> ...(h x)...
92
93 We'd like to replace (h x) in the alternative, by y.  But because of
94 the preceding [Note: case binders 1], we only want to add the mapping
95         scrutinee -> case binder
96 to the reverse CSE mapping if the scrutinee is a non-trivial expression.
97 (If the scrutinee is a simple variable we want to add the mapping
98         case binder -> scrutinee 
99 to the substitution
100
101 Note [Unboxed tuple case binders]
102 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
103 Consider
104         case f x of t { (# a,b #) -> 
105         case ... of
106           True -> f x
107           False -> 0 }
108
109 We must not replace (f x) by t, because t is an unboxed-tuple binder.
110 Instead, we shoudl replace (f x) by (# a,b #).  That is, the "reverse mapping" is
111         f x --> (# a,b #)
112 That is why the CSEMap has pairs of expressions.
113
114 Note [CSE for INLINE and NOINLINE]
115 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
116 We are careful to do no CSE inside functions that the user has marked as
117 INLINE or NOINLINE.  In terms of Core, that means 
118
119         a) we do not do CSE inside (Note InlineMe e)
120
121         b) we do not do CSE on the RHS of a binding b=e
122            unless b's InlinePragma is AlwaysActive
123
124 Here's why (examples from Roman Leshchinskiy).  Consider
125
126         yes :: Int
127         {-# NOINLINE yes #-}
128         yes = undefined
129
130         no :: Int
131         {-# NOINLINE no #-}
132         no = undefined
133
134         foo :: Int -> Int -> Int
135         {-# NOINLINE foo #-}
136         foo m n = n
137
138         {-# RULES "foo/no" foo no = id #-}
139
140         bar :: Int -> Int
141         bar = foo yes
142
143 We do not expect the rule to fire.  But if we do CSE, then we get
144 yes=no, and the rule does fire.  Worse, whether we get yes=no or
145 no=yes depends on the order of the definitions.
146
147 In general, CSE should probably never touch things with INLINE pragmas
148 as this could lead to surprising results.  Consider
149
150         {-# INLINE foo #-}
151         foo = <rhs>
152
153         {-# NOINLINE bar #-}
154         bar = <rhs>     -- Same rhs as foo
155
156 If CSE produces
157         foo = bar
158 then foo will never be inlined (when it should be); but if it produces
159         bar = foo
160 bar will be inlined (when it should not be). Even if we remove INLINE foo,
161 we'd still like foo to be inlined if rhs is small. This won't happen
162 with foo = bar.
163
164 Not CSE-ing inside INLINE also solves an annoying bug in CSE. Consider
165 a worker/wrapper, in which the worker has turned into a single variable:
166         $wf = h
167         f = \x -> ...$wf...
168 Now CSE may transform to
169         f = \x -> ...h...
170 But the WorkerInfo for f still says $wf, which is now dead!  This won't
171 happen now that we don't look inside INLINEs (which wrappers are).
172
173
174 %************************************************************************
175 %*                                                                      *
176 \section{Common subexpression}
177 %*                                                                      *
178 %************************************************************************
179
180 \begin{code}
181 cseProgram :: DynFlags -> [CoreBind] -> IO [CoreBind]
182
183 cseProgram dflags binds
184   = do {
185         showPass dflags "Common sub-expression";
186         let { binds' = cseBinds emptyCSEnv binds };
187         endPass dflags "Common sub-expression"  Opt_D_dump_cse binds'   
188     }
189
190 cseBinds :: CSEnv -> [CoreBind] -> [CoreBind]
191 cseBinds _   []     = []
192 cseBinds env (b:bs) = (b':bs')
193                     where
194                       (env1, b') = cseBind  env  b
195                       bs'        = cseBinds env1 bs
196
197 cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind)
198 cseBind env (NonRec b e) = let (env', (b',e')) = do_one env (b, e)
199                            in (env', NonRec b' e')
200 cseBind env (Rec pairs)  = let (env', pairs') = mapAccumL do_one env pairs
201                            in (env', Rec pairs')
202                          
203
204 do_one :: CSEnv -> (Id, CoreExpr) -> (CSEnv, (Id, CoreExpr))
205 do_one env (id, rhs) 
206   = case lookupCSEnv env rhs' of
207         Just (Var other_id) -> (extendSubst env' id other_id,     (id', Var other_id))
208         Just other_expr     -> (env',                             (id', other_expr))
209         Nothing             -> (addCSEnvItem env' rhs' (Var id'), (id', rhs'))
210   where
211     (env', id') = addBinder env id
212     rhs' | isAlwaysActive (idInlinePragma id) = cseExpr env' rhs
213          | otherwise                          = rhs
214                 -- See Note [CSE for INLINE and NOINLINE]
215
216 tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
217 tryForCSE _   (Type t) = Type t
218 tryForCSE env expr     = case lookupCSEnv env expr' of
219                             Just smaller_expr -> smaller_expr
220                             Nothing           -> expr'
221                        where
222                          expr' = cseExpr env expr
223
224 cseExpr :: CSEnv -> CoreExpr -> CoreExpr
225 cseExpr _   (Type t)               = Type t
226 cseExpr _   (Lit lit)              = Lit lit
227 cseExpr env (Var v)                = Var (lookupSubst env v)
228 cseExpr env (App f a)              = App (cseExpr env f) (tryForCSE env a)
229 cseExpr _   (Note InlineMe e)      = Note InlineMe e    -- See Note [CSE for INLINE and NOINLINE]
230 cseExpr env (Note n e)             = Note n (cseExpr env e)
231 cseExpr env (Cast e co)            = Cast (cseExpr env e) co
232 cseExpr env (Lam b e)              = let (env', b') = addBinder env b
233                                      in Lam b' (cseExpr env' e)
234 cseExpr env (Let bind e)           = let (env', bind') = cseBind env bind
235                                      in Let bind' (cseExpr env' e)
236 cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr'' ty (cseAlts env' scrut' bndr bndr'' alts)
237                                    where
238                                      scrut' = tryForCSE env scrut
239                                      (env', bndr') = addBinder env bndr
240                                      bndr'' = zapIdOccInfo bndr'
241                                         -- The swizzling from Note [Case binders 2] may
242                                         -- cause a dead case binder to be alive, so we
243                                         -- play safe here and bring them all to life
244
245 cseAlts :: CSEnv -> CoreExpr -> CoreBndr -> CoreBndr -> [CoreAlt] -> [CoreAlt]
246
247 cseAlts env scrut' bndr _bndr' [(DataAlt con, args, rhs)]
248   | isUnboxedTupleCon con
249         -- Unboxed tuples are special because the case binder isn't
250         -- a real values.  See Note [Unboxed tuple case binders]
251   = [(DataAlt con, args'', tryForCSE new_env rhs)]
252   where
253     (env', args') = addBinders env args
254     args'' = map zapIdOccInfo args'     -- They should all be ids
255         -- Same motivation for zapping as [Case binders 2] only this time
256         -- it's Note [Unboxed tuple case binders]
257     new_env | exprIsCheap scrut' = env'
258             | otherwise          = extendCSEnv env' scrut' tup_value
259     tup_value = mkAltExpr (DataAlt con) args'' (tyConAppArgs (idType bndr))
260
261 cseAlts env scrut' bndr bndr' alts
262   = map cse_alt alts
263   where
264     (con_target, alt_env)
265         = case scrut' of
266                 Var v' -> (v',     extendSubst env bndr v')     -- See Note [Case binders 1]
267                                                                 -- map: bndr -> v'
268
269                 _      ->  (bndr', extendCSEnv env scrut' (Var  bndr')) -- See Note [Case binders 2]
270                                                                         -- map: scrut' -> bndr'
271
272     arg_tys = tyConAppArgs (idType bndr)
273
274     cse_alt (DataAlt con, args, rhs)
275         | not (null args)
276                 -- Don't try CSE if there are no args; it just increases the number
277                 -- of live vars.  E.g.
278                 --      case x of { True -> ....True.... }
279                 -- Don't replace True by x!  
280                 -- Hence the 'null args', which also deal with literals and DEFAULT
281         = (DataAlt con, args', tryForCSE new_env rhs)
282         where
283           (env', args') = addBinders alt_env args
284           new_env       = extendCSEnv env' (mkAltExpr (DataAlt con) args' arg_tys)
285                                            (Var con_target)
286
287     cse_alt (con, args, rhs)
288         = (con, args', tryForCSE env' rhs)
289         where
290           (env', args') = addBinders alt_env args
291 \end{code}
292
293
294 %************************************************************************
295 %*                                                                      *
296 \section{The CSE envt}
297 %*                                                                      *
298 %************************************************************************
299
300 \begin{code}
301 data CSEnv = CS CSEMap InScopeSet (IdEnv Id)
302                         -- Simple substitution
303
304 type CSEMap = UniqFM [(CoreExpr, CoreExpr)]     -- This is the reverse mapping
305         -- It maps the hash-code of an expression e to list of (e,e') pairs
306         -- This means that it's good to replace e by e'
307         -- INVARIANT: The expr in the range has already been CSE'd
308
309 emptyCSEnv :: CSEnv
310 emptyCSEnv = CS emptyUFM emptyInScopeSet emptyVarEnv
311
312 lookupCSEnv :: CSEnv -> CoreExpr -> Maybe CoreExpr
313 lookupCSEnv (CS cs _ _) expr
314   = case lookupUFM cs (hashExpr expr) of
315         Nothing -> Nothing
316         Just pairs -> lookup_list pairs expr
317
318 lookup_list :: [(CoreExpr,CoreExpr)] -> CoreExpr -> Maybe CoreExpr
319 lookup_list [] _ = Nothing
320 lookup_list ((e,e'):es) expr | cheapEqExpr e expr = Just e'
321                              | otherwise          = lookup_list es expr
322
323 addCSEnvItem :: CSEnv -> CoreExpr -> CoreExpr -> CSEnv
324 addCSEnvItem env expr expr' | exprIsBig expr = env
325                             | otherwise      = extendCSEnv env expr expr'
326    -- We don't try to CSE big expressions, because they are expensive to compare
327    -- (and are unlikely to be the same anyway)
328
329 extendCSEnv :: CSEnv -> CoreExpr -> CoreExpr -> CSEnv
330 extendCSEnv (CS cs in_scope sub) expr expr'
331   = CS (addToUFM_C combine cs hash [(expr, expr')]) in_scope sub
332   where
333     hash = hashExpr expr
334     combine old new 
335         = WARN( result `lengthExceeds` 4, short_msg $$ nest 2 long_msg ) result
336         where
337           result = new ++ old
338           short_msg = ptext (sLit "extendCSEnv: long list, length") <+> int (length result)
339           long_msg | opt_PprStyle_Debug = (text "hash code" <+> text (show hash)) $$ ppr result 
340                    | otherwise          = empty
341
342 lookupSubst :: CSEnv -> Id -> Id
343 lookupSubst (CS _ _ sub) x = case lookupVarEnv sub x of
344                                Just y  -> y
345                                Nothing -> x
346
347 extendSubst :: CSEnv -> Id  -> Id -> CSEnv
348 extendSubst (CS cs in_scope sub) x y = CS cs in_scope (extendVarEnv sub x y)
349
350 addBinder :: CSEnv -> Id -> (CSEnv, Id)
351 addBinder (CS cs in_scope sub) v
352   | not (v `elemInScopeSet` in_scope) = (CS cs (extendInScopeSet in_scope v)  sub,                     v)
353   | isIdVar v                         = (CS cs (extendInScopeSet in_scope v') (extendVarEnv sub v v'), v')
354   | otherwise                         = WARN( True, ppr v )
355                                         (CS emptyUFM in_scope                 sub,                     v)
356         -- This last case is the unusual situation where we have shadowing of
357         -- a type variable; we have to discard the CSE mapping
358         -- See "IMPORTANT NOTE" at the top 
359   where
360     v' = uniqAway in_scope v
361
362 addBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
363 addBinders env vs = mapAccumL addBinder env vs
364 \end{code}