1 {-
2 (c) The AQUA Project, Glasgow University, 1993-1998
4 \section{Common subexpression}
5 -}
7 {-# LANGUAGE CPP #-}
9 module CSE (cseProgram, cseOneExpr) where
11 #include "HsVersions.h"
13 import GhcPrelude
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 )
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.
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.
53 So we carry an extra var->var substitution which we apply *before* looking up in the
54 reverse mapping.
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 ...
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.
70 Note [CSE for bindings]
71 ~~~~~~~~~~~~~~~~~~~~~~~
72 Let-bindings have two cases, implemented by addBinding.
74 * SUBSTITUTE: applies when the RHS is a variable
76 let x = y in ...(h x)....
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'
83 How can we have a variable on the RHS? Doesn't the simplifier inline them?
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.
95 - Second, we use addBinding for case expression scrutinees too;
96 see Note [CSE for case expressions]
98 * EXTEND THE REVERSE MAPPING: applies in all other cases
100 let x = h y in ...(h y)...
102 Here we want to extend the /reverse mapping (cs_map)/ so that
103 we CSE the (h y) call to x.
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.
113 See also Note [Corner case for case expressions] for another
114 reason not to use SUBSTITUTE for all trivial expressions.
116 Notice that
117 - The SUBSTITUTE situation extends the substitution (cs_subst)
118 - The EXTEND situation extends the reverse mapping (cs_map)
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.
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.
139 For example:
141 * Trivial scrutinee
142 f = \x -> case x of wild {
143 (a:as) -> case a of wild1 {
144 (p,q) -> ...(wild1:as)...
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.
151 By using addBinding we add the binding (wild1 -> a) to the substitution,
152 which does exactly the right thing.
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'.)
157 This is the main reason that addBinding is called with a trivial rhs.
159 * Non-trivial scrutinee
160 case (f x) of y { pat -> ...let z = f x in ... }
162 By using addBinding we'll add (f x :-> y) to the cs_map, and
163 thereby CSE the inner (f x) to y.
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
171 yes :: Int {-# NOINLINE yes #-}
172 yes = undefined
174 no :: Int {-# NOINLINE no #-}
175 no = undefined
177 foo :: Int -> Int -> Int {-# NOINLINE foo #-}
178 foo m n = n
180 {-# RULES "foo/no" foo no = id #-}
182 bar :: Int -> Int
183 bar = foo yes
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).
191 But we do need to take care. Consider
193 {-# NOINLINE bar #-}
194 bar = <rhs> -- Same rhs as foo
196 foo = <rhs>
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:
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>.
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.
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.
219 Note [CSE for stable unfoldings]
220 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
221 Consider
222 {-# Unf = Stable (\pq. build blah) #-}
223 foo = x
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].
233 Nor do we want to change the reverse mapping. Suppose we have
235 {-# Unf = Stable (\pq. build blah) #-}
236 foo = <expr>
237 bar = <expr>
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.
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.
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) { ... }
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.
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)
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).
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)
278 Note [Look inside join-point binders]
279 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
280 Another way how CSE for joint points is tricky is
282 let join foo x = (x, 42)
283 join bar x = (x, 42)
284 in … jump foo 1 … jump bar 2
286 naively, CSE would turn this into
288 let join foo x = (x, 42)
289 join bar = foo
290 in … jump foo 1 … jump bar 2
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).
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.
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:
308 * Maintain a separate cs_rec_map, that maps
309 (\f. (\x. ...f...) ) -> f
310 Note the \f in the domain of the mapping!
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
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.
320 ************************************************************************
321 * *
322 \section{Common subexpression}
323 * *
324 ************************************************************************
325 -}
327 cseProgram :: CoreProgram -> CoreProgram
328 cseProgram binds = snd (mapAccumL (cseBind TopLevel) emptyCSEnv binds)
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
337 cseBind toplevel env (Rec [(in_id, rhs)])
338 | noCSE in_id
339 = (env1, Rec [(out_id, rhs')])
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')
348 | otherwise
349 = (extendCSRecEnv env1 out_id rhs'' id_expr', Rec [(zapped_id, rhs')])
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
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)
365 do_one env (pr, b1) = cse_bind toplevel env pr b1
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))
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))
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'
393 delayInlining :: TopLevelFlag -> Id -> Id
394 -- Add a NOINLINE 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
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
429 -- Should we use SUBSTITUTE or EXTEND?
430 -- See Note [CSE for bindings]
431 use_subst = case rhs' of
432 Var {} -> True
433 _ -> False
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?]
447 {- Note [Take care with literal strings]
448 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
449 Consider this example:
451 x = "foo"#
452 y = "foo"#
453 ...x...y...x...y....
455 We would normally turn this into:
457 x = "foo"#
458 y = x
459 ...x...x...x...x....
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.
465 For this reason, we special case top-level bindings to literal strings and leave
466 the original RHS unmodified. This produces:
468 x = "foo"#
469 y = "foo"#
470 ...x...x...x...x....
472 Now 'y' will be discarded as dead code, and we are done.
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
478 This is done by cse_bind. I got it wrong the first time (Trac #13367).
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) ....
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 #-}
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!
497 Solution: during CSE, when adding a top-level
498 g = f
499 binding after a "hit" in the CSE cache, add a NOINLINE activation
500 to it, to ensure it's not inlined right away.
502 Why top level only? Because for nested bindings we are already past
503 phase 2 and will never return there.
504 -}
506 tryForCSE :: CSEnv -> InExpr -> OutExpr
507 tryForCSE env expr = snd (try_for_cse env expr)
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.
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)) }
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
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
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]
570 con_target :: OutExpr
571 con_target = lookupSubst alt_env bndr
573 arg_tys :: [OutType]
574 arg_tys = tyConAppArgs (idType bndr3)
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
591 cse_alt (con, args, rhs)
592 = (con, args', tryForCSE env' rhs)
593 where
594 (env', args') = addBinders alt_env args
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)
607 combineAlts _ alts = alts -- Default case
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
615 DEFAULT -> e1
616 K x -> e1
617 W y z -> e2
618 ===>
619 DEFAULT -> e1
620 W y z -> e2
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.
628 I acutally saw some examples in the wild, where some inlining made e1 too
629 big for cheapEqExpr to catch it.
632 ************************************************************************
633 * *
634 \section{The CSE envt}
635 * *
636 ************************************************************************
637 -}
639 data CSEnv
640 = CS { cs_subst :: Subst -- Maps InBndrs to OutExprs
641 -- The substitution variables to
642 -- /trivial/ OutExprs, not arbitrary expressions
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
648 , cs_rec_map :: CoreMap OutExpr
649 -- See Note [CSE for recursive bindings]
650 }
652 emptyCSEnv :: CSEnv
653 emptyCSEnv = CS { cs_map = emptyCoreMap, cs_rec_map = emptyCoreMap
654 , cs_subst = emptySubst }
656 lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr
657 lookupCSEnv (CS { cs_map = csmap }) expr
658 = lookupCoreMap csmap expr
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
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 }
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)
676 csEnvSubst :: CSEnv -> Subst
677 csEnvSubst = cs_subst
679 lookupSubst :: CSEnv -> Id -> OutExpr
680 lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst (text "CSE.lookupSubst") sub x
682 extendCSSubst :: CSEnv -> Id -> CoreExpr -> CSEnv
683 extendCSSubst cse x rhs = cse { cs_subst = extendSubst (cs_subst cse) x rhs }
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
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
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