CSE.hs 22.5 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1
2
3
{-
(c) The AQUA Project, Glasgow University, 1993-1998

4
\section{Common subexpression}
Austin Seipp's avatar
Austin Seipp committed
5
-}
6

7
8
{-# LANGUAGE CPP #-}

Joachim Breitner's avatar
Joachim Breitner committed
9
module CSE (cseProgram, cseOneExpr) where
10
11
12

#include "HsVersions.h"

13
14
import GhcPrelude

15
import CoreSubst
16
import Var              ( Var )
17
import VarEnv           ( elemInScopeSet, mkInScopeSet )
18
import Id               ( Id, idType, idInlineActivation, isDeadBinder
19
20
                        , zapIdOccInfo, zapIdUsageInfo, idInlinePragma
                        , isJoinId )
21
import CoreUtils        ( mkAltExpr, eqExpr
22
                        , exprIsLiteralString
23
                        , stripTicksE, stripTicksT, mkTicks )
24
import CoreFVs          ( exprFreeVars )
Simon Peyton Jones's avatar
Simon Peyton Jones committed
25
import Type             ( tyConAppArgs )
26
27
import CoreSyn
import Outputable
28
import BasicTypes       ( TopLevelFlag(..), isTopLevel
29
30
                        , isAlwaysActive, isAnyInlinePragma,
                          inlinePragmaSpec, noUserInlineSpec )
31
import TrieMap
David Feuer's avatar
David Feuer committed
32
import Util             ( filterOut )
Simon Peyton Jones's avatar
Simon Peyton Jones committed
33
import Data.List        ( mapAccumL )
34

Austin Seipp's avatar
Austin Seipp committed
35
{-
36
37
                        Simple common sub-expression
                        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
38
When we see
39
40
        x1 = C a b
        x2 = C x1 b
41
we build up a reverse mapping:   C a b  -> x1
42
                                 C x1 b -> x2
43
44
45
and apply that to the rest of the program.

When we then see
46
47
        y1 = C a b
        y2 = C y1 b
48
we replace the C a b with x1.  But then we *dont* want to
49
add   x1 -> y1  to the mapping.  Rather, we want the reverse, y1 -> x1
50
so that a subsequent binding
51
52
        y2 = C y1 b
will get transformed to C x1 b, and then to x2.
53

54
So we carry an extra var->var substitution which we apply *before* looking up in the
55
56
57
reverse mapping.


simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
58
59
Note [Shadowing]
~~~~~~~~~~~~~~~~
60
We have to be careful about shadowing.
61
For example, consider
62
63
64
        f = \x -> let y = x+x in
                      h = \x -> x+x
                  in ...
65

66
67
68
69
Here we must *not* do CSE on the inner x+x!  The simplifier used to guarantee no
shadowing, but it doesn't any more (it proved too hard), so we clone as we go.
We can simply add clones to the substitution already described.

70

71
72
Note [CSE for bindings]
~~~~~~~~~~~~~~~~~~~~~~~
Simon Peyton Jones's avatar
Simon Peyton Jones committed
73
74
Let-bindings have two cases, implemented by addBinding.

75
* SUBSTITUTE: applies when the RHS is a variable
76
77
78
79
80
81

     let x = y in ...(h x)....

  Here we want to extend the /substitution/ with x -> y, so that the
  (h x) in the body might CSE with an enclosing (let v = h y in ...).
  NB: the substitution maps InIds, so we extend the substitution with
82
      a binding for the original InId 'x'
83

Simon Peyton Jones's avatar
Simon Peyton Jones committed
84
  How can we have a variable on the RHS? Doesn't the simplifier inline them?
85
86
87
88
89
90
91
92
93
94
95

    - First, the original RHS might have been (g z) which has CSE'd
      with an enclosing (let y = g z in ...).  This is super-important.
      See Trac #5996:
         x1 = C a b
         x2 = C x1 b
         y1 = C a b
         y2 = C y1 b
      Here we CSE y1's rhs to 'x1', and then we must add (y1->x1) to
      the substitution so that we can CSE the binding for y2.

96
    - Second, we use addBinding for case expression scrutinees too;
97
      see Note [CSE for case expressions]
98

Simon Peyton Jones's avatar
Simon Peyton Jones committed
99
100
* EXTEND THE REVERSE MAPPING: applies in all other cases

101
     let x = h y in ...(h y)...
102

103
104
  Here we want to extend the /reverse mapping (cs_map)/ so that
  we CSE the (h y) call to x.
105

Simon Peyton Jones's avatar
Simon Peyton Jones committed
106
107
108
109
110
111
112
113
114
115
116
  Note that we use EXTEND even for a trivial expression, provided it
  is not a variable or literal. In particular this /includes/ type
  applications. This can be important (Trac #13156); e.g.
     case f @ Int of { r1 ->
     case f @ Int of { r2 -> ...
  Here we want to common-up the two uses of (f @ Int) so we can
  remove one of the case expressions.

  See also Note [Corner case for case expressions] for another
  reason not to use SUBSTITUTE for all trivial expressions.

117
Notice that
Simon Peyton Jones's avatar
Simon Peyton Jones committed
118
119
  - The SUBSTITUTE situation extends the substitution (cs_subst)
  - The EXTEND situation extends the reverse mapping (cs_map)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
120

Simon Peyton Jones's avatar
Simon Peyton Jones committed
121
Notice also that in the SUBSTITUTE case we leave behind a binding
Simon Peyton Jones's avatar
Simon Peyton Jones committed
122
123
124
125
126
127
128
129
  x = y
even though we /also/ carry a substitution x -> y.  Can we just drop
the binding instead?  Well, not at top level! See SimplUtils
Note [Top level and postInlineUnconditionally]; and in any case CSE
applies only to the /bindings/ of the program, and we leave it to the
simplifier to propate effects to the RULES.  Finally, it doesn't seem
worth the effort to discard the nested bindings because the simplifier
will do it next.
130
131
132

Note [CSE for case expressions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
133
Consider
134
135
136
  case scrut_expr of x { ...alts... }
This is very like a strict let-binding
  let !x = scrut_expr in ...
Simon Peyton Jones's avatar
Simon Peyton Jones committed
137
So we use (addBinding x scrut_expr) to process scrut_expr and x, and as a
138
139
140
141
142
143
144
145
result all the stuff under Note [CSE for bindings] applies directly.

For example:

* Trivial scrutinee
     f = \x -> case x of wild {
                 (a:as) -> case a of wild1 {
                             (p,q) -> ...(wild1:as)...
146

147
148
149
150
151
  Here, (wild1:as) is morally the same as (a:as) and hence equal to
  wild. But that's not quite obvious.  In the rest of the compiler we
  want to keep it as (wild1:as), but for CSE purpose that's a bad
  idea.

Simon Peyton Jones's avatar
Simon Peyton Jones committed
152
  By using addBinding we add the binding (wild1 -> a) to the substitution,
153
154
155
156
157
  which does exactly the right thing.

  (Notice this is exactly backwards to what the simplifier does, which
  is to try to replaces uses of 'a' with uses of 'wild1'.)

158
  This is the main reason that addBinding is called with a trivial rhs.
159
160

* Non-trivial scrutinee
Edward Z. Yang's avatar
Edward Z. Yang committed
161
     case (f x) of y { pat -> ...let z = f x in ... }
162

Simon Peyton Jones's avatar
Simon Peyton Jones committed
163
  By using addBinding we'll add (f x :-> y) to the cs_map, and
164
  thereby CSE the inner (f x) to y.
165

166
167
Note [CSE for INLINE and NOINLINE]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
168
169
170
There are some subtle interactions of CSE with functions that the user
has marked as INLINE or NOINLINE. (Examples from Roman Leshchinskiy.)
Consider
171

172
        yes :: Int  {-# NOINLINE yes #-}
173
        yes = undefined
174

175
        no :: Int   {-# NOINLINE no #-}
176
        no = undefined
177

178
        foo :: Int -> Int -> Int  {-# NOINLINE foo #-}
179
        foo m n = n
180

181
        {-# RULES "foo/no" foo no = id #-}
182

183
184
        bar :: Int -> Int
        bar = foo yes
185

186
We do not expect the rule to fire.  But if we do CSE, then we risk
Gabor Greif's avatar
Gabor Greif committed
187
getting yes=no, and the rule does fire.  Actually, it won't because
188
NOINLINE means that 'yes' will never be inlined, not even if we have
Gabor Greif's avatar
Gabor Greif committed
189
yes=no.  So that's fine (now; perhaps in the olden days, yes=no would
Simon Peyton Jones's avatar
Simon Peyton Jones committed
190
have substituted even if 'yes' was NOINLINE).
191

192
But we do need to take care.  Consider
193

194
195
        {-# NOINLINE bar #-}
        bar = <rhs>     -- Same rhs as foo
196

197
198
        foo = <rhs>

199
If CSE produces
200
        foo = bar
201
202
203
204
205
206
207
208
209
210
then foo will never be inlined to <rhs> (when it should be, if <rhs>
is small).  The conclusion here is this:

   We should not add
       <rhs> :-> bar
  to the CSEnv if 'bar' has any constraints on when it can inline;
  that is, if its 'activation' not always active.  Otherwise we
  might replace <rhs> by 'bar', and then later be unable to see that it
  really was <rhs>.

211
212
213
214
An except to the rule is when the INLINE pragma is not from the user, e.g. from
WorkWrap (see Note [Wrapper activation]). We can tell because noUserInlineSpec
is then true.

215
Note that we do not (currently) do CSE on the unfolding stored inside
Gabor Greif's avatar
Gabor Greif committed
216
an Id, even if it is a 'stable' unfolding.  That means that when an
217
218
219
unfolding happens, it is always faithful to what the stable unfolding
originally was.

220
221
Note [CSE for stable unfoldings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
222
Consider
223
224
225
226
227
   {-# Unf = Stable (\pq. build blah) #-}
   foo = x

Here 'foo' has a stable unfolding, but its (optimised) RHS is trivial.
(Turns out that this actually happens for the enumFromTo method of
rwbarton's avatar
rwbarton committed
228
229
230
231
the Integer instance of Enum in GHC.Enum.)  Suppose moreover that foo's
stable unfolding originates from an INLINE or INLINEABLE pragma on foo.
Then we obviously do NOT want to extend the substitution with (foo->x),
because we promised to inline foo as what the user wrote.  See similar
232
233
234
235
236
237
238
239
240
241
242
243
244
SimplUtils Note [Stable unfoldings and postInlineUnconditionally].

Nor do we want to change the reverse mapping. Suppose we have

   {-# Unf = Stable (\pq. build blah) #-}
   foo = <expr>
   bar = <expr>

There could conceivably be merit in rewriting the RHS of bar:
   bar = foo
but now bar's inlining behaviour will change, and importing
modules might see that.  So it seems dodgy and we don't do it.

rwbarton's avatar
rwbarton committed
245
246
247
248
249
Stable unfoldings are also created during worker/wrapper when we decide
that a function's definition is so small that it should always inline.
In this case we still want to do CSE (#13340). Hence the use of
isAnyInlinePragma rather than isStableUnfolding.

250
251
Note [Corner case for case expressions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Simon Peyton Jones's avatar
Simon Peyton Jones committed
252
253
Here is another reason that we do not use SUBSTITUTE for
all trivial expressions. Consider
254
255
   case x |> co of (y::Array# Int) { ... }

Simon Peyton Jones's avatar
Simon Peyton Jones committed
256
We do not want to extend the substitution with (y -> x |> co); since y
257
is of unlifted type, this would destroy the let/app invariant if (x |>
Simon Peyton Jones's avatar
Simon Peyton Jones committed
258
co) was not ok-for-speculation.
259

Simon Peyton Jones's avatar
Simon Peyton Jones committed
260
261
262
263
But surely (x |> co) is ok-for-speculation, becasue it's a trivial
expression, and x's type is also unlifted, presumably.  Well, maybe
not if you are using unsafe casts.  I actually found a case where we
had
264
265
   (x :: HValue) |> (UnsafeCo :: HValue ~ Array# Int)

lukemaurer's avatar
lukemaurer committed
266
267
268
269
270
271
272
273
274
275
276
277
Note [CSE for join points?]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
We must not be naive about join points in CSE:
   join j = e in
   if b then jump j else 1 + e
The expression (1 + jump j) is not good (see Note [Invariants on join points] in
CoreSyn). This seems to come up quite seldom, but it happens (first seen
compiling ppHtml in Haddock.Backends.Xhtml).

We could try and be careful by tracking which join points are still valid at
each subexpression, but since join points aren't allocated or shared, there's
less to gain by trying to CSE them.
278

279
280
281
282
283
284
285
286
287
288
289
290
291
292
Note [CSE for recursive bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
  f = \x ... f....
  g = \y ... g ...
where the "..." are identical.  Could we CSE them?  In full generality
with mutual recursion it's quite hard; but for self-recursive bindings
(which are very common) it's rather easy:

* Maintain a separate cs_rec_map, that maps
      (\f. (\x. ...f...) ) -> f
  Note the \f in the domain of the mapping!

* When we come across the binding for 'g', look up (\g. (\y. ...g...))
Ben Gamari's avatar
Ben Gamari committed
293
  Bingo we get a hit.  So we can replace the 'g' binding with
294
295
296
297
298
299
     g = f

We can't use cs_map for this, because the key isn't an expression of
the program; it's a kind of synthetic key for recursive bindings.


Austin Seipp's avatar
Austin Seipp committed
300
301
************************************************************************
*                                                                      *
302
\section{Common subexpression}
Austin Seipp's avatar
Austin Seipp committed
303
304
305
*                                                                      *
************************************************************************
-}
306

307
cseProgram :: CoreProgram -> CoreProgram
308
cseProgram binds = snd (mapAccumL (cseBind TopLevel) emptyCSEnv binds)
309

310
cseBind :: TopLevelFlag -> CSEnv -> CoreBind -> (CSEnv, CoreBind)
311
cseBind toplevel env (NonRec b e)
312
  = (env2, NonRec b2 e2)
313
  where
314
315
    (env1, b1)       = addBinder env b
    (env2, (b2, e2)) = cse_bind toplevel env1 (b,e) b1
316

317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
cseBind _ env (Rec [(in_id, rhs)])
  | noCSE in_id
  = (env1, Rec [(out_id, rhs')])

  -- See Note [CSE for recursive bindings]
  | Just previous <- lookupCSRecEnv env out_id rhs''
  , let previous' = mkTicks ticks previous
  = (extendCSSubst env1 in_id previous', NonRec out_id previous')

  | otherwise
  = (extendCSRecEnv env1 out_id rhs'' id_expr', Rec [(zapped_id, rhs')])

  where
    (env1, [out_id]) = addRecBinders env [in_id]
    rhs'  = cseExpr env1 rhs
    rhs'' = stripTicksE tickishFloatable rhs'
    ticks = stripTicksT tickishFloatable rhs'
    id_expr'  = varToCoreExpr out_id
    zapped_id = zapIdUsageInfo out_id

337
cseBind toplevel env (Rec pairs)
338
  = (env2, Rec pairs')
339
  where
340
341
342
343
344
    (env1, bndrs1) = addRecBinders env (map fst pairs)
    (env2, pairs') = mapAccumL do_one env1 (zip pairs bndrs1)

    do_one env (pr, b1) = cse_bind toplevel env pr b1

Edward Z. Yang's avatar
Edward Z. Yang committed
345
346
347
348
349
-- | Given a binding of @in_id@ to @in_rhs@, and a fresh name to refer
-- to @in_id@ (@out_id@, created from addBinder or addRecBinders),
-- first try to CSE @in_rhs@, and then add the resulting (possibly CSE'd)
-- binding to the 'CSEnv', so that we attempt to CSE any expressions
-- which are equal to @out_rhs@.
350
351
352
353
354
355
356
357
358
359
360
cse_bind :: TopLevelFlag -> CSEnv -> (InId, InExpr) -> OutId -> (CSEnv, (OutId, OutExpr))
cse_bind toplevel env (in_id, in_rhs) out_id
  | isTopLevel toplevel, exprIsLiteralString in_rhs
      -- See Note [Take care with literal strings]
  = (env', (out_id, in_rhs))

  | otherwise
  = (env', (out_id', out_rhs))
  where
    out_rhs         = tryForCSE env in_rhs
    (env', out_id') = addBinding env in_id out_id out_rhs
361
362

addBinding :: CSEnv                      -- Includes InId->OutId cloning
Simon Peyton Jones's avatar
Simon Peyton Jones committed
363
           -> InVar                      -- Could be a let-bound type
364
           -> OutId -> OutExpr           -- Processed binding
Simon Peyton Jones's avatar
Simon Peyton Jones committed
365
           -> (CSEnv, OutId)             -- Final env, final bndr
366
367
-- Extend the CSE env with a mapping [rhs -> out-id]
-- unless we can instead just substitute [in-id -> rhs]
Simon Peyton Jones's avatar
Simon Peyton Jones committed
368
369
370
--
-- It's possible for the binder to be a type variable (see
-- Note [Type-let] in CoreSyn), in which case we can just substitute.
371
addBinding env in_id out_id rhs'
Simon Peyton Jones's avatar
Simon Peyton Jones committed
372
373
374
375
  | not (isId in_id) = (extendCSSubst env in_id rhs',     out_id)
  | noCSE in_id      = (env,                              out_id)
  | use_subst        = (extendCSSubst env in_id rhs',     out_id)
  | otherwise        = (extendCSEnv env rhs' id_expr', zapped_id)
376
  where
377
378
379
    id_expr'  = varToCoreExpr out_id
    zapped_id = zapIdUsageInfo out_id
       -- Putting the Id into the cs_map makes it possible that
380
       -- it'll become shared more than it is now, which would
381
382
       -- invalidate (the usage part of) its demand info.
       --    This caused Trac #100218.
383
384
385
386
387
388
       -- Easiest thing is to zap the usage info; subsequently
       -- performing late demand-analysis will restore it.  Don't zap
       -- the strictness info; it's not necessary to do so, and losing
       -- it is bad for performance if you don't do late demand
       -- analysis

Simon Peyton Jones's avatar
Simon Peyton Jones committed
389
    -- Should we use SUBSTITUTE or EXTEND?
390
    -- See Note [CSE for bindings]
Simon Peyton Jones's avatar
Simon Peyton Jones committed
391
392
393
    use_subst = case rhs' of
                   Var {} -> True
                   _      -> False
394

395
noCSE :: InId -> Bool
396
397
noCSE id =  not (isAlwaysActive (idInlineActivation id)) &&
            not (noUserInlineSpec (inlinePragmaSpec (idInlinePragma id)))
398
399
400
401
402
403
404
             -- See Note [CSE for INLINE and NOINLINE]
         || isAnyInlinePragma (idInlinePragma id)
             -- See Note [CSE for stable unfoldings]
         || isJoinId id
             -- See Note [CSE for join points?]


405
406
{- Note [Take care with literal strings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
Consider this example:

  x = "foo"#
  y = "foo"#
  ...x...y...x...y....

We would normally turn this into:

  x = "foo"#
  y = x
  ...x...x...x...x....

But this breaks an invariant of Core, namely that the RHS of a top-level binding
of type Addr# must be a string literal, not another variable. See Note
[CoreSyn top-level string literals] in CoreSyn.

For this reason, we special case top-level bindings to literal strings and leave
the original RHS unmodified. This produces:

  x = "foo"#
  y = "foo"#
  ...x...x...x...x....
429
430
431
432
433
434
435
436

Now 'y' will be discarded as dead code, and we are done.

The net effect is that for the y-binding we want to
  - Use SUBSTITUTE, by extending the substitution with  y :-> x
  - but leave the original binding for y undisturbed

This is done by cse_bind.  I got it wrong the first time (Trac #13367).
437
438
-}

439
440
tryForCSE :: CSEnv -> InExpr -> OutExpr
tryForCSE env expr
441
442
443
444
445
446
  | Just e <- lookupCSEnv env expr'' = mkTicks ticks e
  | otherwise                        = expr'
    -- The varToCoreExpr is needed if we have
    --   case e of xco { ...case e of yco { ... } ... }
    -- Then CSE will substitute yco -> xco;
    -- but these are /coercion/ variables
447
  where
448
    expr'  = cseExpr env expr
449
    expr'' = stripTicksE tickishFloatable expr'
450
451
452
453
454
    ticks  = stripTicksT tickishFloatable expr'
    -- We don't want to lose the source notes when a common sub
    -- expression gets eliminated. Hence we push all (!) of them on
    -- top of the replaced sub-expression. This is probably not too
    -- useful in practice, but upholds our semantics.
455

456
457
458
459
-- | Runs CSE on a single expression.
--
-- This entry point is not used in the compiler itself, but is provided
-- as a convenient entry point for users of the GHC API.
460
cseOneExpr :: InExpr -> OutExpr
461
462
cseOneExpr e = cseExpr env e
  where env = emptyCSEnv {cs_subst = mkEmptySubst (mkInScopeSet (exprFreeVars e)) }
Joachim Breitner's avatar
Joachim Breitner committed
463

464
cseExpr :: CSEnv -> InExpr -> OutExpr
Simon Peyton Jones's avatar
Simon Peyton Jones committed
465
466
467
468
cseExpr env (Type t)              = Type (substTy (csEnvSubst env) t)
cseExpr env (Coercion c)          = Coercion (substCo (csEnvSubst env) c)
cseExpr _   (Lit lit)             = Lit lit
cseExpr env (Var v)               = lookupSubst env v
469
cseExpr env (App f a)             = App (cseExpr env f) (tryForCSE env a)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
470
cseExpr env (Tick t e)            = Tick t (cseExpr env e)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
471
cseExpr env (Cast e co)           = Cast (tryForCSE env e) (substCo (csEnvSubst env) co)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
472
473
cseExpr env (Lam b e)             = let (env', b') = addBinder env b
                                    in Lam b' (cseExpr env' e)
474
cseExpr env (Let bind e)          = let (env', bind') = cseBind NotTopLevel env bind
Simon Peyton Jones's avatar
Simon Peyton Jones committed
475
476
                                    in Let bind' (cseExpr env' e)
cseExpr env (Case e bndr ty alts) = cseCase env e bndr ty alts
477
478
479

cseCase :: CSEnv -> InExpr -> InId -> InType -> [InAlt] -> OutExpr
cseCase env scrut bndr ty alts
480
481
  = Case scrut1 bndr3 ty' $
    combineAlts alt_env (map cse_alt alts)
482
  where
483
    ty' = substTy (csEnvSubst env) ty
484
    scrut1 = tryForCSE env scrut
485

486
487
488
489
    bndr1 = zapIdOccInfo bndr
      -- Zapping the OccInfo is needed because the extendCSEnv
      -- in cse_alt may mean that a dead case binder
      -- becomes alive, and Lint rejects that
Simon Peyton Jones's avatar
Simon Peyton Jones committed
490
491
    (env1, bndr2)    = addBinder env bndr1
    (alt_env, bndr3) = addBinding env1 bndr bndr2 scrut1
492
         -- addBinding: see Note [CSE for case expressions]
493

494
495
    con_target :: OutExpr
    con_target = lookupSubst alt_env bndr
496

497
498
    arg_tys :: [OutType]
    arg_tys = tyConAppArgs (idType bndr3)
499

Edward Z. Yang's avatar
Edward Z. Yang committed
500
501
    -- Given case x of { K y z -> ...K y z... }
    -- CSE K y z into x...
502
    cse_alt (DataAlt con, args, rhs)
503
        | not (null args)
Edward Z. Yang's avatar
Edward Z. Yang committed
504
                -- ... but don't try CSE if there are no args; it just increases the number
505
506
507
508
                -- of live vars.  E.g.
                --      case x of { True -> ....True.... }
                -- Don't replace True by x!
                -- Hence the 'null args', which also deal with literals and DEFAULT
509
        = (DataAlt con, args', tryForCSE new_env rhs)
510
511
        where
          (env', args') = addBinders alt_env args
512
513
          new_env       = extendCSEnv env' con_expr con_target
          con_expr      = mkAltExpr (DataAlt con) args' arg_tys
514
515

    cse_alt (con, args, rhs)
516
        = (con, args', tryForCSE env' rhs)
517
518
        where
          (env', args') = addBinders alt_env args
519

520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
combineAlts :: CSEnv -> [InAlt] -> [InAlt]
-- See Note [Combine case alternatives]
combineAlts env ((_,bndrs1,rhs1) : rest_alts)
  | all isDeadBinder bndrs1
  = (DEFAULT, [], rhs1) : filtered_alts
  where
    in_scope = substInScope (csEnvSubst env)
    filtered_alts = filterOut identical rest_alts
    identical (_con, bndrs, rhs) = all ok bndrs && eqExpr in_scope rhs1 rhs
    ok bndr = isDeadBinder bndr || not (bndr `elemInScopeSet` in_scope)

combineAlts _ alts = alts  -- Default case

{- Note [Combine case alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
combineAlts is just a more heavyweight version of the use of
Edward Z. Yang's avatar
Edward Z. Yang committed
536
combineIdenticalAlts in SimplUtils.prepareAlts.  The basic idea is
537
538
539
540
541
542
543
544
545
546
to transform

    DEFAULT -> e1
    K x     -> e1
    W y z   -> e2
===>
   DEFAULT -> e1
   W y z   -> e2

In the simplifier we use cheapEqExpr, because it is called a lot.
Gabor Greif's avatar
Gabor Greif committed
547
But here in CSE we use the full eqExpr.  After all, two alternatives usually
548
differ near the root, so it probably isn't expensive to compare the full
549
alternative.  It seems like the same kind of thing that CSE is supposed
550
551
552
553
554
555
to be doing, which is why I put it here.

I acutally saw some examples in the wild, where some inlining made e1 too
big for cheapEqExpr to catch it.


Austin Seipp's avatar
Austin Seipp committed
556
557
************************************************************************
*                                                                      *
558
\section{The CSE envt}
Austin Seipp's avatar
Austin Seipp committed
559
560
561
*                                                                      *
************************************************************************
-}
562

563
564
565
566
data CSEnv
  = CS { cs_subst :: Subst  -- Maps InBndrs to OutExprs
            -- The substitution variables to
            -- /trivial/ OutExprs, not arbitrary expressions
567

568
569
570
       , cs_map   :: CoreMap OutExpr   -- The reverse mapping
            -- Maps a OutExpr to a /trivial/ OutExpr
            -- The key of cs_map is stripped of all Ticks
571
572
573

       , cs_rec_map :: CoreMap OutExpr
            -- See Note [CSE for recursive bindings]
574
       }
575
576

emptyCSEnv :: CSEnv
577
578
emptyCSEnv = CS { cs_map = emptyCoreMap, cs_rec_map = emptyCoreMap
                , cs_subst = emptySubst }
579

580
lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr
581
lookupCSEnv (CS { cs_map = csmap }) expr
582
583
584
585
586
587
588
  = lookupCoreMap csmap expr

extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv
extendCSEnv cse expr triv_expr
  = cse { cs_map = extendCoreMap (cs_map cse) sexpr triv_expr }
  where
    sexpr = stripTicksE tickishFloatable expr
589

590
591
592
extendCSRecEnv :: CSEnv -> OutId -> OutExpr -> OutExpr -> CSEnv
-- See Note [CSE for recursive bindings]
extendCSRecEnv cse bndr expr triv_expr
Ben Gamari's avatar
Ben Gamari committed
593
  = cse { cs_rec_map = extendCoreMap (cs_rec_map cse) (Lam bndr expr) triv_expr }
594
595
596
597
598
599

lookupCSRecEnv :: CSEnv -> OutId -> OutExpr -> Maybe OutExpr
-- See Note [CSE for recursive bindings]
lookupCSRecEnv (CS { cs_rec_map = csmap }) bndr expr
  = lookupCoreMap csmap (Lam bndr expr)

600
601
602
csEnvSubst :: CSEnv -> Subst
csEnvSubst = cs_subst

603
lookupSubst :: CSEnv -> Id -> OutExpr
604
lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst (text "CSE.lookupSubst") sub x
605

606
607
extendCSSubst :: CSEnv -> Id  -> CoreExpr -> CSEnv
extendCSSubst cse x rhs = cse { cs_subst = extendSubst (cs_subst cse) x rhs }
608

Edward Z. Yang's avatar
Edward Z. Yang committed
609
610
611
-- | Add clones to the substitution to deal with shadowing.  See
-- Note [Shadowing] for more details.  You should call this whenever
-- you go under a binder.
612
addBinder :: CSEnv -> Var -> (CSEnv, Var)
613
addBinder cse v = (cse { cs_subst = sub' }, v')
614
615
                where
                  (sub', v') = substBndr (cs_subst cse) v
616
617

addBinders :: CSEnv -> [Var] -> (CSEnv, [Var])
618
addBinders cse vs = (cse { cs_subst = sub' }, vs')
619
620
                where
                  (sub', vs') = substBndrs (cs_subst cse) vs
621

622
addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
623
addRecBinders cse vs = (cse { cs_subst = sub' }, vs')
624
625
                where
                  (sub', vs') = substRecBndrs (cs_subst cse) vs