60ee802f61b7d94a194337c3e6cfaddf2f4c3a98
[ghc.git] / compiler / simplCore / Simplify.lhs
1 %
2 % (c) The AQUA Project, Glasgow University, 1993-1998
3 %
4 \section[Simplify]{The main module of the simplifier}
5
6 \begin{code}
7 module Simplify ( simplTopBinds, simplExpr ) where
8
9 #include "HsVersions.h"
10
11 import DynFlags
12 import SimplMonad
13 import Type hiding      ( substTy, extendTvSubst )
14 import SimplEnv
15 import SimplUtils
16 import FamInstEnv       ( FamInstEnv )
17 import Id
18 import MkId             ( mkImpossibleExpr, seqId )
19 import Var
20 import IdInfo
21 import Name             ( mkSystemVarName )
22 import Coercion
23 import FamInstEnv       ( topNormaliseType )
24 import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness )
25 import CoreSyn
26 import Demand           ( isStrictDmd, splitStrictSig )
27 import PprCore          ( pprParendExpr, pprCoreExpr )
28 import CoreUnfold       ( mkUnfolding, mkCoreUnfolding, mkInlineRule, 
29                           exprIsConApp_maybe, callSiteInline, CallCtxt(..) )
30 import CoreUtils
31 import qualified CoreSubst
32 import CoreArity        ( exprArity )
33 import Rules            ( lookupRule, getRules )
34 import BasicTypes       ( isMarkedStrict, Arity )
35 import CostCentre       ( currentCCS, pushCCisNop )
36 import TysPrim          ( realWorldStatePrimTy )
37 import PrelInfo         ( realWorldPrimId )
38 import BasicTypes       ( TopLevelFlag(..), isTopLevel, RecFlag(..) )
39 import MonadUtils       ( foldlM, mapAccumLM )
40 import Maybes           ( orElse )
41 import Data.List        ( mapAccumL )
42 import Outputable
43 import FastString
44 \end{code}
45
46
47 The guts of the simplifier is in this module, but the driver loop for
48 the simplifier is in SimplCore.lhs.
49
50
51 -----------------------------------------
52         *** IMPORTANT NOTE ***
53 -----------------------------------------
54 The simplifier used to guarantee that the output had no shadowing, but
55 it does not do so any more.   (Actually, it never did!)  The reason is
56 documented with simplifyArgs.
57
58
59 -----------------------------------------
60         *** IMPORTANT NOTE ***
61 -----------------------------------------
62 Many parts of the simplifier return a bunch of "floats" as well as an
63 expression. This is wrapped as a datatype SimplUtils.FloatsWith.
64
65 All "floats" are let-binds, not case-binds, but some non-rec lets may
66 be unlifted (with RHS ok-for-speculation).
67
68
69
70 -----------------------------------------
71         ORGANISATION OF FUNCTIONS
72 -----------------------------------------
73 simplTopBinds
74   - simplify all top-level binders
75   - for NonRec, call simplRecOrTopPair
76   - for Rec,    call simplRecBind
77
78
79         ------------------------------
80 simplExpr (applied lambda)      ==> simplNonRecBind
81 simplExpr (Let (NonRec ...) ..) ==> simplNonRecBind
82 simplExpr (Let (Rec ...)    ..) ==> simplify binders; simplRecBind
83
84         ------------------------------
85 simplRecBind    [binders already simplfied]
86   - use simplRecOrTopPair on each pair in turn
87
88 simplRecOrTopPair [binder already simplified]
89   Used for: recursive bindings (top level and nested)
90             top-level non-recursive bindings
91   Returns:
92   - check for PreInlineUnconditionally
93   - simplLazyBind
94
95 simplNonRecBind
96   Used for: non-top-level non-recursive bindings
97             beta reductions (which amount to the same thing)
98   Because it can deal with strict arts, it takes a
99         "thing-inside" and returns an expression
100
101   - check for PreInlineUnconditionally
102   - simplify binder, including its IdInfo
103   - if strict binding
104         simplStrictArg
105         mkAtomicArgs
106         completeNonRecX
107     else
108         simplLazyBind
109         addFloats
110
111 simplNonRecX:   [given a *simplified* RHS, but an *unsimplified* binder]
112   Used for: binding case-binder and constr args in a known-constructor case
113   - check for PreInLineUnconditionally
114   - simplify binder
115   - completeNonRecX
116
117         ------------------------------
118 simplLazyBind:  [binder already simplified, RHS not]
119   Used for: recursive bindings (top level and nested)
120             top-level non-recursive bindings
121             non-top-level, but *lazy* non-recursive bindings
122         [must not be strict or unboxed]
123   Returns floats + an augmented environment, not an expression
124   - substituteIdInfo and add result to in-scope
125         [so that rules are available in rec rhs]
126   - simplify rhs
127   - mkAtomicArgs
128   - float if exposes constructor or PAP
129   - completeBind
130
131
132 completeNonRecX:        [binder and rhs both simplified]
133   - if the the thing needs case binding (unlifted and not ok-for-spec)
134         build a Case
135    else
136         completeBind
137         addFloats
138
139 completeBind:   [given a simplified RHS]
140         [used for both rec and non-rec bindings, top level and not]
141   - try PostInlineUnconditionally
142   - add unfolding [this is the only place we add an unfolding]
143   - add arity
144
145
146
147 Right hand sides and arguments
148 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
149 In many ways we want to treat
150         (a) the right hand side of a let(rec), and
151         (b) a function argument
152 in the same way.  But not always!  In particular, we would
153 like to leave these arguments exactly as they are, so they
154 will match a RULE more easily.
155
156         f (g x, h x)
157         g (+ x)
158
159 It's harder to make the rule match if we ANF-ise the constructor,
160 or eta-expand the PAP:
161
162         f (let { a = g x; b = h x } in (a,b))
163         g (\y. + x y)
164
165 On the other hand if we see the let-defns
166
167         p = (g x, h x)
168         q = + x
169
170 then we *do* want to ANF-ise and eta-expand, so that p and q
171 can be safely inlined.
172
173 Even floating lets out is a bit dubious.  For let RHS's we float lets
174 out if that exposes a value, so that the value can be inlined more vigorously.
175 For example
176
177         r = let x = e in (x,x)
178
179 Here, if we float the let out we'll expose a nice constructor. We did experiments
180 that showed this to be a generally good thing.  But it was a bad thing to float
181 lets out unconditionally, because that meant they got allocated more often.
182
183 For function arguments, there's less reason to expose a constructor (it won't
184 get inlined).  Just possibly it might make a rule match, but I'm pretty skeptical.
185 So for the moment we don't float lets out of function arguments either.
186
187
188 Eta expansion
189 ~~~~~~~~~~~~~~
190 For eta expansion, we want to catch things like
191
192         case e of (a,b) -> \x -> case a of (p,q) -> \y -> r
193
194 If the \x was on the RHS of a let, we'd eta expand to bring the two
195 lambdas together.  And in general that's a good thing to do.  Perhaps
196 we should eta expand wherever we find a (value) lambda?  Then the eta
197 expansion at a let RHS can concentrate solely on the PAP case.
198
199
200 %************************************************************************
201 %*                                                                      *
202 \subsection{Bindings}
203 %*                                                                      *
204 %************************************************************************
205
206 \begin{code}
207 simplTopBinds :: SimplEnv -> [InBind] -> SimplM SimplEnv
208
209 simplTopBinds env0 binds0
210   = do  {       -- Put all the top-level binders into scope at the start
211                 -- so that if a transformation rule has unexpectedly brought
212                 -- anything into scope, then we don't get a complaint about that.
213                 -- It's rather as if the top-level binders were imported.
214         ; env1 <- simplRecBndrs env0 (bindersOfBinds binds0)
215         ; dflags <- getDOptsSmpl
216         ; let dump_flag = dopt Opt_D_verbose_core2core dflags
217         ; env2 <- simpl_binds dump_flag env1 binds0
218         ; freeTick SimplifierDone
219         ; return env2 }
220   where
221         -- We need to track the zapped top-level binders, because
222         -- they should have their fragile IdInfo zapped (notably occurrence info)
223         -- That's why we run down binds and bndrs' simultaneously.
224         --
225         -- The dump-flag emits a trace for each top-level binding, which
226         -- helps to locate the tracing for inlining and rule firing
227     simpl_binds :: Bool -> SimplEnv -> [InBind] -> SimplM SimplEnv
228     simpl_binds _    env []           = return env
229     simpl_binds dump env (bind:binds) = do { env' <- trace_bind dump bind $
230                                                      simpl_bind env bind
231                                            ; simpl_binds dump env' binds }
232
233     trace_bind True  bind = pprTrace "SimplBind" (ppr (bindersOf bind))
234     trace_bind False _    = \x -> x
235
236     simpl_bind env (Rec pairs)  = simplRecBind      env  TopLevel pairs
237     simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel b b' r
238         where
239           (env', b') = addBndrRules env b (lookupRecBndr env b)
240 \end{code}
241
242
243 %************************************************************************
244 %*                                                                      *
245 \subsection{Lazy bindings}
246 %*                                                                      *
247 %************************************************************************
248
249 simplRecBind is used for
250         * recursive bindings only
251
252 \begin{code}
253 simplRecBind :: SimplEnv -> TopLevelFlag
254              -> [(InId, InExpr)]
255              -> SimplM SimplEnv
256 simplRecBind env0 top_lvl pairs0
257   = do  { let (env_with_info, triples) = mapAccumL add_rules env0 pairs0
258         ; env1 <- go (zapFloats env_with_info) triples
259         ; return (env0 `addRecFloats` env1) }
260         -- addFloats adds the floats from env1,
261         -- _and_ updates env0 with the in-scope set from env1
262   where
263     add_rules :: SimplEnv -> (InBndr,InExpr) -> (SimplEnv, (InBndr, OutBndr, InExpr))
264         -- Add the (substituted) rules to the binder
265     add_rules env (bndr, rhs) = (env', (bndr, bndr', rhs))
266         where
267           (env', bndr') = addBndrRules env bndr (lookupRecBndr env bndr)
268
269     go env [] = return env
270
271     go env ((old_bndr, new_bndr, rhs) : pairs)
272         = do { env' <- simplRecOrTopPair env top_lvl old_bndr new_bndr rhs
273              ; go env' pairs }
274 \end{code}
275
276 simplOrTopPair is used for
277         * recursive bindings (whether top level or not)
278         * top-level non-recursive bindings
279
280 It assumes the binder has already been simplified, but not its IdInfo.
281
282 \begin{code}
283 simplRecOrTopPair :: SimplEnv
284                   -> TopLevelFlag
285                   -> InId -> OutBndr -> InExpr  -- Binder and rhs
286                   -> SimplM SimplEnv    -- Returns an env that includes the binding
287
288 simplRecOrTopPair env top_lvl old_bndr new_bndr rhs
289   | preInlineUnconditionally env top_lvl old_bndr rhs   -- Check for unconditional inline
290   = do  { tick (PreInlineUnconditionally old_bndr)
291         ; return (extendIdSubst env old_bndr (mkContEx env rhs)) }
292
293   | otherwise
294   = simplLazyBind env top_lvl Recursive old_bndr new_bndr rhs env
295         -- May not actually be recursive, but it doesn't matter
296 \end{code}
297
298
299 simplLazyBind is used for
300   * [simplRecOrTopPair] recursive bindings (whether top level or not)
301   * [simplRecOrTopPair] top-level non-recursive bindings
302   * [simplNonRecE]      non-top-level *lazy* non-recursive bindings
303
304 Nota bene:
305     1. It assumes that the binder is *already* simplified,
306        and is in scope, and its IdInfo too, except unfolding
307
308     2. It assumes that the binder type is lifted.
309
310     3. It does not check for pre-inline-unconditionallly;
311        that should have been done already.
312
313 \begin{code}
314 simplLazyBind :: SimplEnv
315               -> TopLevelFlag -> RecFlag
316               -> InId -> OutId          -- Binder, both pre-and post simpl
317                                         -- The OutId has IdInfo, except arity, unfolding
318               -> InExpr -> SimplEnv     -- The RHS and its environment
319               -> SimplM SimplEnv
320
321 simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
322   = do  { let   rhs_env     = rhs_se `setInScope` env
323                 (tvs, body) = case collectTyBinders rhs of
324                                 (tvs, body) | not_lam body -> (tvs,body)
325                                             | otherwise    -> ([], rhs)
326                 not_lam (Lam _ _) = False
327                 not_lam _         = True
328                         -- Do not do the "abstract tyyvar" thing if there's
329                         -- a lambda inside, becuase it defeats eta-reduction
330                         --    f = /\a. \x. g a x  
331                         -- should eta-reduce
332
333         ; (body_env, tvs') <- simplBinders rhs_env tvs
334                 -- See Note [Floating and type abstraction] in SimplUtils
335
336         -- Simplify the RHS
337         ; (body_env1, body1) <- simplExprF body_env body mkRhsStop
338         -- ANF-ise a constructor or PAP rhs
339         ; (body_env2, body2) <- prepareRhs body_env1 bndr1 body1
340
341         ; (env', rhs')
342             <-  if not (doFloatFromRhs top_lvl is_rec False body2 body_env2)
343                 then                            -- No floating, just wrap up!
344                      do { rhs' <- mkLam env tvs' (wrapFloats body_env2 body2)
345                         ; return (env, rhs') }
346
347                 else if null tvs then           -- Simple floating
348                      do { tick LetFloatFromLet
349                         ; return (addFloats env body_env2, body2) }
350
351                 else                            -- Do type-abstraction first
352                      do { tick LetFloatFromLet
353                         ; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2
354                         ; rhs' <- mkLam env tvs' body3
355                         ; env' <- foldlM (addPolyBind top_lvl) env poly_binds
356                         ; return (env', rhs') }
357
358         ; completeBind env' top_lvl bndr bndr1 rhs' }
359 \end{code}
360
361 A specialised variant of simplNonRec used when the RHS is already simplified,
362 notably in knownCon.  It uses case-binding where necessary.
363
364 \begin{code}
365 simplNonRecX :: SimplEnv
366              -> InId            -- Old binder
367              -> OutExpr         -- Simplified RHS
368              -> SimplM SimplEnv
369
370 simplNonRecX env bndr new_rhs
371   | isDeadBinder bndr   -- Not uncommon; e.g. case (a,b) of b { (p,q) -> p }
372   = return env          --               Here b is dead, and we avoid creating
373   | otherwise           --               the binding b = (a,b)
374   = do  { (env', bndr') <- simplBinder env bndr
375         ; completeNonRecX env' (isStrictId bndr) bndr bndr' new_rhs }
376
377 completeNonRecX :: SimplEnv
378                 -> Bool
379                 -> InId                 -- Old binder
380                 -> OutId                -- New binder
381                 -> OutExpr              -- Simplified RHS
382                 -> SimplM SimplEnv
383
384 completeNonRecX env is_strict old_bndr new_bndr new_rhs
385   = do  { (env1, rhs1) <- prepareRhs (zapFloats env) new_bndr new_rhs
386         ; (env2, rhs2) <-
387                 if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1
388                 then do { tick LetFloatFromLet
389                         ; return (addFloats env env1, rhs1) }   -- Add the floats to the main env
390                 else return (env, wrapFloats env1 rhs1)         -- Wrap the floats around the RHS
391         ; completeBind env2 NotTopLevel old_bndr new_bndr rhs2 }
392 \end{code}
393
394 {- No, no, no!  Do not try preInlineUnconditionally in completeNonRecX
395    Doing so risks exponential behaviour, because new_rhs has been simplified once already
396    In the cases described by the folowing commment, postInlineUnconditionally will
397    catch many of the relevant cases.
398         -- This happens; for example, the case_bndr during case of
399         -- known constructor:  case (a,b) of x { (p,q) -> ... }
400         -- Here x isn't mentioned in the RHS, so we don't want to
401         -- create the (dead) let-binding  let x = (a,b) in ...
402         --
403         -- Similarly, single occurrences can be inlined vigourously
404         -- e.g.  case (f x, g y) of (a,b) -> ....
405         -- If a,b occur once we can avoid constructing the let binding for them.
406
407    Furthermore in the case-binding case preInlineUnconditionally risks extra thunks
408         -- Consider     case I# (quotInt# x y) of
409         --                I# v -> let w = J# v in ...
410         -- If we gaily inline (quotInt# x y) for v, we end up building an
411         -- extra thunk:
412         --                let w = J# (quotInt# x y) in ...
413         -- because quotInt# can fail.
414
415   | preInlineUnconditionally env NotTopLevel bndr new_rhs
416   = thing_inside (extendIdSubst env bndr (DoneEx new_rhs))
417 -}
418
419 ----------------------------------
420 prepareRhs takes a putative RHS, checks whether it's a PAP or
421 constructor application and, if so, converts it to ANF, so that the
422 resulting thing can be inlined more easily.  Thus
423         x = (f a, g b)
424 becomes
425         t1 = f a
426         t2 = g b
427         x = (t1,t2)
428
429 We also want to deal well cases like this
430         v = (f e1 `cast` co) e2
431 Here we want to make e1,e2 trivial and get
432         x1 = e1; x2 = e2; v = (f x1 `cast` co) v2
433 That's what the 'go' loop in prepareRhs does
434
435 \begin{code}
436 prepareRhs :: SimplEnv -> OutId -> OutExpr -> SimplM (SimplEnv, OutExpr)
437 -- Adds new floats to the env iff that allows us to return a good RHS
438 prepareRhs env id (Cast rhs co)    -- Note [Float coercions]
439   | (ty1, _ty2) <- coercionKind co       -- Do *not* do this if rhs has an unlifted type
440   , not (isUnLiftedType ty1)            -- see Note [Float coercions (unlifted)]
441   = do  { (env', rhs') <- makeTrivialWithInfo env sanitised_info rhs
442         ; return (env', Cast rhs' co) }
443   where
444     sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info
445                                    `setDemandInfo`     demandInfo info
446     info = idInfo id
447
448 prepareRhs env0 _ rhs0
449   = do  { (_is_exp, env1, rhs1) <- go 0 env0 rhs0
450         ; return (env1, rhs1) }
451   where
452     go n_val_args env (Cast rhs co)
453         = do { (is_exp, env', rhs') <- go n_val_args env rhs
454              ; return (is_exp, env', Cast rhs' co) }
455     go n_val_args env (App fun (Type ty))
456         = do { (is_exp, env', rhs') <- go n_val_args env fun
457              ; return (is_exp, env', App rhs' (Type ty)) }
458     go n_val_args env (App fun arg)
459         = do { (is_exp, env', fun') <- go (n_val_args+1) env fun
460              ; case is_exp of
461                 True -> do { (env'', arg') <- makeTrivial env' arg
462                            ; return (True, env'', App fun' arg') }
463                 False -> return (False, env, App fun arg) }
464     go n_val_args env (Var fun)
465         = return (is_exp, env, Var fun)
466         where
467           is_exp = isExpandableApp fun n_val_args   -- The fun a constructor or PAP
468                         -- See Note [CONLIKE pragma] in BasicTypes
469                         -- The definition of is_exp should match that in
470                         -- OccurAnal.occAnalApp
471
472     go _ env other
473         = return (False, env, other)
474 \end{code}
475
476
477 Note [Float coercions]
478 ~~~~~~~~~~~~~~~~~~~~~~
479 When we find the binding
480         x = e `cast` co
481 we'd like to transform it to
482         x' = e
483         x = x `cast` co         -- A trivial binding
484 There's a chance that e will be a constructor application or function, or something
485 like that, so moving the coerion to the usage site may well cancel the coersions
486 and lead to further optimisation.  Example:
487
488      data family T a :: *
489      data instance T Int = T Int
490
491      foo :: Int -> Int -> Int
492      foo m n = ...
493         where
494           x = T m
495           go 0 = 0
496           go n = case x of { T m -> go (n-m) }
497                 -- This case should optimise
498
499 Note [Preserve strictness when floating coercions]
500 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
501 In the Note [Float coercions] transformation, keep the strictness info.
502 Eg
503         f = e `cast` co    -- f has strictness SSL
504 When we transform to
505         f' = e             -- f' also has strictness SSL
506         f = f' `cast` co   -- f still has strictness SSL
507
508 Its not wrong to drop it on the floor, but better to keep it.
509
510 Note [Float coercions (unlifted)]
511 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
512 BUT don't do [Float coercions] if 'e' has an unlifted type.
513 This *can* happen:
514
515      foo :: Int = (error (# Int,Int #) "urk")
516                   `cast` CoUnsafe (# Int,Int #) Int
517
518 If do the makeTrivial thing to the error call, we'll get
519     foo = case error (# Int,Int #) "urk" of v -> v `cast` ...
520 But 'v' isn't in scope!
521
522 These strange casts can happen as a result of case-of-case
523         bar = case (case x of { T -> (# 2,3 #); F -> error "urk" }) of
524                 (# p,q #) -> p+q
525
526
527 \begin{code}
528 makeTrivial :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
529 -- Binds the expression to a variable, if it's not trivial, returning the variable
530 makeTrivial env expr = makeTrivialWithInfo env vanillaIdInfo expr
531
532 makeTrivialWithInfo :: SimplEnv -> IdInfo -> OutExpr -> SimplM (SimplEnv, OutExpr)
533 -- Propagate strictness and demand info to the new binder
534 -- Note [Preserve strictness when floating coercions]
535 makeTrivialWithInfo env info expr
536   | exprIsTrivial expr
537   = return (env, expr)
538   | otherwise           -- See Note [Take care] below
539   = do  { uniq <- getUniqueM
540         ; let name = mkSystemVarName uniq (fsLit "a")
541               var = mkLocalIdWithInfo name (exprType expr) info
542         ; env' <- completeNonRecX env False var var expr
543         ; return (env', substExpr env' (Var var)) }
544         -- The substitution is needed becase we're constructing a new binding
545         --     a = rhs
546         -- And if rhs is of form (rhs1 |> co), then we might get
547         --     a1 = rhs1
548         --     a = a1 |> co
549         -- and now a's RHS is trivial and can be substituted out, and that
550         -- is what completeNonRecX will do
551 \end{code}
552
553
554 %************************************************************************
555 %*                                                                      *
556 \subsection{Completing a lazy binding}
557 %*                                                                      *
558 %************************************************************************
559
560 completeBind
561   * deals only with Ids, not TyVars
562   * takes an already-simplified binder and RHS
563   * is used for both recursive and non-recursive bindings
564   * is used for both top-level and non-top-level bindings
565
566 It does the following:
567   - tries discarding a dead binding
568   - tries PostInlineUnconditionally
569   - add unfolding [this is the only place we add an unfolding]
570   - add arity
571
572 It does *not* attempt to do let-to-case.  Why?  Because it is used for
573   - top-level bindings (when let-to-case is impossible)
574   - many situations where the "rhs" is known to be a WHNF
575                 (so let-to-case is inappropriate).
576
577 Nor does it do the atomic-argument thing
578
579 \begin{code}
580 completeBind :: SimplEnv
581              -> TopLevelFlag            -- Flag stuck into unfolding
582              -> InId                    -- Old binder
583              -> OutId -> OutExpr        -- New binder and RHS
584              -> SimplM SimplEnv
585 -- completeBind may choose to do its work
586 --      * by extending the substitution (e.g. let x = y in ...)
587 --      * or by adding to the floats in the envt
588
589 completeBind env top_lvl old_bndr new_bndr new_rhs
590   = do  { let old_info = idInfo old_bndr
591               old_unf  = unfoldingInfo old_info
592               occ_info = occInfo old_info
593
594         ; new_unfolding <- simplUnfolding env top_lvl old_bndr occ_info new_rhs old_unf
595
596         ; if postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs new_unfolding
597                         -- Inline and discard the binding
598           then do  { tick (PostInlineUnconditionally old_bndr)
599                    ; -- pprTrace "postInlineUnconditionally" (ppr old_bndr <+> equals <+> ppr new_rhs) $
600                      return (extendIdSubst env old_bndr (DoneEx new_rhs)) }
601                 -- Use the substitution to make quite, quite sure that the
602                 -- substitution will happen, since we are going to discard the binding
603
604           else return (addNonRecWithUnf env new_bndr new_rhs new_unfolding) }
605
606 ------------------------------
607 addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplM SimplEnv
608 -- Add a new binding to the environment, complete with its unfolding
609 -- but *do not* do postInlineUnconditionally, because we have already
610 -- processed some of the scope of the binding
611 -- We still want the unfolding though.  Consider
612 --      let 
613 --            x = /\a. let y = ... in Just y
614 --      in body
615 -- Then we float the y-binding out (via abstractFloats and addPolyBind)
616 -- but 'x' may well then be inlined in 'body' in which case we'd like the 
617 -- opportunity to inline 'y' too.
618
619 addPolyBind top_lvl env (NonRec poly_id rhs)
620   = do  { unfolding <- simplUnfolding env top_lvl poly_id NoOccInfo rhs noUnfolding
621                         -- Assumes that poly_id did not have an INLINE prag
622                         -- which is perhaps wrong.  ToDo: think about this
623         ; return (addNonRecWithUnf env poly_id rhs unfolding) }
624
625 addPolyBind _ env bind@(Rec _) = return (extendFloats env bind)
626                 -- Hack: letrecs are more awkward, so we extend "by steam"
627                 -- without adding unfoldings etc.  At worst this leads to
628                 -- more simplifier iterations
629
630 ------------------------------
631 addNonRecWithUnf :: SimplEnv
632                  -> OutId -> OutExpr    -- New binder and RHS
633                  -> Unfolding           -- New unfolding
634                  -> SimplEnv
635 addNonRecWithUnf env new_bndr new_rhs new_unfolding
636   = let new_arity = exprArity new_rhs
637         old_arity = idArity new_bndr
638         info1 = idInfo new_bndr `setArityInfo` new_arity
639         
640               -- Unfolding info: Note [Setting the new unfolding]
641         info2 = info1 `setUnfoldingInfo` new_unfolding
642
643         -- Demand info: Note [Setting the demand info]
644         info3 | isEvaldUnfolding new_unfolding = zapDemandInfo info2 `orElse` info2
645               | otherwise                      = info2
646
647         final_id = new_bndr `setIdInfo` info3
648         dmd_arity = length $ fst $ splitStrictSig $ idStrictness new_bndr
649     in
650     ASSERT( isId new_bndr )
651     WARN( new_arity < old_arity || new_arity < dmd_arity, 
652           (ptext (sLit "Arity decrease:") <+> ppr final_id <+> ppr old_arity
653                 <+> ppr new_arity <+> ppr dmd_arity) )
654         -- Note [Arity decrease]
655
656     final_id `seq`   -- This seq forces the Id, and hence its IdInfo,
657                      -- and hence any inner substitutions
658             -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $
659     addNonRec env final_id new_rhs
660                 -- The addNonRec adds it to the in-scope set too
661
662 ------------------------------
663 simplUnfolding :: SimplEnv-> TopLevelFlag
664                -> Id
665                -> OccInfo -> OutExpr
666                -> Unfolding -> SimplM Unfolding
667 -- Note [Setting the new unfolding]
668 simplUnfolding env _ _ _ _ (DFunUnfolding con ops)
669   = return (DFunUnfolding con ops')
670   where
671     ops' = map (CoreSubst.substExpr (mkCoreSubst env)) ops
672
673 simplUnfolding env top_lvl id _ _ 
674     (CoreUnfolding { uf_tmpl = expr, uf_arity = arity
675                    , uf_src = src, uf_guidance = guide })
676   | isInlineRuleSource src
677   = do { expr' <- simplExpr rule_env expr
678        ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst env) src
679        ; return (mkCoreUnfolding (isTopLevel top_lvl) src' expr' arity guide) }
680                 -- See Note [Top-level flag on inline rules] in CoreUnfold
681   where
682     rule_env = updMode (updModeForInlineRules (idInlineActivation id)) env
683                -- See Note [Simplifying gently inside InlineRules] in SimplUtils
684
685 simplUnfolding _ top_lvl id _occ_info new_rhs _
686   = return (mkUnfolding (isTopLevel top_lvl) (isBottomingId id) new_rhs)
687   -- We make an  unfolding *even for loop-breakers*.
688   -- Reason: (a) It might be useful to know that they are WHNF
689   --         (b) In TidyPgm we currently assume that, if we want to
690   --             expose the unfolding then indeed we *have* an unfolding
691   --             to expose.  (We could instead use the RHS, but currently
692   --             we don't.)  The simple thing is always to have one.
693 \end{code}
694
695 Note [Arity decrease]
696 ~~~~~~~~~~~~~~~~~~~~~
697 Generally speaking the arity of a binding should not decrease.  But it *can* 
698 legitimately happen becuase of RULES.  Eg
699         f = g Int
700 where g has arity 2, will have arity 2.  But if there's a rewrite rule
701         g Int --> h
702 where h has arity 1, then f's arity will decrease.  Here's a real-life example,
703 which is in the output of Specialise:
704
705      Rec {
706         $dm {Arity 2} = \d.\x. op d
707         {-# RULES forall d. $dm Int d = $s$dm #-}
708         
709         dInt = MkD .... opInt ...
710         opInt {Arity 1} = $dm dInt
711
712         $s$dm {Arity 0} = \x. op dInt }
713
714 Here opInt has arity 1; but when we apply the rule its arity drops to 0.
715 That's why Specialise goes to a little trouble to pin the right arity
716 on specialised functions too.
717
718 Note [Setting the new unfolding]
719 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
720 * If there's an INLINE pragma, we simplify the RHS gently.  Maybe we
721   should do nothing at all, but simplifying gently might get rid of 
722   more crap.
723
724 * If not, we make an unfolding from the new RHS.  But *only* for
725   non-loop-breakers. Making loop breakers not have an unfolding at all
726   means that we can avoid tests in exprIsConApp, for example.  This is
727   important: if exprIsConApp says 'yes' for a recursive thing, then we
728   can get into an infinite loop
729
730 If there's an InlineRule on a loop breaker, we hang on to the inlining.
731 It's pretty dodgy, but the user did say 'INLINE'.  May need to revisit
732 this choice.
733
734 Note [Setting the demand info]
735 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
736 If the unfolding is a value, the demand info may
737 go pear-shaped, so we nuke it.  Example:
738      let x = (a,b) in
739      case x of (p,q) -> h p q x
740 Here x is certainly demanded. But after we've nuked
741 the case, we'll get just
742      let x = (a,b) in h a b x
743 and now x is not demanded (I'm assuming h is lazy)
744 This really happens.  Similarly
745      let f = \x -> e in ...f..f...
746 After inlining f at some of its call sites the original binding may
747 (for example) be no longer strictly demanded.
748 The solution here is a bit ad hoc...
749
750
751 %************************************************************************
752 %*                                                                      *
753 \subsection[Simplify-simplExpr]{The main function: simplExpr}
754 %*                                                                      *
755 %************************************************************************
756
757 The reason for this OutExprStuff stuff is that we want to float *after*
758 simplifying a RHS, not before.  If we do so naively we get quadratic
759 behaviour as things float out.
760
761 To see why it's important to do it after, consider this (real) example:
762
763         let t = f x
764         in fst t
765 ==>
766         let t = let a = e1
767                     b = e2
768                 in (a,b)
769         in fst t
770 ==>
771         let a = e1
772             b = e2
773             t = (a,b)
774         in
775         a       -- Can't inline a this round, cos it appears twice
776 ==>
777         e1
778
779 Each of the ==> steps is a round of simplification.  We'd save a
780 whole round if we float first.  This can cascade.  Consider
781
782         let f = g d
783         in \x -> ...f...
784 ==>
785         let f = let d1 = ..d.. in \y -> e
786         in \x -> ...f...
787 ==>
788         let d1 = ..d..
789         in \x -> ...(\y ->e)...
790
791 Only in this second round can the \y be applied, and it
792 might do the same again.
793
794
795 \begin{code}
796 simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
797 simplExpr env expr = simplExprC env expr mkBoringStop
798
799 simplExprC :: SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr
800         -- Simplify an expression, given a continuation
801 simplExprC env expr cont
802   = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seFloats env) ) $
803     do  { (env', expr') <- simplExprF (zapFloats env) expr cont
804         ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $
805           -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $
806           -- pprTrace "simplExprC ret4" (ppr (seFloats env')) $
807           return (wrapFloats env' expr') }
808
809 --------------------------------------------------
810 simplExprF :: SimplEnv -> InExpr -> SimplCont
811            -> SimplM (SimplEnv, OutExpr)
812
813 simplExprF env e cont
814   = -- pprTrace "simplExprF" (ppr e $$ ppr cont $$ ppr (seTvSubst env) $$ ppr (seIdSubst env) {- $$ ppr (seFloats env) -} ) $
815     simplExprF' env e cont
816
817 simplExprF' :: SimplEnv -> InExpr -> SimplCont
818             -> SimplM (SimplEnv, OutExpr)
819 simplExprF' env (Var v)        cont = simplVar env v cont
820 simplExprF' env (Lit lit)      cont = rebuild env (Lit lit) cont
821 simplExprF' env (Note n expr)  cont = simplNote env n expr cont
822 simplExprF' env (Cast body co) cont = simplCast env body co cont
823 simplExprF' env (App fun arg)  cont = simplExprF env fun $
824                                       ApplyTo NoDup arg env cont
825
826 simplExprF' env expr@(Lam _ _) cont
827   = simplLam env (map zap bndrs) body cont
828         -- The main issue here is under-saturated lambdas
829         --   (\x1. \x2. e) arg1
830         -- Here x1 might have "occurs-once" occ-info, because occ-info
831         -- is computed assuming that a group of lambdas is applied
832         -- all at once.  If there are too few args, we must zap the
833         -- occ-info.
834   where
835     n_args   = countArgs cont
836     n_params = length bndrs
837     (bndrs, body) = collectBinders expr
838     zap | n_args >= n_params = \b -> b
839         | otherwise          = \b -> if isTyVar b then b
840                                      else zapLamIdInfo b
841         -- NB: we count all the args incl type args
842         -- so we must count all the binders (incl type lambdas)
843
844 simplExprF' env (Type ty) cont
845   = ASSERT( contIsRhsOrArg cont )
846     do  { ty' <- simplCoercion env ty
847         ; rebuild env (Type ty') cont }
848
849 simplExprF' env (Case scrut bndr _ alts) cont
850   | not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
851   =     -- Simplify the scrutinee with a Select continuation
852     simplExprF env scrut (Select NoDup bndr alts env cont)
853
854   | otherwise
855   =     -- If case-of-case is off, simply simplify the case expression
856         -- in a vanilla Stop context, and rebuild the result around it
857     do  { case_expr' <- simplExprC env scrut case_cont
858         ; rebuild env case_expr' cont }
859   where
860     case_cont = Select NoDup bndr alts env mkBoringStop
861
862 simplExprF' env (Let (Rec pairs) body) cont
863   = do  { env' <- simplRecBndrs env (map fst pairs)
864                 -- NB: bndrs' don't have unfoldings or rules
865                 -- We add them as we go down
866
867         ; env'' <- simplRecBind env' NotTopLevel pairs
868         ; simplExprF env'' body cont }
869
870 simplExprF' env (Let (NonRec bndr rhs) body) cont
871   = simplNonRecE env bndr (rhs, env) ([], body) cont
872
873 ---------------------------------
874 simplType :: SimplEnv -> InType -> SimplM OutType
875         -- Kept monadic just so we can do the seqType
876 simplType env ty
877   = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $
878     seqType new_ty `seq` return new_ty
879   where
880     new_ty = substTy env ty
881
882 ---------------------------------
883 simplCoercion :: SimplEnv -> InType -> SimplM OutType
884 -- The InType isn't *necessarily* a coercion, but it might be
885 -- (in a type application, say) and optCoercion is a no-op on types
886 simplCoercion env co
887   = seqType new_co `seq` return new_co
888   where 
889     new_co = optCoercion (getTvSubst env) co
890 \end{code}
891
892
893 %************************************************************************
894 %*                                                                      *
895 \subsection{The main rebuilder}
896 %*                                                                      *
897 %************************************************************************
898
899 \begin{code}
900 rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr)
901 -- At this point the substitution in the SimplEnv should be irrelevant
902 -- only the in-scope set and floats should matter
903 rebuild env expr cont0
904   = -- pprTrace "rebuild" (ppr expr $$ ppr cont0 $$ ppr (seFloats env)) $
905     case cont0 of
906       Stop {}                      -> return (env, expr)
907       CoerceIt co cont             -> rebuild env (mkCoerce co expr) cont
908       Select _ bndr alts se cont   -> rebuildCase (se `setFloats` env) expr bndr alts cont
909       StrictArg info _ cont        -> rebuildCall env (info `addArgTo` expr) cont
910       StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr
911                                          ; simplLam env' bs body cont }
912       ApplyTo _ arg se cont        -> do { arg' <- simplExpr (se `setInScope` env) arg
913                                          ; rebuild env (App expr arg') cont }
914 \end{code}
915
916
917 %************************************************************************
918 %*                                                                      *
919 \subsection{Lambdas}
920 %*                                                                      *
921 %************************************************************************
922
923 \begin{code}
924 simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont
925           -> SimplM (SimplEnv, OutExpr)
926 simplCast env body co0 cont0
927   = do  { co1 <- simplCoercion env co0
928         ; simplExprF env body (addCoerce co1 cont0) }
929   where
930        addCoerce co cont = add_coerce co (coercionKind co) cont
931
932        add_coerce _co (s1, k1) cont     -- co :: ty~ty
933          | s1 `coreEqType` k1 = cont    -- is a no-op
934
935        add_coerce co1 (s1, _k2) (CoerceIt co2 cont)
936          | (_l1, t1) <- coercionKind co2
937                 --      e |> (g1 :: S1~L) |> (g2 :: L~T1)
938                 -- ==>
939                 --      e,                       if S1=T1
940                 --      e |> (g1 . g2 :: S1~T1)  otherwise
941                 --
942                 -- For example, in the initial form of a worker
943                 -- we may find  (coerce T (coerce S (\x.e))) y
944                 -- and we'd like it to simplify to e[y/x] in one round
945                 -- of simplification
946          , s1 `coreEqType` t1  = cont            -- The coerces cancel out
947          | otherwise           = CoerceIt (mkTransCoercion co1 co2) cont
948
949        add_coerce co (s1s2, _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont)
950                 -- (f |> g) ty  --->   (f ty) |> (g @ ty)
951                 -- This implements the PushT and PushC rules from the paper
952          | Just (tyvar,_) <- splitForAllTy_maybe s1s2
953          = let 
954              (new_arg_ty, new_cast)
955                | isCoVar tyvar = (new_arg_co, mkCselRCoercion co)       -- PushC rule
956                | otherwise     = (ty',        mkInstCoercion co ty')    -- PushT rule
957            in 
958            ApplyTo dup (Type new_arg_ty) (zapSubstEnv arg_se) (addCoerce new_cast cont)
959          where
960            ty' = substTy (arg_se `setInScope` env) arg_ty
961            new_arg_co = mkCsel1Coercion co  `mkTransCoercion`
962                               ty'           `mkTransCoercion`
963                         mkSymCoercion (mkCsel2Coercion co)
964
965        add_coerce co (s1s2, _t1t2) (ApplyTo dup arg arg_se cont)
966          | not (isTypeArg arg)  -- This implements the Push rule from the paper
967          , isFunTy s1s2   -- t1t2 must be a function type, becuase it's applied
968                 --      (e |> (g :: s1s2 ~ t1->t2)) f
969                 -- ===>
970                 --      (e (f |> (arg g :: t1~s1))
971                 --      |> (res g :: s2->t2)
972                 --
973                 -- t1t2 must be a function type, t1->t2, because it's applied
974                 -- to something but s1s2 might conceivably not be
975                 --
976                 -- When we build the ApplyTo we can't mix the out-types
977                 -- with the InExpr in the argument, so we simply substitute
978                 -- to make it all consistent.  It's a bit messy.
979                 -- But it isn't a common case.
980                 --
981                 -- Example of use: Trac #995
982          = ApplyTo dup new_arg (zapSubstEnv arg_se) (addCoerce co2 cont)
983          where
984            -- we split coercion t1->t2 ~ s1->s2 into t1 ~ s1 and
985            -- t2 ~ s2 with left and right on the curried form:
986            --    (->) t1 t2 ~ (->) s1 s2
987            [co1, co2] = decomposeCo 2 co
988            new_arg    = mkCoerce (mkSymCoercion co1) arg'
989            arg'       = substExpr (arg_se `setInScope` env) arg
990
991        add_coerce co _ cont = CoerceIt co cont
992 \end{code}
993
994
995 %************************************************************************
996 %*                                                                      *
997 \subsection{Lambdas}
998 %*                                                                      *
999 %************************************************************************
1000
1001 \begin{code}
1002 simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont
1003          -> SimplM (SimplEnv, OutExpr)
1004
1005 simplLam env [] body cont = simplExprF env body cont
1006
1007         -- Beta reduction
1008 simplLam env (bndr:bndrs) body (ApplyTo _ arg arg_se cont)
1009   = do  { tick (BetaReduction bndr)
1010         ; simplNonRecE env bndr (arg, arg_se) (bndrs, body) cont }
1011
1012         -- Not enough args, so there are real lambdas left to put in the result
1013 simplLam env bndrs body cont
1014   = do  { (env', bndrs') <- simplLamBndrs env bndrs
1015         ; body' <- simplExpr env' body
1016         ; new_lam <- mkLam env' bndrs' body'
1017         ; rebuild env' new_lam cont }
1018
1019 ------------------
1020 simplNonRecE :: SimplEnv
1021              -> InBndr                  -- The binder
1022              -> (InExpr, SimplEnv)      -- Rhs of binding (or arg of lambda)
1023              -> ([InBndr], InExpr)      -- Body of the let/lambda
1024                                         --      \xs.e
1025              -> SimplCont
1026              -> SimplM (SimplEnv, OutExpr)
1027
1028 -- simplNonRecE is used for
1029 --  * non-top-level non-recursive lets in expressions
1030 --  * beta reduction
1031 --
1032 -- It deals with strict bindings, via the StrictBind continuation,
1033 -- which may abort the whole process
1034 --
1035 -- The "body" of the binding comes as a pair of ([InId],InExpr)
1036 -- representing a lambda; so we recurse back to simplLam
1037 -- Why?  Because of the binder-occ-info-zapping done before
1038 --       the call to simplLam in simplExprF (Lam ...)
1039
1040         -- First deal with type applications and type lets
1041         --   (/\a. e) (Type ty)   and   (let a = Type ty in e)
1042 simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont
1043   = ASSERT( isTyVar bndr )
1044     do  { ty_arg' <- simplType (rhs_se `setInScope` env) ty_arg
1045         ; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont }
1046
1047 simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
1048   | preInlineUnconditionally env NotTopLevel bndr rhs
1049   = do  { tick (PreInlineUnconditionally bndr)
1050         ; simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont }
1051
1052   | isStrictId bndr
1053   = do  { simplExprF (rhs_se `setFloats` env) rhs
1054                      (StrictBind bndr bndrs body env cont) }
1055
1056   | otherwise
1057   = ASSERT( not (isTyVar bndr) )
1058     do  { (env1, bndr1) <- simplNonRecBndr env bndr
1059         ; let (env2, bndr2) = addBndrRules env1 bndr bndr1
1060         ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
1061         ; simplLam env3 bndrs body cont }
1062 \end{code}
1063
1064
1065 %************************************************************************
1066 %*                                                                      *
1067 \subsection{Notes}
1068 %*                                                                      *
1069 %************************************************************************
1070
1071 \begin{code}
1072 -- Hack alert: we only distinguish subsumed cost centre stacks for the
1073 -- purposes of inlining.  All other CCCSs are mapped to currentCCS.
1074 simplNote :: SimplEnv -> Note -> CoreExpr -> SimplCont
1075           -> SimplM (SimplEnv, OutExpr)
1076 simplNote env (SCC cc) e cont
1077   | pushCCisNop cc (getEnclosingCC env)  -- scc "f" (...(scc "f" e)...) 
1078   = simplExprF env e cont                -- ==>  scc "f" (...e...)
1079   | otherwise
1080   = do  { e' <- simplExpr (setEnclosingCC env currentCCS) e
1081         ; rebuild env (mkSCC cc e') cont }
1082
1083 simplNote env (CoreNote s) e cont
1084   = do { e' <- simplExpr env e
1085        ; rebuild env (Note (CoreNote s) e') cont }
1086 \end{code}
1087
1088
1089 %************************************************************************
1090 %*                                                                      *
1091 \subsection{Dealing with calls}
1092 %*                                                                      *
1093 %************************************************************************
1094
1095 \begin{code}
1096 simplVar :: SimplEnv -> Id -> SimplCont -> SimplM (SimplEnv, OutExpr)
1097 simplVar env var cont
1098   = case substId env var of
1099         DoneEx e         -> simplExprF (zapSubstEnv env) e cont
1100         ContEx tvs ids e -> simplExprF (setSubstEnv env tvs ids) e cont
1101         DoneId var1      -> completeCall env var1 cont
1102                 -- Note [zapSubstEnv]
1103                 -- The template is already simplified, so don't re-substitute.
1104                 -- This is VITAL.  Consider
1105                 --      let x = e in
1106                 --      let y = \z -> ...x... in
1107                 --      \ x -> ...y...
1108                 -- We'll clone the inner \x, adding x->x' in the id_subst
1109                 -- Then when we inline y, we must *not* replace x by x' in
1110                 -- the inlined copy!!
1111
1112 ---------------------------------------------------------
1113 --      Dealing with a call site
1114
1115 completeCall :: SimplEnv -> Id -> SimplCont -> SimplM (SimplEnv, OutExpr)
1116 completeCall env var cont
1117   = do  {   ------------- Try inlining ----------------
1118           dflags <- getDOptsSmpl
1119         ; let  (args,call_cont) = contArgs cont
1120                 -- The args are OutExprs, obtained by *lazily* substituting
1121                 -- in the args found in cont.  These args are only examined
1122                 -- to limited depth (unless a rule fires).  But we must do
1123                 -- the substitution; rule matching on un-simplified args would
1124                 -- be bogus
1125
1126                arg_infos  = [interestingArg arg | arg <- args, isValArg arg]
1127                n_val_args = length arg_infos
1128                interesting_cont = interestingCallContext call_cont
1129                unfolding    = activeUnfolding env var
1130                maybe_inline = callSiteInline dflags var unfolding
1131                                              (null args) arg_infos interesting_cont
1132         ; case maybe_inline of {
1133             Just unfolding      -- There is an inlining!
1134               ->  do { tick (UnfoldingDone var)
1135                      ; trace_inline dflags unfolding args call_cont $
1136                        simplExprF (zapSubstEnv env) unfolding cont }
1137
1138             ; Nothing -> do               -- No inlining!
1139
1140         { rule_base <- getSimplRules
1141         ; let info = mkArgInfo var (getRules rule_base var) n_val_args call_cont
1142         ; rebuildCall env info cont
1143     }}}
1144   where
1145     trace_inline dflags unfolding args call_cont stuff
1146       | not (dopt Opt_D_dump_inlinings dflags) = stuff
1147       | not (dopt Opt_D_verbose_core2core dflags) 
1148       = if isExternalName (idName var) then 
1149           pprTrace "Inlining done:" (ppr var) stuff
1150         else stuff
1151       | otherwise
1152       = pprTrace ("Inlining done: " ++ showSDoc (ppr var))
1153            (vcat [text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
1154                   text "Inlined fn: " <+> nest 2 (ppr unfolding),
1155                   text "Cont:  " <+> ppr call_cont])
1156            stuff
1157
1158 rebuildCall :: SimplEnv
1159             -> ArgInfo
1160             -> SimplCont
1161             -> SimplM (SimplEnv, OutExpr)
1162 rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) cont
1163   -- When we run out of strictness args, it means
1164   -- that the call is definitely bottom; see SimplUtils.mkArgInfo
1165   -- Then we want to discard the entire strict continuation.  E.g.
1166   --    * case (error "hello") of { ... }
1167   --    * (error "Hello") arg
1168   --    * f (error "Hello") where f is strict
1169   --    etc
1170   -- Then, especially in the first of these cases, we'd like to discard
1171   -- the continuation, leaving just the bottoming expression.  But the
1172   -- type might not be right, so we may have to add a coerce.
1173   | not (contIsTrivial cont)     -- Only do this if there is a non-trivial
1174   = return (env, mk_coerce res)  -- contination to discard, else we do it
1175   where                          -- again and again!
1176     res     = mkApps (Var fun) (reverse rev_args)
1177     res_ty  = exprType res
1178     cont_ty = contResultType env res_ty cont
1179     co      = mkUnsafeCoercion res_ty cont_ty
1180     mk_coerce expr | cont_ty `coreEqType` res_ty = expr
1181                    | otherwise = mkCoerce co expr
1182
1183 rebuildCall env info (ApplyTo _ (Type arg_ty) se cont)
1184   = do  { ty' <- simplCoercion (se `setInScope` env) arg_ty
1185         ; rebuildCall env (info `addArgTo` Type ty') cont }
1186
1187 rebuildCall env info@(ArgInfo { ai_encl = encl_rules
1188                               , ai_strs = str:strs, ai_discs = disc:discs })
1189             (ApplyTo _ arg arg_se cont)
1190   | str                 -- Strict argument
1191   = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
1192     simplExprF (arg_se `setFloats` env) arg
1193                (StrictArg info' cci cont)
1194                 -- Note [Shadowing]
1195
1196   | otherwise                           -- Lazy argument
1197         -- DO NOT float anything outside, hence simplExprC
1198         -- There is no benefit (unlike in a let-binding), and we'd
1199         -- have to be very careful about bogus strictness through
1200         -- floating a demanded let.
1201   = do  { arg' <- simplExprC (arg_se `setInScope` env) arg
1202                              (mkLazyArgStop cci)
1203         ; rebuildCall env (addArgTo info' arg') cont }
1204   where
1205     info' = info { ai_strs = strs, ai_discs = discs }
1206     cci | encl_rules || disc > 0 = ArgCtxt encl_rules  -- Be keener here
1207         | otherwise              = BoringCtxt          -- Nothing interesting
1208
1209 rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) cont
1210   = do {  -- We've accumulated a simplified call in <fun,rev_args> 
1211           -- so try rewrite rules; see Note [RULEs apply to simplified arguments]
1212           -- See also Note [Rules for recursive functions]
1213         ; let args = reverse rev_args
1214               env' = zapSubstEnv env
1215         ; mb_rule <- tryRules env rules fun args cont
1216         ; case mb_rule of {
1217              Just (n_args, rule_rhs) -> simplExprF env' rule_rhs $
1218                                         pushArgs env' (drop n_args args) cont ;
1219                  -- n_args says how many args the rule consumed
1220            ; Nothing -> rebuild env (mkApps (Var fun) args) cont      -- No rules
1221     } }
1222 \end{code}
1223
1224 Note [RULES apply to simplified arguments]
1225 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1226 It's very desirable to try RULES once the arguments have been simplified, because
1227 doing so ensures that rule cascades work in one pass.  Consider
1228    {-# RULES g (h x) = k x
1229             f (k x) = x #-}
1230    ...f (g (h x))...
1231 Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If
1232 we match f's rules against the un-simplified RHS, it won't match.  This 
1233 makes a particularly big difference when superclass selectors are involved:
1234         op ($p1 ($p2 (df d)))
1235 We want all this to unravel in one sweeep.
1236
1237 Note [Shadowing]
1238 ~~~~~~~~~~~~~~~~
1239 This part of the simplifier may break the no-shadowing invariant
1240 Consider
1241         f (...(\a -> e)...) (case y of (a,b) -> e')
1242 where f is strict in its second arg
1243 If we simplify the innermost one first we get (...(\a -> e)...)
1244 Simplifying the second arg makes us float the case out, so we end up with
1245         case y of (a,b) -> f (...(\a -> e)...) e'
1246 So the output does not have the no-shadowing invariant.  However, there is
1247 no danger of getting name-capture, because when the first arg was simplified
1248 we used an in-scope set that at least mentioned all the variables free in its
1249 static environment, and that is enough.
1250
1251 We can't just do innermost first, or we'd end up with a dual problem:
1252         case x of (a,b) -> f e (...(\a -> e')...)
1253
1254 I spent hours trying to recover the no-shadowing invariant, but I just could
1255 not think of an elegant way to do it.  The simplifier is already knee-deep in
1256 continuations.  We have to keep the right in-scope set around; AND we have
1257 to get the effect that finding (error "foo") in a strict arg position will
1258 discard the entire application and replace it with (error "foo").  Getting
1259 all this at once is TOO HARD!
1260
1261
1262 %************************************************************************
1263 %*                                                                      *
1264                 Rewrite rules
1265 %*                                                                      *
1266 %************************************************************************
1267
1268 \begin{code}
1269 tryRules :: SimplEnv -> [CoreRule]
1270          -> Id -> [OutExpr] -> SimplCont 
1271          -> SimplM (Maybe (Arity, CoreExpr))         -- The arity is the number of
1272                                                      -- args consumed by the rule
1273 tryRules env rules fn args call_cont
1274   | null rules
1275   = return Nothing
1276   | otherwise
1277   = do { dflags <- getDOptsSmpl
1278        ; case activeRule dflags env of {
1279            Nothing     -> return Nothing  ; -- No rules apply
1280            Just act_fn -> 
1281          case lookupRule act_fn (activeUnfInRule env) (getInScope env) fn args rules of {
1282            Nothing               -> return Nothing ;   -- No rule matches
1283            Just (rule, rule_rhs) ->
1284
1285              do { tick (RuleFired (ru_name rule))
1286                 ; trace_dump dflags rule rule_rhs $
1287                   return (Just (ruleArity rule, rule_rhs)) }}}}
1288   where
1289     trace_dump dflags rule rule_rhs stuff
1290       | not (dopt Opt_D_dump_rule_firings dflags) = stuff
1291       | not (dopt Opt_D_verbose_core2core dflags) 
1292
1293       = pprTrace "Rule fired:" (ftext (ru_name rule)) stuff
1294       | otherwise
1295       = pprTrace "Rule fired"
1296            (vcat [text "Rule:" <+> ftext (ru_name rule),
1297                   text "Before:" <+> ppr fn <+> sep (map pprParendExpr args),
1298                   text "After: " <+> pprCoreExpr rule_rhs,
1299                   text "Cont:  " <+> ppr call_cont])
1300            stuff
1301 \end{code}
1302
1303 Note [Rules for recursive functions]
1304 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1305 You might think that we shouldn't apply rules for a loop breaker:
1306 doing so might give rise to an infinite loop, because a RULE is
1307 rather like an extra equation for the function:
1308      RULE:           f (g x) y = x+y
1309      Eqn:            f a     y = a-y
1310
1311 But it's too drastic to disable rules for loop breakers.
1312 Even the foldr/build rule would be disabled, because foldr
1313 is recursive, and hence a loop breaker:
1314      foldr k z (build g) = g k z
1315 So it's up to the programmer: rules can cause divergence
1316
1317
1318 %************************************************************************
1319 %*                                                                      *
1320                 Rebuilding a cse expression
1321 %*                                                                      *
1322 %************************************************************************
1323
1324 Note [Case elimination]
1325 ~~~~~~~~~~~~~~~~~~~~~~~
1326 The case-elimination transformation discards redundant case expressions.
1327 Start with a simple situation:
1328
1329         case x# of      ===>   e[x#/y#]
1330           y# -> e
1331
1332 (when x#, y# are of primitive type, of course).  We can't (in general)
1333 do this for algebraic cases, because we might turn bottom into
1334 non-bottom!
1335
1336 The code in SimplUtils.prepareAlts has the effect of generalise this
1337 idea to look for a case where we're scrutinising a variable, and we
1338 know that only the default case can match.  For example:
1339
1340         case x of
1341           0#      -> ...
1342           DEFAULT -> ...(case x of
1343                          0#      -> ...
1344                          DEFAULT -> ...) ...
1345
1346 Here the inner case is first trimmed to have only one alternative, the
1347 DEFAULT, after which it's an instance of the previous case.  This
1348 really only shows up in eliminating error-checking code.
1349
1350 We also make sure that we deal with this very common case:
1351
1352         case e of
1353           x -> ...x...
1354
1355 Here we are using the case as a strict let; if x is used only once
1356 then we want to inline it.  We have to be careful that this doesn't
1357 make the program terminate when it would have diverged before, so we
1358 check that
1359         - e is already evaluated (it may so if e is a variable)
1360         - x is used strictly, or
1361
1362 Lastly, the code in SimplUtils.mkCase combines identical RHSs.  So
1363
1364         case e of       ===> case e of DEFAULT -> r
1365            True  -> r
1366            False -> r
1367
1368 Now again the case may be elminated by the CaseElim transformation.
1369
1370
1371 Further notes about case elimination
1372 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1373 Consider:       test :: Integer -> IO ()
1374                 test = print
1375
1376 Turns out that this compiles to:
1377     Print.test
1378       = \ eta :: Integer
1379           eta1 :: State# RealWorld ->
1380           case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->
1381           case hPutStr stdout
1382                  (PrelNum.jtos eta ($w[] @ Char))
1383                  eta1
1384           of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s  }}
1385
1386 Notice the strange '<' which has no effect at all. This is a funny one.
1387 It started like this:
1388
1389 f x y = if x < 0 then jtos x
1390           else if y==0 then "" else jtos x
1391
1392 At a particular call site we have (f v 1).  So we inline to get
1393
1394         if v < 0 then jtos x
1395         else if 1==0 then "" else jtos x
1396
1397 Now simplify the 1==0 conditional:
1398
1399         if v<0 then jtos v else jtos v
1400
1401 Now common-up the two branches of the case:
1402
1403         case (v<0) of DEFAULT -> jtos v
1404
1405 Why don't we drop the case?  Because it's strict in v.  It's technically
1406 wrong to drop even unnecessary evaluations, and in practice they
1407 may be a result of 'seq' so we *definitely* don't want to drop those.
1408 I don't really know how to improve this situation.
1409
1410 \begin{code}
1411 ---------------------------------------------------------
1412 --      Eliminate the case if possible
1413
1414 rebuildCase, reallyRebuildCase
1415    :: SimplEnv
1416    -> OutExpr          -- Scrutinee
1417    -> InId             -- Case binder
1418    -> [InAlt]          -- Alternatives (inceasing order)
1419    -> SimplCont
1420    -> SimplM (SimplEnv, OutExpr)
1421
1422 --------------------------------------------------
1423 --      1. Eliminate the case if there's a known constructor
1424 --------------------------------------------------
1425
1426 rebuildCase env scrut case_bndr alts cont
1427   | Lit lit <- scrut    -- No need for same treatment as constructors
1428                         -- because literals are inlined more vigorously
1429   = do  { tick (KnownBranch case_bndr)
1430         ; case findAlt (LitAlt lit) alts of
1431             Nothing           -> missingAlt env case_bndr alts cont
1432             Just (_, bs, rhs) -> simple_rhs bs rhs }
1433
1434   | Just (con, ty_args, other_args) <- exprIsConApp_maybe (activeUnfInRule env) scrut
1435         -- Works when the scrutinee is a variable with a known unfolding
1436         -- as well as when it's an explicit constructor application
1437   = do  { tick (KnownBranch case_bndr)
1438         ; case findAlt (DataAlt con) alts of
1439             Nothing  -> missingAlt env case_bndr alts cont
1440             Just (DEFAULT, bs, rhs) -> simple_rhs bs rhs
1441             Just (_, bs, rhs)       -> knownCon env scrut con ty_args other_args 
1442                                                 case_bndr bs rhs cont
1443         }
1444   where
1445     simple_rhs bs rhs = ASSERT( null bs ) 
1446                         do { env' <- simplNonRecX env case_bndr scrut
1447                            ; simplExprF env' rhs cont }
1448
1449
1450 --------------------------------------------------
1451 --      2. Eliminate the case if scrutinee is evaluated
1452 --------------------------------------------------
1453
1454 rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont
1455   -- See if we can get rid of the case altogether
1456   -- See Note [Case eliminiation] 
1457   -- mkCase made sure that if all the alternatives are equal,
1458   -- then there is now only one (DEFAULT) rhs
1459  | all isDeadBinder bndrs       -- bndrs are [InId]
1460
1461         -- Check that the scrutinee can be let-bound instead of case-bound
1462  , exprOkForSpeculation scrut
1463                 -- OK not to evaluate it
1464                 -- This includes things like (==# a# b#)::Bool
1465                 -- so that we simplify
1466                 --      case ==# a# b# of { True -> x; False -> x }
1467                 -- to just
1468                 --      x
1469                 -- This particular example shows up in default methods for
1470                 -- comparision operations (e.g. in (>=) for Int.Int32)
1471         || exprIsHNF scrut                      -- It's already evaluated
1472         || var_demanded_later scrut             -- It'll be demanded later
1473
1474 --      || not opt_SimplPedanticBottoms)        -- Or we don't care!
1475 --      We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on,
1476 --      but that breaks badly for the dataToTag# primop, which relies on a case to evaluate
1477 --      its argument:  case x of { y -> dataToTag# y }
1478 --      Here we must *not* discard the case, because dataToTag# just fetches the tag from
1479 --      the info pointer.  So we'll be pedantic all the time, and see if that gives any
1480 --      other problems
1481 --      Also we don't want to discard 'seq's
1482   = do  { tick (CaseElim case_bndr)
1483         ; env' <- simplNonRecX env case_bndr scrut
1484         ; simplExprF env' rhs cont }
1485   where
1486         -- The case binder is going to be evaluated later,
1487         -- and the scrutinee is a simple variable
1488     var_demanded_later (Var v) = isStrictDmd (idDemandInfo case_bndr)
1489                                  && not (isTickBoxOp v)
1490                                     -- ugly hack; covering this case is what
1491                                     -- exprOkForSpeculation was intended for.
1492     var_demanded_later _       = False
1493
1494 --------------------------------------------------
1495 --      3. Try seq rules; see Note [User-defined RULES for seq] in MkId
1496 --------------------------------------------------
1497
1498 rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont
1499   | all isDeadBinder (case_bndr : bndrs)  -- So this is just 'seq'
1500   = do { let rhs' = substExpr env rhs
1501              out_args = [Type (substTy env (idType case_bndr)), 
1502                          Type (exprType rhs'), scrut, rhs']
1503                       -- Lazily evaluated, so we don't do most of this
1504
1505        ; rule_base <- getSimplRules
1506        ; mb_rule <- tryRules env (getRules rule_base seqId) seqId out_args cont
1507        ; case mb_rule of 
1508            Just (n_args, res) -> simplExprF (zapSubstEnv env) 
1509                                             (mkApps res (drop n_args out_args))
1510                                             cont
1511            Nothing -> reallyRebuildCase env scrut case_bndr alts cont }
1512
1513 rebuildCase env scrut case_bndr alts cont
1514   = reallyRebuildCase env scrut case_bndr alts cont
1515
1516 --------------------------------------------------
1517 --      3. Catch-all case
1518 --------------------------------------------------
1519
1520 reallyRebuildCase env scrut case_bndr alts cont
1521   = do  {       -- Prepare the continuation;
1522                 -- The new subst_env is in place
1523           (env', dup_cont, nodup_cont) <- prepareCaseCont env alts cont
1524
1525         -- Simplify the alternatives
1526         ; (scrut', case_bndr', alts') <- simplAlts env' scrut case_bndr alts dup_cont
1527
1528         -- Check for empty alternatives
1529         ; if null alts' then missingAlt env case_bndr alts cont
1530           else do
1531         { dflags <- getDOptsSmpl
1532         ; case_expr <- mkCase dflags scrut' case_bndr' alts'
1533
1534         -- Notice that rebuild gets the in-scope set from env', not alt_env
1535         -- (which in any case is only build in simplAlts)
1536         -- The case binder *not* scope over the whole returned case-expression
1537         ; rebuild env' case_expr nodup_cont } }
1538 \end{code}
1539
1540 simplCaseBinder checks whether the scrutinee is a variable, v.  If so,
1541 try to eliminate uses of v in the RHSs in favour of case_bndr; that
1542 way, there's a chance that v will now only be used once, and hence
1543 inlined.
1544
1545 Historical note: we use to do the "case binder swap" in the Simplifier
1546 so there were additional complications if the scrutinee was a variable.
1547 Now the binder-swap stuff is done in the occurrence analyer; see
1548 OccurAnal Note [Binder swap].
1549
1550 Note [zapOccInfo]
1551 ~~~~~~~~~~~~~~~~~
1552 If the case binder is not dead, then neither are the pattern bound
1553 variables:  
1554         case <any> of x { (a,b) ->
1555         case x of { (p,q) -> p } }
1556 Here (a,b) both look dead, but come alive after the inner case is eliminated.
1557 The point is that we bring into the envt a binding
1558         let x = (a,b)
1559 after the outer case, and that makes (a,b) alive.  At least we do unless
1560 the case binder is guaranteed dead.
1561
1562 In practice, the scrutinee is almost always a variable, so we pretty
1563 much always zap the OccInfo of the binders.  It doesn't matter much though.
1564
1565
1566 Note [Case of cast]
1567 ~~~~~~~~~~~~~~~~~~~
1568 Consider        case (v `cast` co) of x { I# y ->
1569                 ... (case (v `cast` co) of {...}) ...
1570 We'd like to eliminate the inner case.  We can get this neatly by
1571 arranging that inside the outer case we add the unfolding
1572         v |-> x `cast` (sym co)
1573 to v.  Then we should inline v at the inner case, cancel the casts, and away we go
1574
1575 Note [Improving seq]
1576 ~~~~~~~~~~~~~~~~~~~
1577 Consider
1578         type family F :: * -> *
1579         type instance F Int = Int
1580
1581         ... case e of x { DEFAULT -> rhs } ...
1582
1583 where x::F Int.  Then we'd like to rewrite (F Int) to Int, getting
1584
1585         case e `cast` co of x'::Int
1586            I# x# -> let x = x' `cast` sym co
1587                     in rhs
1588
1589 so that 'rhs' can take advantage of the form of x'.  
1590
1591 Notice that Note [Case of cast] may then apply to the result. 
1592
1593 Nota Bene: We only do the [Improving seq] transformation if the 
1594 case binder 'x' is actually used in the rhs; that is, if the case 
1595 is *not* a *pure* seq.  
1596   a) There is no point in adding the cast to a pure seq.
1597   b) There is a good reason not to: doing so would interfere 
1598      with seq rules (Note [Built-in RULES for seq] in MkId).
1599      In particular, this [Improving seq] thing *adds* a cast
1600      while [Built-in RULES for seq] *removes* one, so they
1601      just flip-flop.
1602
1603 You might worry about 
1604    case v of x { __DEFAULT ->
1605       ... case (v `cast` co) of y { I# -> ... }}
1606 This is a pure seq (since x is unused), so [Improving seq] won't happen.
1607 But it's ok: the simplifier will replace 'v' by 'x' in the rhs to get
1608    case v of x { __DEFAULT ->
1609       ... case (x `cast` co) of y { I# -> ... }}
1610 Now the outer case is not a pure seq, so [Improving seq] will happen,
1611 and then the inner case will disappear.
1612
1613 The need for [Improving seq] showed up in Roman's experiments.  Example:
1614   foo :: F Int -> Int -> Int
1615   foo t n = t `seq` bar n
1616      where
1617        bar 0 = 0
1618        bar n = bar (n - case t of TI i -> i)
1619 Here we'd like to avoid repeated evaluating t inside the loop, by
1620 taking advantage of the `seq`.
1621
1622 At one point I did transformation in LiberateCase, but it's more
1623 robust here.  (Otherwise, there's a danger that we'll simply drop the
1624 'seq' altogether, before LiberateCase gets to see it.)
1625
1626 \begin{code}
1627 simplAlts :: SimplEnv
1628           -> OutExpr
1629           -> InId                       -- Case binder
1630           -> [InAlt]                    -- Non-empty
1631           -> SimplCont
1632           -> SimplM (OutExpr, OutId, [OutAlt])  -- Includes the continuation
1633 -- Like simplExpr, this just returns the simplified alternatives;
1634 -- it does not return an environment
1635
1636 simplAlts env scrut case_bndr alts cont'
1637   = -- pprTrace "simplAlts" (ppr alts $$ ppr (seIdSubst env)) $
1638     do  { let env0 = zapFloats env
1639
1640         ; (env1, case_bndr1) <- simplBinder env0 case_bndr
1641
1642         ; fam_envs <- getFamEnvs
1643         ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env1 scrut 
1644                                                        case_bndr case_bndr1 alts
1645
1646         ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts
1647
1648         ; alts' <- mapM (simplAlt alt_env' imposs_deflt_cons case_bndr' cont') in_alts
1649         ; return (scrut', case_bndr', alts') }
1650
1651
1652 ------------------------------------
1653 improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv
1654            -> OutExpr -> InId -> OutId -> [InAlt]
1655            -> SimplM (SimplEnv, OutExpr, OutId)
1656 -- Note [Improving seq]
1657 improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)]
1658   | not (isDeadBinder case_bndr)        -- Not a pure seq!  See the Note!
1659   , Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1)
1660   = do { case_bndr2 <- newId (fsLit "nt") ty2
1661         ; let rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co)
1662               env2 = extendIdSubst env case_bndr rhs
1663         ; return (env2, scrut `Cast` co, case_bndr2) }
1664
1665 improveSeq _ env scrut _ case_bndr1 _
1666   = return (env, scrut, case_bndr1)
1667
1668
1669 ------------------------------------
1670 simplAlt :: SimplEnv
1671          -> [AltCon]    -- These constructors can't be present when
1672                         -- matching the DEFAULT alternative
1673          -> OutId       -- The case binder
1674          -> SimplCont
1675          -> InAlt
1676          -> SimplM OutAlt
1677
1678 simplAlt env imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs)
1679   = ASSERT( null bndrs )
1680     do  { let env' = addBinderOtherCon env case_bndr' imposs_deflt_cons
1681                 -- Record the constructors that the case-binder *can't* be.
1682         ; rhs' <- simplExprC env' rhs cont'
1683         ; return (DEFAULT, [], rhs') }
1684
1685 simplAlt env _ case_bndr' cont' (LitAlt lit, bndrs, rhs)
1686   = ASSERT( null bndrs )
1687     do  { let env' = addBinderUnfolding env case_bndr' (Lit lit)
1688         ; rhs' <- simplExprC env' rhs cont'
1689         ; return (LitAlt lit, [], rhs') }
1690
1691 simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs)
1692   = do  {       -- Deal with the pattern-bound variables
1693                 -- Mark the ones that are in ! positions in the
1694                 -- data constructor as certainly-evaluated.
1695                 -- NB: simplLamBinders preserves this eval info
1696           let vs_with_evals = add_evals (dataConRepStrictness con)
1697         ; (env', vs') <- simplLamBndrs env vs_with_evals
1698
1699                 -- Bind the case-binder to (con args)
1700         ; let inst_tys' = tyConAppArgs (idType case_bndr')
1701               con_args  = map Type inst_tys' ++ varsToCoreExprs vs'
1702               env''     = addBinderUnfolding env' case_bndr'
1703                                              (mkConApp con con_args)
1704
1705         ; rhs' <- simplExprC env'' rhs cont'
1706         ; return (DataAlt con, vs', rhs') }
1707   where
1708         -- add_evals records the evaluated-ness of the bound variables of
1709         -- a case pattern.  This is *important*.  Consider
1710         --      data T = T !Int !Int
1711         --
1712         --      case x of { T a b -> T (a+1) b }
1713         --
1714         -- We really must record that b is already evaluated so that we don't
1715         -- go and re-evaluate it when constructing the result.
1716         -- See Note [Data-con worker strictness] in MkId.lhs
1717     add_evals the_strs
1718         = go vs the_strs
1719         where
1720           go [] [] = []
1721           go (v:vs') strs | isTyVar v = v : go vs' strs
1722           go (v:vs') (str:strs)
1723             | isMarkedStrict str = evald_v  : go vs' strs
1724             | otherwise          = zapped_v : go vs' strs
1725             where
1726               zapped_v = zap_occ_info v
1727               evald_v  = zapped_v `setIdUnfolding` evaldUnfolding
1728           go _ _ = pprPanic "cat_evals" (ppr con $$ ppr vs $$ ppr the_strs)
1729
1730         -- See Note [zapOccInfo]
1731         -- zap_occ_info: if the case binder is alive, then we add the unfolding
1732         --      case_bndr = C vs
1733         -- to the envt; so vs are now very much alive
1734         -- Note [Aug06] I can't see why this actually matters, but it's neater
1735         --        case e of t { (a,b) -> ...(case t of (p,q) -> p)... }
1736         --   ==>  case e of t { (a,b) -> ...(a)... }
1737         -- Look, Ma, a is alive now.
1738     zap_occ_info = zapCasePatIdOcc case_bndr'
1739
1740 addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv
1741 addBinderUnfolding env bndr rhs
1742   = modifyInScope env (bndr `setIdUnfolding` mkUnfolding False False rhs)
1743
1744 addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv
1745 addBinderOtherCon env bndr cons
1746   = modifyInScope env (bndr `setIdUnfolding` mkOtherCon cons)
1747
1748 zapCasePatIdOcc :: Id -> Id -> Id
1749 -- Consider  case e of b { (a,b) -> ... }
1750 -- Then if we bind b to (a,b) in "...", and b is not dead,
1751 -- then we must zap the deadness info on a,b
1752 zapCasePatIdOcc case_bndr
1753   | isDeadBinder case_bndr = \ pat_id -> pat_id
1754   | otherwise              = \ pat_id -> zapIdOccInfo pat_id
1755 \end{code}
1756
1757
1758 %************************************************************************
1759 %*                                                                      *
1760 \subsection{Known constructor}
1761 %*                                                                      *
1762 %************************************************************************
1763
1764 We are a bit careful with occurrence info.  Here's an example
1765
1766         (\x* -> case x of (a*, b) -> f a) (h v, e)
1767
1768 where the * means "occurs once".  This effectively becomes
1769         case (h v, e) of (a*, b) -> f a)
1770 and then
1771         let a* = h v; b = e in f a
1772 and then
1773         f (h v)
1774
1775 All this should happen in one sweep.
1776
1777 \begin{code}
1778 knownCon :: SimplEnv            
1779          -> OutExpr                             -- The scrutinee
1780          -> DataCon -> [OutType] -> [OutExpr]   -- The scrutinee (in pieces)
1781          -> InId -> [InBndr] -> InExpr          -- The alternative
1782          -> SimplCont
1783          -> SimplM (SimplEnv, OutExpr)
1784
1785 knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont
1786   = do  { env' <- bind_args env bs dc_args
1787         ; let
1788                 -- It's useful to bind bndr to scrut, rather than to a fresh
1789                 -- binding      x = Con arg1 .. argn
1790                 -- because very often the scrut is a variable, so we avoid
1791                 -- creating, and then subsequently eliminating, a let-binding
1792                 -- BUT, if scrut is a not a variable, we must be careful
1793                 -- about duplicating the arg redexes; in that case, make
1794                 -- a new con-app from the args
1795                 bndr_rhs | exprIsTrivial scrut = scrut
1796                          | otherwise           = con_app
1797                 con_app = Var (dataConWorkId dc) 
1798                           `mkTyApps` dc_ty_args
1799                           `mkApps`   [substExpr env' (varToCoreExpr b) | b <- bs]
1800                          -- dc_ty_args are aready OutTypes, but bs are InBndrs
1801
1802         ; env'' <- simplNonRecX env' bndr bndr_rhs
1803         ; simplExprF env'' rhs cont }
1804   where
1805     zap_occ = zapCasePatIdOcc bndr    -- bndr is an InId
1806
1807                   -- Ugh!
1808     bind_args env' [] _  = return env'
1809
1810     bind_args env' (b:bs') (Type ty : args)
1811       = ASSERT( isTyVar b )
1812         bind_args (extendTvSubst env' b ty) bs' args
1813
1814     bind_args env' (b:bs') (arg : args)
1815       = ASSERT( isId b )
1816         do { let b' = zap_occ b
1817              -- Note that the binder might be "dead", because it doesn't
1818              -- occur in the RHS; and simplNonRecX may therefore discard
1819              -- it via postInlineUnconditionally.
1820              -- Nevertheless we must keep it if the case-binder is alive,
1821              -- because it may be used in the con_app.  See Note [zapOccInfo]
1822            ; env'' <- simplNonRecX env' b' arg
1823            ; bind_args env'' bs' args }
1824
1825     bind_args _ _ _ =
1826       pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$
1827                              text "scrut:" <+> ppr scrut
1828
1829 -------------------
1830 missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont -> SimplM (SimplEnv, OutExpr)
1831                 -- This isn't strictly an error, although it is unusual. 
1832                 -- It's possible that the simplifer might "see" that 
1833                 -- an inner case has no accessible alternatives before 
1834                 -- it "sees" that the entire branch of an outer case is 
1835                 -- inaccessible.  So we simply put an error case here instead.
1836 missingAlt env case_bndr alts cont
1837   = WARN( True, ptext (sLit "missingAlt") <+> ppr case_bndr )
1838     return (env, mkImpossibleExpr res_ty)
1839   where
1840     res_ty = contResultType env (substTy env (coreAltsType alts)) cont
1841 \end{code}
1842
1843
1844 %************************************************************************
1845 %*                                                                      *
1846 \subsection{Duplicating continuations}
1847 %*                                                                      *
1848 %************************************************************************
1849
1850 \begin{code}
1851 prepareCaseCont :: SimplEnv
1852                 -> [InAlt] -> SimplCont
1853                 -> SimplM (SimplEnv, SimplCont,SimplCont)
1854                         -- Return a duplicatable continuation, a non-duplicable part
1855                         -- plus some extra bindings (that scope over the entire
1856                         -- continunation)
1857
1858         -- No need to make it duplicatable if there's only one alternative
1859 prepareCaseCont env [_] cont = return (env, cont, mkBoringStop)
1860 prepareCaseCont env _   cont = mkDupableCont env cont
1861 \end{code}
1862
1863 \begin{code}
1864 mkDupableCont :: SimplEnv -> SimplCont
1865               -> SimplM (SimplEnv, SimplCont, SimplCont)
1866
1867 mkDupableCont env cont
1868   | contIsDupable cont
1869   = return (env, cont, mkBoringStop)
1870
1871 mkDupableCont _   (Stop {}) = panic "mkDupableCont"     -- Handled by previous eqn
1872
1873 mkDupableCont env (CoerceIt ty cont)
1874   = do  { (env', dup, nodup) <- mkDupableCont env cont
1875         ; return (env', CoerceIt ty dup, nodup) }
1876
1877 mkDupableCont env cont@(StrictBind {})
1878   =  return (env, mkBoringStop, cont)
1879         -- See Note [Duplicating StrictBind]
1880
1881 mkDupableCont env (StrictArg info cci cont)
1882         -- See Note [Duplicating StrictArg]
1883   = do { (env', dup, nodup) <- mkDupableCont env cont
1884        ; (env'', args')     <- mapAccumLM makeTrivial env' (ai_args info)
1885        ; return (env'', StrictArg (info { ai_args = args' }) cci dup, nodup) }
1886
1887 mkDupableCont env (ApplyTo _ arg se cont)
1888   =     -- e.g.         [...hole...] (...arg...)
1889         --      ==>
1890         --              let a = ...arg...
1891         --              in [...hole...] a
1892     do  { (env', dup_cont, nodup_cont) <- mkDupableCont env cont
1893         ; arg' <- simplExpr (se `setInScope` env') arg
1894         ; (env'', arg'') <- makeTrivial env' arg'
1895         ; let app_cont = ApplyTo OkToDup arg'' (zapSubstEnv env'') dup_cont
1896         ; return (env'', app_cont, nodup_cont) }
1897
1898 mkDupableCont env cont@(Select _ case_bndr [(_, bs, _rhs)] _ _)
1899 --  See Note [Single-alternative case]
1900 --  | not (exprIsDupable rhs && contIsDupable case_cont)
1901 --  | not (isDeadBinder case_bndr)
1902   | all isDeadBinder bs  -- InIds
1903     && not (isUnLiftedType (idType case_bndr))
1904     -- Note [Single-alternative-unlifted]
1905   = return (env, mkBoringStop, cont)
1906
1907 mkDupableCont env (Select _ case_bndr alts se cont)
1908   =     -- e.g.         (case [...hole...] of { pi -> ei })
1909         --      ===>
1910         --              let ji = \xij -> ei
1911         --              in case [...hole...] of { pi -> ji xij }
1912     do  { tick (CaseOfCase case_bndr)
1913         ; (env', dup_cont, nodup_cont) <- mkDupableCont env cont
1914                 -- NB: call mkDupableCont here, *not* prepareCaseCont
1915                 -- We must make a duplicable continuation, whereas prepareCaseCont
1916                 -- doesn't when there is a single case branch
1917
1918         ; let alt_env = se `setInScope` env'
1919         ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr
1920         ; alts' <- mapM (simplAlt alt_env' [] case_bndr' dup_cont) alts
1921         -- Safe to say that there are no handled-cons for the DEFAULT case
1922                 -- NB: simplBinder does not zap deadness occ-info, so
1923                 -- a dead case_bndr' will still advertise its deadness
1924                 -- This is really important because in
1925                 --      case e of b { (# p,q #) -> ... }
1926                 -- b is always dead, and indeed we are not allowed to bind b to (# p,q #),
1927                 -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.
1928                 -- In the new alts we build, we have the new case binder, so it must retain
1929                 -- its deadness.
1930         -- NB: we don't use alt_env further; it has the substEnv for
1931         --     the alternatives, and we don't want that
1932
1933         ; (env'', alts'') <- mkDupableAlts env' case_bndr' alts'
1934         ; return (env'',  -- Note [Duplicated env]
1935                   Select OkToDup case_bndr' alts'' (zapSubstEnv env'') mkBoringStop,
1936                   nodup_cont) }
1937
1938
1939 mkDupableAlts :: SimplEnv -> OutId -> [InAlt]
1940               -> SimplM (SimplEnv, [InAlt])
1941 -- Absorbs the continuation into the new alternatives
1942
1943 mkDupableAlts env case_bndr' the_alts
1944   = go env the_alts
1945   where
1946     go env0 [] = return (env0, [])
1947     go env0 (alt:alts)
1948         = do { (env1, alt') <- mkDupableAlt env0 case_bndr' alt
1949              ; (env2, alts') <- go env1 alts
1950              ; return (env2, alt' : alts' ) }
1951
1952 mkDupableAlt :: SimplEnv -> OutId -> (AltCon, [CoreBndr], CoreExpr)
1953               -> SimplM (SimplEnv, (AltCon, [CoreBndr], CoreExpr))
1954 mkDupableAlt env case_bndr (con, bndrs', rhs')
1955   | exprIsDupable rhs'  -- Note [Small alternative rhs]
1956   = return (env, (con, bndrs', rhs'))
1957   | otherwise
1958   = do  { let rhs_ty'  = exprType rhs'
1959               scrut_ty = idType case_bndr
1960               case_bndr_w_unf   
1961                 = case con of 
1962                       DEFAULT    -> case_bndr                                   
1963                       DataAlt dc -> setIdUnfolding case_bndr unf
1964                           where
1965                                  -- See Note [Case binders and join points]
1966                              unf = mkInlineRule needSaturated rhs 0
1967                              rhs = mkConApp dc (map Type (tyConAppArgs scrut_ty)
1968                                                 ++ varsToCoreExprs bndrs')
1969
1970                       LitAlt {} -> WARN( True, ptext (sLit "mkDupableAlt")
1971                                                 <+> ppr case_bndr <+> ppr con )
1972                                    case_bndr
1973                            -- The case binder is alive but trivial, so why has 
1974                            -- it not been substituted away?
1975
1976               used_bndrs' | isDeadBinder case_bndr = filter abstract_over bndrs'
1977                           | otherwise              = bndrs' ++ [case_bndr_w_unf]
1978               
1979               abstract_over bndr
1980                   | isTyVar bndr = True -- Abstract over all type variables just in case
1981                   | otherwise    = not (isDeadBinder bndr)
1982                         -- The deadness info on the new Ids is preserved by simplBinders
1983
1984         ; (final_bndrs', final_args)    -- Note [Join point abstraction]
1985                 <- if (any isId used_bndrs')
1986                    then return (used_bndrs', varsToCoreExprs used_bndrs')
1987                     else do { rw_id <- newId (fsLit "w") realWorldStatePrimTy
1988                             ; return ([rw_id], [Var realWorldPrimId]) }
1989
1990         ; join_bndr <- newId (fsLit "$j") (mkPiTypes final_bndrs' rhs_ty')
1991                 -- Note [Funky mkPiTypes]
1992
1993         ; let   -- We make the lambdas into one-shot-lambdas.  The
1994                 -- join point is sure to be applied at most once, and doing so
1995                 -- prevents the body of the join point being floated out by
1996                 -- the full laziness pass
1997                 really_final_bndrs     = map one_shot final_bndrs'
1998                 one_shot v | isId v    = setOneShotLambda v
1999                            | otherwise = v
2000                 join_rhs  = mkLams really_final_bndrs rhs'
2001                 join_call = mkApps (Var join_bndr) final_args
2002
2003         ; env' <- addPolyBind NotTopLevel env (NonRec join_bndr join_rhs)
2004         ; return (env', (con, bndrs', join_call)) }
2005                 -- See Note [Duplicated env]
2006 \end{code}
2007
2008 Note [Case binders and join points]
2009 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2010 Consider this 
2011    case (case .. ) of c {
2012      I# c# -> ....c....
2013
2014 If we make a join point with c but not c# we get
2015   $j = \c -> ....c....
2016
2017 But if later inlining scrutines the c, thus
2018
2019   $j = \c -> ... case c of { I# y -> ... } ...
2020
2021 we won't see that 'c' has already been scrutinised.  This actually
2022 happens in the 'tabulate' function in wave4main, and makes a significant
2023 difference to allocation.
2024
2025 An alternative plan is this:
2026
2027    $j = \c# -> let c = I# c# in ...c....
2028
2029 but that is bad if 'c' is *not* later scrutinised.  
2030
2031 So instead we do both: we pass 'c' and 'c#' , and record in c's inlining
2032 that it's really I# c#, thus
2033    
2034    $j = \c# -> \c[=I# c#] -> ...c....
2035
2036 Absence analysis may later discard 'c'.
2037
2038    
2039 Note [Duplicated env]
2040 ~~~~~~~~~~~~~~~~~~~~~
2041 Some of the alternatives are simplified, but have not been turned into a join point
2042 So they *must* have an zapped subst-env.  So we can't use completeNonRecX to
2043 bind the join point, because it might to do PostInlineUnconditionally, and
2044 we'd lose that when zapping the subst-env.  We could have a per-alt subst-env,
2045 but zapping it (as we do in mkDupableCont, the Select case) is safe, and
2046 at worst delays the join-point inlining.
2047
2048 Note [Small alternative rhs]
2049 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2050 It is worth checking for a small RHS because otherwise we
2051 get extra let bindings that may cause an extra iteration of the simplifier to
2052 inline back in place.  Quite often the rhs is just a variable or constructor.
2053 The Ord instance of Maybe in PrelMaybe.lhs, for example, took several extra
2054 iterations because the version with the let bindings looked big, and so wasn't
2055 inlined, but after the join points had been inlined it looked smaller, and so
2056 was inlined.
2057
2058 NB: we have to check the size of rhs', not rhs.
2059 Duplicating a small InAlt might invalidate occurrence information
2060 However, if it *is* dupable, we return the *un* simplified alternative,
2061 because otherwise we'd need to pair it up with an empty subst-env....
2062 but we only have one env shared between all the alts.
2063 (Remember we must zap the subst-env before re-simplifying something).
2064 Rather than do this we simply agree to re-simplify the original (small) thing later.
2065
2066 Note [Funky mkPiTypes]
2067 ~~~~~~~~~~~~~~~~~~~~~~
2068 Notice the funky mkPiTypes.  If the contructor has existentials
2069 it's possible that the join point will be abstracted over
2070 type varaibles as well as term variables.
2071  Example:  Suppose we have
2072         data T = forall t.  C [t]
2073  Then faced with
2074         case (case e of ...) of
2075             C t xs::[t] -> rhs
2076  We get the join point
2077         let j :: forall t. [t] -> ...
2078             j = /\t \xs::[t] -> rhs
2079         in
2080         case (case e of ...) of
2081             C t xs::[t] -> j t xs
2082
2083 Note [Join point abstaction]
2084 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2085 If we try to lift a primitive-typed something out
2086 for let-binding-purposes, we will *caseify* it (!),
2087 with potentially-disastrous strictness results.  So
2088 instead we turn it into a function: \v -> e
2089 where v::State# RealWorld#.  The value passed to this function
2090 is realworld#, which generates (almost) no code.
2091
2092 There's a slight infelicity here: we pass the overall
2093 case_bndr to all the join points if it's used in *any* RHS,
2094 because we don't know its usage in each RHS separately
2095
2096 We used to say "&& isUnLiftedType rhs_ty'" here, but now
2097 we make the join point into a function whenever used_bndrs'
2098 is empty.  This makes the join-point more CPR friendly.
2099 Consider:       let j = if .. then I# 3 else I# 4
2100                 in case .. of { A -> j; B -> j; C -> ... }
2101
2102 Now CPR doesn't w/w j because it's a thunk, so
2103 that means that the enclosing function can't w/w either,
2104 which is a lose.  Here's the example that happened in practice:
2105         kgmod :: Int -> Int -> Int
2106         kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
2107                     then 78
2108                     else 5
2109
2110 I have seen a case alternative like this:
2111         True -> \v -> ...
2112 It's a bit silly to add the realWorld dummy arg in this case, making
2113         $j = \s v -> ...
2114            True -> $j s
2115 (the \v alone is enough to make CPR happy) but I think it's rare
2116
2117 Note [Duplicating StrictArg]
2118 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2119 The original plan had (where E is a big argument)
2120 e.g.    f E [..hole..]
2121         ==>     let $j = \a -> f E a
2122                 in $j [..hole..]
2123
2124 But this is terrible! Here's an example:
2125         && E (case x of { T -> F; F -> T })
2126 Now, && is strict so we end up simplifying the case with
2127 an ArgOf continuation.  If we let-bind it, we get
2128         let $j = \v -> && E v
2129         in simplExpr (case x of { T -> F; F -> T })
2130                      (ArgOf (\r -> $j r)
2131 And after simplifying more we get
2132         let $j = \v -> && E v
2133         in case x of { T -> $j F; F -> $j T }
2134 Which is a Very Bad Thing
2135
2136 What we do now is this
2137         f E [..hole..]
2138         ==>     let a = E
2139                 in f a [..hole..]
2140 Now if the thing in the hole is a case expression (which is when
2141 we'll call mkDupableCont), we'll push the function call into the
2142 branches, which is what we want.  Now RULES for f may fire, and
2143 call-pattern specialisation.  Here's an example from Trac #3116
2144      go (n+1) (case l of
2145                  1  -> bs'
2146                  _  -> Chunk p fpc (o+1) (l-1) bs')
2147 If we can push the call for 'go' inside the case, we get
2148 call-pattern specialisation for 'go', which is *crucial* for 
2149 this program.
2150
2151 Here is the (&&) example: 
2152         && E (case x of { T -> F; F -> T })
2153   ==>   let a = E in 
2154         case x of { T -> && a F; F -> && a T }
2155 Much better!
2156
2157 Notice that 
2158   * Arguments to f *after* the strict one are handled by 
2159     the ApplyTo case of mkDupableCont.  Eg
2160         f [..hole..] E
2161
2162   * We can only do the let-binding of E because the function
2163     part of a StrictArg continuation is an explicit syntax
2164     tree.  In earlier versions we represented it as a function
2165     (CoreExpr -> CoreEpxr) which we couldn't take apart.
2166
2167 Do *not* duplicate StrictBind and StritArg continuations.  We gain
2168 nothing by propagating them into the expressions, and we do lose a
2169 lot.  
2170
2171 The desire not to duplicate is the entire reason that
2172 mkDupableCont returns a pair of continuations.
2173
2174 Note [Duplicating StrictBind]
2175 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2176 Unlike StrictArg, there doesn't seem anything to gain from
2177 duplicating a StrictBind continuation, so we don't.
2178
2179 The desire not to duplicate is the entire reason that
2180 mkDupableCont returns a pair of continuations.
2181
2182
2183 Note [Single-alternative cases]
2184 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2185 This case is just like the ArgOf case.  Here's an example:
2186         data T a = MkT !a
2187         ...(MkT (abs x))...
2188 Then we get
2189         case (case x of I# x' ->
2190               case x' <# 0# of
2191                 True  -> I# (negate# x')
2192                 False -> I# x') of y {
2193           DEFAULT -> MkT y
2194 Because the (case x) has only one alternative, we'll transform to
2195         case x of I# x' ->
2196         case (case x' <# 0# of
2197                 True  -> I# (negate# x')
2198                 False -> I# x') of y {
2199           DEFAULT -> MkT y
2200 But now we do *NOT* want to make a join point etc, giving
2201         case x of I# x' ->
2202         let $j = \y -> MkT y
2203         in case x' <# 0# of
2204                 True  -> $j (I# (negate# x'))
2205                 False -> $j (I# x')
2206 In this case the $j will inline again, but suppose there was a big
2207 strict computation enclosing the orginal call to MkT.  Then, it won't
2208 "see" the MkT any more, because it's big and won't get duplicated.
2209 And, what is worse, nothing was gained by the case-of-case transform.
2210
2211 When should use this case of mkDupableCont?
2212 However, matching on *any* single-alternative case is a *disaster*;
2213   e.g.  case (case ....) of (a,b) -> (# a,b #)
2214   We must push the outer case into the inner one!
2215 Other choices:
2216
2217    * Match [(DEFAULT,_,_)], but in the common case of Int,
2218      the alternative-filling-in code turned the outer case into
2219                 case (...) of y { I# _ -> MkT y }
2220
2221    * Match on single alternative plus (not (isDeadBinder case_bndr))
2222      Rationale: pushing the case inwards won't eliminate the construction.
2223      But there's a risk of
2224                 case (...) of y { (a,b) -> let z=(a,b) in ... }
2225      Now y looks dead, but it'll come alive again.  Still, this
2226      seems like the best option at the moment.
2227
2228    * Match on single alternative plus (all (isDeadBinder bndrs))
2229      Rationale: this is essentially  seq.
2230
2231    * Match when the rhs is *not* duplicable, and hence would lead to a
2232      join point.  This catches the disaster-case above.  We can test
2233      the *un-simplified* rhs, which is fine.  It might get bigger or
2234      smaller after simplification; if it gets smaller, this case might
2235      fire next time round.  NB also that we must test contIsDupable
2236      case_cont *btoo, because case_cont might be big!
2237
2238      HOWEVER: I found that this version doesn't work well, because
2239      we can get         let x = case (...) of { small } in ...case x...
2240      When x is inlined into its full context, we find that it was a bad
2241      idea to have pushed the outer case inside the (...) case.
2242
2243 Note [Single-alternative-unlifted]
2244 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2245 Here's another single-alternative where we really want to do case-of-case:
2246
2247 data Mk1 = Mk1 Int#
2248 data Mk1 = Mk2 Int#
2249
2250 M1.f =
2251     \r [x_s74 y_s6X]
2252         case
2253             case y_s6X of tpl_s7m {
2254               M1.Mk1 ipv_s70 -> ipv_s70;
2255               M1.Mk2 ipv_s72 -> ipv_s72;
2256             }
2257         of
2258         wild_s7c
2259         { __DEFAULT ->
2260               case
2261                   case x_s74 of tpl_s7n {
2262                     M1.Mk1 ipv_s77 -> ipv_s77;
2263                     M1.Mk2 ipv_s79 -> ipv_s79;
2264                   }
2265               of
2266               wild1_s7b
2267               { __DEFAULT -> ==# [wild1_s7b wild_s7c];
2268               };
2269         };
2270
2271 So the outer case is doing *nothing at all*, other than serving as a
2272 join-point.  In this case we really want to do case-of-case and decide
2273 whether to use a real join point or just duplicate the continuation.
2274
2275 Hence: check whether the case binder's type is unlifted, because then
2276 the outer case is *not* a seq.