96fbd0745450c17748eeacaa944b138fbdb75048
[ghc.git] / compiler / simplCore / CSE.hs
1 {-
2 (c) The AQUA Project, Glasgow University, 1993-1998
3
4 \section{Common subexpression}
5 -}
6
7 {-# LANGUAGE CPP #-}
8
9 module CSE (cseProgram, cseOneExpr) where
10
11 #include "HsVersions.h"
12
13 import GhcPrelude
14
15 import CoreSubst
16 import Var ( Var )
17 import VarEnv ( elemInScopeSet, mkInScopeSet )
18 import Id ( Id, idType, isDeadBinder
19 , idInlineActivation, setInlineActivation
20 , zapIdOccInfo, zapIdUsageInfo, idInlinePragma
21 , isJoinId, isJoinId_maybe )
22 import CoreUtils ( mkAltExpr, eqExpr
23 , exprIsTickedString
24 , stripTicksE, stripTicksT, mkTicks )
25 import CoreFVs ( exprFreeVars )
26 import Type ( tyConAppArgs )
27 import CoreSyn
28 import Outputable
29 import BasicTypes
30 import CoreMap
31 import Util ( filterOut )
32 import Data.List ( mapAccumL )
33
34 {-
35 Simple common sub-expression
36 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
37 When we see
38 x1 = C a b
39 x2 = C x1 b
40 we build up a reverse mapping: C a b -> x1
41 C x1 b -> x2
42 and apply that to the rest of the program.
43
44 When we then see
45 y1 = C a b
46 y2 = C y1 b
47 we replace the C a b with x1. But then we *dont* want to
48 add x1 -> y1 to the mapping. Rather, we want the reverse, y1 -> x1
49 so that a subsequent binding
50 y2 = C y1 b
51 will get transformed to C x1 b, and then to x2.
52
53 So we carry an extra var->var substitution which we apply *before* looking up in the
54 reverse mapping.
55
56
57 Note [Shadowing]
58 ~~~~~~~~~~~~~~~~
59 We have to be careful about shadowing.
60 For example, consider
61 f = \x -> let y = x+x in
62 h = \x -> x+x
63 in ...
64
65 Here we must *not* do CSE on the inner x+x! The simplifier used to guarantee no
66 shadowing, but it doesn't any more (it proved too hard), so we clone as we go.
67 We can simply add clones to the substitution already described.
68
69
70 Note [CSE for bindings]
71 ~~~~~~~~~~~~~~~~~~~~~~~
72 Let-bindings have two cases, implemented by addBinding.
73
74 * SUBSTITUTE: applies when the RHS is a variable
75
76 let x = y in ...(h x)....
77
78 Here we want to extend the /substitution/ with x -> y, so that the
79 (h x) in the body might CSE with an enclosing (let v = h y in ...).
80 NB: the substitution maps InIds, so we extend the substitution with
81 a binding for the original InId 'x'
82
83 How can we have a variable on the RHS? Doesn't the simplifier inline them?
84
85 - First, the original RHS might have been (g z) which has CSE'd
86 with an enclosing (let y = g z in ...). This is super-important.
87 See Trac #5996:
88 x1 = C a b
89 x2 = C x1 b
90 y1 = C a b
91 y2 = C y1 b
92 Here we CSE y1's rhs to 'x1', and then we must add (y1->x1) to
93 the substitution so that we can CSE the binding for y2.
94
95 - Second, we use addBinding for case expression scrutinees too;
96 see Note [CSE for case expressions]
97
98 * EXTEND THE REVERSE MAPPING: applies in all other cases
99
100 let x = h y in ...(h y)...
101
102 Here we want to extend the /reverse mapping (cs_map)/ so that
103 we CSE the (h y) call to x.
104
105 Note that we use EXTEND even for a trivial expression, provided it
106 is not a variable or literal. In particular this /includes/ type
107 applications. This can be important (Trac #13156); e.g.
108 case f @ Int of { r1 ->
109 case f @ Int of { r2 -> ...
110 Here we want to common-up the two uses of (f @ Int) so we can
111 remove one of the case expressions.
112
113 See also Note [Corner case for case expressions] for another
114 reason not to use SUBSTITUTE for all trivial expressions.
115
116 Notice that
117 - The SUBSTITUTE situation extends the substitution (cs_subst)
118 - The EXTEND situation extends the reverse mapping (cs_map)
119
120 Notice also that in the SUBSTITUTE case we leave behind a binding
121 x = y
122 even though we /also/ carry a substitution x -> y. Can we just drop
123 the binding instead? Well, not at top level! See SimplUtils
124 Note [Top level and postInlineUnconditionally]; and in any case CSE
125 applies only to the /bindings/ of the program, and we leave it to the
126 simplifier to propate effects to the RULES. Finally, it doesn't seem
127 worth the effort to discard the nested bindings because the simplifier
128 will do it next.
129
130 Note [CSE for case expressions]
131 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
132 Consider
133 case scrut_expr of x { ...alts... }
134 This is very like a strict let-binding
135 let !x = scrut_expr in ...
136 So we use (addBinding x scrut_expr) to process scrut_expr and x, and as a
137 result all the stuff under Note [CSE for bindings] applies directly.
138
139 For example:
140
141 * Trivial scrutinee
142 f = \x -> case x of wild {
143 (a:as) -> case a of wild1 {
144 (p,q) -> ...(wild1:as)...
145
146 Here, (wild1:as) is morally the same as (a:as) and hence equal to
147 wild. But that's not quite obvious. In the rest of the compiler we
148 want to keep it as (wild1:as), but for CSE purpose that's a bad
149 idea.
150
151 By using addBinding we add the binding (wild1 -> a) to the substitution,
152 which does exactly the right thing.
153
154 (Notice this is exactly backwards to what the simplifier does, which
155 is to try to replaces uses of 'a' with uses of 'wild1'.)
156
157 This is the main reason that addBinding is called with a trivial rhs.
158
159 * Non-trivial scrutinee
160 case (f x) of y { pat -> ...let z = f x in ... }
161
162 By using addBinding we'll add (f x :-> y) to the cs_map, and
163 thereby CSE the inner (f x) to y.
164
165 Note [CSE for INLINE and NOINLINE]
166 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
167 There are some subtle interactions of CSE with functions that the user
168 has marked as INLINE or NOINLINE. (Examples from Roman Leshchinskiy.)
169 Consider
170
171 yes :: Int {-# NOINLINE yes #-}
172 yes = undefined
173
174 no :: Int {-# NOINLINE no #-}
175 no = undefined
176
177 foo :: Int -> Int -> Int {-# NOINLINE foo #-}
178 foo m n = n
179
180 {-# RULES "foo/no" foo no = id #-}
181
182 bar :: Int -> Int
183 bar = foo yes
184
185 We do not expect the rule to fire. But if we do CSE, then we risk
186 getting yes=no, and the rule does fire. Actually, it won't because
187 NOINLINE means that 'yes' will never be inlined, not even if we have
188 yes=no. So that's fine (now; perhaps in the olden days, yes=no would
189 have substituted even if 'yes' was NOINLINE).
190
191 But we do need to take care. Consider
192
193 {-# NOINLINE bar #-}
194 bar = <rhs> -- Same rhs as foo
195
196 foo = <rhs>
197
198 If CSE produces
199 foo = bar
200 then foo will never be inlined to <rhs> (when it should be, if <rhs>
201 is small). The conclusion here is this:
202
203 We should not add
204 <rhs> :-> bar
205 to the CSEnv if 'bar' has any constraints on when it can inline;
206 that is, if its 'activation' not always active. Otherwise we
207 might replace <rhs> by 'bar', and then later be unable to see that it
208 really was <rhs>.
209
210 An except to the rule is when the INLINE pragma is not from the user, e.g. from
211 WorkWrap (see Note [Wrapper activation]). We can tell because noUserInlineSpec
212 is then true.
213
214 Note that we do not (currently) do CSE on the unfolding stored inside
215 an Id, even if it is a 'stable' unfolding. That means that when an
216 unfolding happens, it is always faithful to what the stable unfolding
217 originally was.
218
219 Note [CSE for stable unfoldings]
220 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
221 Consider
222 {-# Unf = Stable (\pq. build blah) #-}
223 foo = x
224
225 Here 'foo' has a stable unfolding, but its (optimised) RHS is trivial.
226 (Turns out that this actually happens for the enumFromTo method of
227 the Integer instance of Enum in GHC.Enum.) Suppose moreover that foo's
228 stable unfolding originates from an INLINE or INLINEABLE pragma on foo.
229 Then we obviously do NOT want to extend the substitution with (foo->x),
230 because we promised to inline foo as what the user wrote. See similar
231 SimplUtils Note [Stable unfoldings and postInlineUnconditionally].
232
233 Nor do we want to change the reverse mapping. Suppose we have
234
235 {-# Unf = Stable (\pq. build blah) #-}
236 foo = <expr>
237 bar = <expr>
238
239 There could conceivably be merit in rewriting the RHS of bar:
240 bar = foo
241 but now bar's inlining behaviour will change, and importing
242 modules might see that. So it seems dodgy and we don't do it.
243
244 Stable unfoldings are also created during worker/wrapper when we decide
245 that a function's definition is so small that it should always inline.
246 In this case we still want to do CSE (#13340). Hence the use of
247 isAnyInlinePragma rather than isStableUnfolding.
248
249 Note [Corner case for case expressions]
250 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
251 Here is another reason that we do not use SUBSTITUTE for
252 all trivial expressions. Consider
253 case x |> co of (y::Array# Int) { ... }
254
255 We do not want to extend the substitution with (y -> x |> co); since y
256 is of unlifted type, this would destroy the let/app invariant if (x |>
257 co) was not ok-for-speculation.
258
259 But surely (x |> co) is ok-for-speculation, becasue it's a trivial
260 expression, and x's type is also unlifted, presumably. Well, maybe
261 not if you are using unsafe casts. I actually found a case where we
262 had
263 (x :: HValue) |> (UnsafeCo :: HValue ~ Array# Int)
264
265 Note [CSE for join points?]
266 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
267 We must not be naive about join points in CSE:
268 join j = e in
269 if b then jump j else 1 + e
270 The expression (1 + jump j) is not good (see Note [Invariants on join points] in
271 CoreSyn). This seems to come up quite seldom, but it happens (first seen
272 compiling ppHtml in Haddock.Backends.Xhtml).
273
274 We could try and be careful by tracking which join points are still valid at
275 each subexpression, but since join points aren't allocated or shared, there's
276 less to gain by trying to CSE them. (#13219)
277
278 Note [Look inside join-point binders]
279 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
280 Another way how CSE for joint points is tricky is
281
282 let join foo x = (x, 42)
283 join bar x = (x, 42)
284 in … jump foo 1 … jump bar 2
285
286 naively, CSE would turn this into
287
288 let join foo x = (x, 42)
289 join bar = foo
290 in … jump foo 1 … jump bar 2
291
292 but now bar is a join point that claims arity one, but its right-hand side
293 is not a lambda, breaking the join-point invariant (this was #15002).
294
295 So `cse_bind` must zoom past the lambdas of a join point (using
296 `collectNBinders`) and resume searching for CSE opportunities only in
297 the body of the join point.
298
299 Note [CSE for recursive bindings]
300 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
301 Consider
302 f = \x ... f....
303 g = \y ... g ...
304 where the "..." are identical. Could we CSE them? In full generality
305 with mutual recursion it's quite hard; but for self-recursive bindings
306 (which are very common) it's rather easy:
307
308 * Maintain a separate cs_rec_map, that maps
309 (\f. (\x. ...f...) ) -> f
310 Note the \f in the domain of the mapping!
311
312 * When we come across the binding for 'g', look up (\g. (\y. ...g...))
313 Bingo we get a hit. So we can replace the 'g' binding with
314 g = f
315
316 We can't use cs_map for this, because the key isn't an expression of
317 the program; it's a kind of synthetic key for recursive bindings.
318
319
320 ************************************************************************
321 * *
322 \section{Common subexpression}
323 * *
324 ************************************************************************
325 -}
326
327 cseProgram :: CoreProgram -> CoreProgram
328 cseProgram binds = snd (mapAccumL (cseBind TopLevel) emptyCSEnv binds)
329
330 cseBind :: TopLevelFlag -> CSEnv -> CoreBind -> (CSEnv, CoreBind)
331 cseBind toplevel env (NonRec b e)
332 = (env2, NonRec b2 e2)
333 where
334 (env1, b1) = addBinder env b
335 (env2, (b2, e2)) = cse_bind toplevel env1 (b,e) b1
336
337 cseBind toplevel env (Rec [(in_id, rhs)])
338 | noCSE in_id
339 = (env1, Rec [(out_id, rhs')])
340
341 -- See Note [CSE for recursive bindings]
342 | Just previous <- lookupCSRecEnv env out_id rhs''
343 , let previous' = mkTicks ticks previous
344 out_id' = delayInlining toplevel out_id
345 = -- We have a hit in the recursive-binding cache
346 (extendCSSubst env1 in_id previous', NonRec out_id' previous')
347
348 | otherwise
349 = (extendCSRecEnv env1 out_id rhs'' id_expr', Rec [(zapped_id, rhs')])
350
351 where
352 (env1, [out_id]) = addRecBinders env [in_id]
353 rhs' = cseExpr env1 rhs
354 rhs'' = stripTicksE tickishFloatable rhs'
355 ticks = stripTicksT tickishFloatable rhs'
356 id_expr' = varToCoreExpr out_id
357 zapped_id = zapIdUsageInfo out_id
358
359 cseBind toplevel env (Rec pairs)
360 = (env2, Rec pairs')
361 where
362 (env1, bndrs1) = addRecBinders env (map fst pairs)
363 (env2, pairs') = mapAccumL do_one env1 (zip pairs bndrs1)
364
365 do_one env (pr, b1) = cse_bind toplevel env pr b1
366
367 -- | Given a binding of @in_id@ to @in_rhs@, and a fresh name to refer
368 -- to @in_id@ (@out_id@, created from addBinder or addRecBinders),
369 -- first try to CSE @in_rhs@, and then add the resulting (possibly CSE'd)
370 -- binding to the 'CSEnv', so that we attempt to CSE any expressions
371 -- which are equal to @out_rhs@.
372 cse_bind :: TopLevelFlag -> CSEnv -> (InId, InExpr) -> OutId -> (CSEnv, (OutId, OutExpr))
373 cse_bind toplevel env (in_id, in_rhs) out_id
374 | isTopLevel toplevel, exprIsTickedString in_rhs
375 -- See Note [Take care with literal strings]
376 = (env', (out_id', in_rhs))
377
378 | Just arity <- isJoinId_maybe in_id
379 -- See Note [Look inside join-point binders]
380 = let (params, in_body) = collectNBinders arity in_rhs
381 (env', params') = addBinders env params
382 out_body = tryForCSE env' in_body
383 in (env, (out_id, mkLams params' out_body))
384
385 | otherwise
386 = (env', (out_id'', out_rhs))
387 where
388 (env', out_id') = addBinding env in_id out_id out_rhs
389 (cse_done, out_rhs) = try_for_cse env in_rhs
390 out_id'' | cse_done = delayInlining toplevel out_id'
391 | otherwise = out_id'
392
393 delayInlining :: TopLevelFlag -> Id -> Id
394 -- Add a NOINLINE[2] if the Id doesn't have an INLNE pragma already
395 delayInlining top_lvl bndr
396 | isTopLevel top_lvl
397 , isAlwaysActive (idInlineActivation bndr)
398 = bndr `setInlineActivation` activeAfterInitial
399 | otherwise
400 = bndr
401
402 addBinding :: CSEnv -- Includes InId->OutId cloning
403 -> InVar -- Could be a let-bound type
404 -> OutId -> OutExpr -- Processed binding
405 -> (CSEnv, OutId) -- Final env, final bndr
406 -- Extend the CSE env with a mapping [rhs -> out-id]
407 -- unless we can instead just substitute [in-id -> rhs]
408 --
409 -- It's possible for the binder to be a type variable (see
410 -- Note [Type-let] in CoreSyn), in which case we can just substitute.
411 addBinding env in_id out_id rhs'
412 | not (isId in_id) = (extendCSSubst env in_id rhs', out_id)
413 | noCSE in_id = (env, out_id)
414 | use_subst = (extendCSSubst env in_id rhs', out_id)
415 | otherwise = (extendCSEnv env rhs' id_expr', zapped_id)
416 where
417 id_expr' = varToCoreExpr out_id
418 zapped_id = zapIdUsageInfo out_id
419 -- Putting the Id into the cs_map makes it possible that
420 -- it'll become shared more than it is now, which would
421 -- invalidate (the usage part of) its demand info.
422 -- This caused Trac #100218.
423 -- Easiest thing is to zap the usage info; subsequently
424 -- performing late demand-analysis will restore it. Don't zap
425 -- the strictness info; it's not necessary to do so, and losing
426 -- it is bad for performance if you don't do late demand
427 -- analysis
428
429 -- Should we use SUBSTITUTE or EXTEND?
430 -- See Note [CSE for bindings]
431 use_subst = case rhs' of
432 Var {} -> True
433 _ -> False
434
435 -- | Given a binder `let x = e`, this function
436 -- determines whether we should add `e -> x` to the cs_map
437 noCSE :: InId -> Bool
438 noCSE id = not (isAlwaysActive (idInlineActivation id)) &&
439 not (noUserInlineSpec (inlinePragmaSpec (idInlinePragma id)))
440 -- See Note [CSE for INLINE and NOINLINE]
441 || isAnyInlinePragma (idInlinePragma id)
442 -- See Note [CSE for stable unfoldings]
443 || isJoinId id
444 -- See Note [CSE for join points?]
445
446
447 {- Note [Take care with literal strings]
448 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
449 Consider this example:
450
451 x = "foo"#
452 y = "foo"#
453 ...x...y...x...y....
454
455 We would normally turn this into:
456
457 x = "foo"#
458 y = x
459 ...x...x...x...x....
460
461 But this breaks an invariant of Core, namely that the RHS of a top-level binding
462 of type Addr# must be a string literal, not another variable. See Note
463 [CoreSyn top-level string literals] in CoreSyn.
464
465 For this reason, we special case top-level bindings to literal strings and leave
466 the original RHS unmodified. This produces:
467
468 x = "foo"#
469 y = "foo"#
470 ...x...x...x...x....
471
472 Now 'y' will be discarded as dead code, and we are done.
473
474 The net effect is that for the y-binding we want to
475 - Use SUBSTITUTE, by extending the substitution with y :-> x
476 - but leave the original binding for y undisturbed
477
478 This is done by cse_bind. I got it wrong the first time (Trac #13367).
479
480 Note [Delay inlining after CSE]
481 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
482 Suppose (Trac #15445) we have
483 f,g :: Num a => a -> a
484 f x = ...f (x-1).....
485 g y = ...g (y-1) ....
486
487 and we make some specialisations of 'g', either automatically, or via
488 a SPECIALISE pragma. Then CSE kicks in and notices that the RHSs of
489 'f' and 'g' are identical, so we get
490 f x = ...f (x-1)...
491 g = f
492 {-# RULES g @Int _ = $sg #-}
493
494 Now there is terrible danger that, in an importing module, we'll inline
495 'g' before we have a chance to run its specialisation!
496
497 Solution: during CSE, when adding a top-level
498 g = f
499 binding after a "hit" in the CSE cache, add a NOINLINE[2] activation
500 to it, to ensure it's not inlined right away.
501
502 Why top level only? Because for nested bindings we are already past
503 phase 2 and will never return there.
504 -}
505
506 tryForCSE :: CSEnv -> InExpr -> OutExpr
507 tryForCSE env expr = snd (try_for_cse env expr)
508
509 try_for_cse :: CSEnv -> InExpr -> (Bool, OutExpr)
510 -- (False, e') => We did not CSE the entire expression,
511 -- but we might have CSE'd some sub-expressions,
512 -- yielding e'
513 --
514 -- (True, te') => We CSE'd the entire expression,
515 -- yielding the trivial expression te'
516 try_for_cse env expr
517 | Just e <- lookupCSEnv env expr'' = (True, mkTicks ticks e)
518 | otherwise = (False, expr')
519 -- The varToCoreExpr is needed if we have
520 -- case e of xco { ...case e of yco { ... } ... }
521 -- Then CSE will substitute yco -> xco;
522 -- but these are /coercion/ variables
523 where
524 expr' = cseExpr env expr
525 expr'' = stripTicksE tickishFloatable expr'
526 ticks = stripTicksT tickishFloatable expr'
527 -- We don't want to lose the source notes when a common sub
528 -- expression gets eliminated. Hence we push all (!) of them on
529 -- top of the replaced sub-expression. This is probably not too
530 -- useful in practice, but upholds our semantics.
531
532 -- | Runs CSE on a single expression.
533 --
534 -- This entry point is not used in the compiler itself, but is provided
535 -- as a convenient entry point for users of the GHC API.
536 cseOneExpr :: InExpr -> OutExpr
537 cseOneExpr e = cseExpr env e
538 where env = emptyCSEnv {cs_subst = mkEmptySubst (mkInScopeSet (exprFreeVars e)) }
539
540 cseExpr :: CSEnv -> InExpr -> OutExpr
541 cseExpr env (Type t) = Type (substTy (csEnvSubst env) t)
542 cseExpr env (Coercion c) = Coercion (substCo (csEnvSubst env) c)
543 cseExpr _ (Lit lit) = Lit lit
544 cseExpr env (Var v) = lookupSubst env v
545 cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a)
546 cseExpr env (Tick t e) = Tick t (cseExpr env e)
547 cseExpr env (Cast e co) = Cast (tryForCSE env e) (substCo (csEnvSubst env) co)
548 cseExpr env (Lam b e) = let (env', b') = addBinder env b
549 in Lam b' (cseExpr env' e)
550 cseExpr env (Let bind e) = let (env', bind') = cseBind NotTopLevel env bind
551 in Let bind' (cseExpr env' e)
552 cseExpr env (Case e bndr ty alts) = cseCase env e bndr ty alts
553
554 cseCase :: CSEnv -> InExpr -> InId -> InType -> [InAlt] -> OutExpr
555 cseCase env scrut bndr ty alts
556 = Case scrut1 bndr3 ty' $
557 combineAlts alt_env (map cse_alt alts)
558 where
559 ty' = substTy (csEnvSubst env) ty
560 scrut1 = tryForCSE env scrut
561
562 bndr1 = zapIdOccInfo bndr
563 -- Zapping the OccInfo is needed because the extendCSEnv
564 -- in cse_alt may mean that a dead case binder
565 -- becomes alive, and Lint rejects that
566 (env1, bndr2) = addBinder env bndr1
567 (alt_env, bndr3) = addBinding env1 bndr bndr2 scrut1
568 -- addBinding: see Note [CSE for case expressions]
569
570 con_target :: OutExpr
571 con_target = lookupSubst alt_env bndr
572
573 arg_tys :: [OutType]
574 arg_tys = tyConAppArgs (idType bndr3)
575
576 -- Given case x of { K y z -> ...K y z... }
577 -- CSE K y z into x...
578 cse_alt (DataAlt con, args, rhs)
579 | not (null args)
580 -- ... but don't try CSE if there are no args; it just increases the number
581 -- of live vars. E.g.
582 -- case x of { True -> ....True.... }
583 -- Don't replace True by x!
584 -- Hence the 'null args', which also deal with literals and DEFAULT
585 = (DataAlt con, args', tryForCSE new_env rhs)
586 where
587 (env', args') = addBinders alt_env args
588 new_env = extendCSEnv env' con_expr con_target
589 con_expr = mkAltExpr (DataAlt con) args' arg_tys
590
591 cse_alt (con, args, rhs)
592 = (con, args', tryForCSE env' rhs)
593 where
594 (env', args') = addBinders alt_env args
595
596 combineAlts :: CSEnv -> [InAlt] -> [InAlt]
597 -- See Note [Combine case alternatives]
598 combineAlts env ((_,bndrs1,rhs1) : rest_alts)
599 | all isDeadBinder bndrs1
600 = (DEFAULT, [], rhs1) : filtered_alts
601 where
602 in_scope = substInScope (csEnvSubst env)
603 filtered_alts = filterOut identical rest_alts
604 identical (_con, bndrs, rhs) = all ok bndrs && eqExpr in_scope rhs1 rhs
605 ok bndr = isDeadBinder bndr || not (bndr `elemInScopeSet` in_scope)
606
607 combineAlts _ alts = alts -- Default case
608
609 {- Note [Combine case alternatives]
610 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
611 combineAlts is just a more heavyweight version of the use of
612 combineIdenticalAlts in SimplUtils.prepareAlts. The basic idea is
613 to transform
614
615 DEFAULT -> e1
616 K x -> e1
617 W y z -> e2
618 ===>
619 DEFAULT -> e1
620 W y z -> e2
621
622 In the simplifier we use cheapEqExpr, because it is called a lot.
623 But here in CSE we use the full eqExpr. After all, two alternatives usually
624 differ near the root, so it probably isn't expensive to compare the full
625 alternative. It seems like the same kind of thing that CSE is supposed
626 to be doing, which is why I put it here.
627
628 I acutally saw some examples in the wild, where some inlining made e1 too
629 big for cheapEqExpr to catch it.
630
631
632 ************************************************************************
633 * *
634 \section{The CSE envt}
635 * *
636 ************************************************************************
637 -}
638
639 data CSEnv
640 = CS { cs_subst :: Subst -- Maps InBndrs to OutExprs
641 -- The substitution variables to
642 -- /trivial/ OutExprs, not arbitrary expressions
643
644 , cs_map :: CoreMap OutExpr -- The reverse mapping
645 -- Maps a OutExpr to a /trivial/ OutExpr
646 -- The key of cs_map is stripped of all Ticks
647
648 , cs_rec_map :: CoreMap OutExpr
649 -- See Note [CSE for recursive bindings]
650 }
651
652 emptyCSEnv :: CSEnv
653 emptyCSEnv = CS { cs_map = emptyCoreMap, cs_rec_map = emptyCoreMap
654 , cs_subst = emptySubst }
655
656 lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr
657 lookupCSEnv (CS { cs_map = csmap }) expr
658 = lookupCoreMap csmap expr
659
660 extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv
661 extendCSEnv cse expr triv_expr
662 = cse { cs_map = extendCoreMap (cs_map cse) sexpr triv_expr }
663 where
664 sexpr = stripTicksE tickishFloatable expr
665
666 extendCSRecEnv :: CSEnv -> OutId -> OutExpr -> OutExpr -> CSEnv
667 -- See Note [CSE for recursive bindings]
668 extendCSRecEnv cse bndr expr triv_expr
669 = cse { cs_rec_map = extendCoreMap (cs_rec_map cse) (Lam bndr expr) triv_expr }
670
671 lookupCSRecEnv :: CSEnv -> OutId -> OutExpr -> Maybe OutExpr
672 -- See Note [CSE for recursive bindings]
673 lookupCSRecEnv (CS { cs_rec_map = csmap }) bndr expr
674 = lookupCoreMap csmap (Lam bndr expr)
675
676 csEnvSubst :: CSEnv -> Subst
677 csEnvSubst = cs_subst
678
679 lookupSubst :: CSEnv -> Id -> OutExpr
680 lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst (text "CSE.lookupSubst") sub x
681
682 extendCSSubst :: CSEnv -> Id -> CoreExpr -> CSEnv
683 extendCSSubst cse x rhs = cse { cs_subst = extendSubst (cs_subst cse) x rhs }
684
685 -- | Add clones to the substitution to deal with shadowing. See
686 -- Note [Shadowing] for more details. You should call this whenever
687 -- you go under a binder.
688 addBinder :: CSEnv -> Var -> (CSEnv, Var)
689 addBinder cse v = (cse { cs_subst = sub' }, v')
690 where
691 (sub', v') = substBndr (cs_subst cse) v
692
693 addBinders :: CSEnv -> [Var] -> (CSEnv, [Var])
694 addBinders cse vs = (cse { cs_subst = sub' }, vs')
695 where
696 (sub', vs') = substBndrs (cs_subst cse) vs
697
698 addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
699 addRecBinders cse vs = (cse { cs_subst = sub' }, vs')
700 where
701 (sub', vs') = substRecBndrs (cs_subst cse) vs