25d765f520631d4f8d098d2d1527041abc096588
[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, substTyVar )
14 import SimplEnv
15 import SimplUtils
16 import FamInstEnv       ( FamInstEnv )
17 import Literal          ( litIsLifted ) --, mkMachInt ) -- temporalily commented out. See #8326
18 import Id
19 import MkId             ( seqId, realWorldPrimId )
20 import MkCore           ( mkImpossibleExpr, castBottomExpr )
21 import IdInfo
22 import Name             ( mkSystemVarName, isExternalName )
23 import Coercion hiding  ( substCo, substTy, substCoVar, extendTvSubst )
24 import OptCoercion      ( optCoercion )
25 import FamInstEnv       ( topNormaliseType_maybe )
26 import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness
27                         , isMarkedStrict ) --, dataConTyCon, dataConTag, fIRST_TAG )
28 --import TyCon            ( isEnumerationTyCon ) -- temporalily commented out. See #8326
29 import CoreMonad        ( Tick(..), SimplifierMode(..) )
30 import CoreSyn
31 import Demand           ( StrictSig(..), dmdTypeDepth )
32 import PprCore          ( pprParendExpr, pprCoreExpr )
33 import CoreUnfold
34 import CoreUtils
35 import CoreArity
36 --import PrimOp           ( tagToEnumKey ) -- temporalily commented out. See #8326
37 import Rules            ( lookupRule, getRules )
38 import TysPrim          ( realWorldStatePrimTy ) --, intPrimTy ) -- temporalily commented out. See #8326
39 import BasicTypes       ( TopLevelFlag(..), isTopLevel, RecFlag(..) )
40 import MonadUtils       ( foldlM, mapAccumLM, liftIO )
41 import Maybes           ( orElse )
42 --import Unique           ( hasKey ) -- temporalily commented out. See #8326
43 import Control.Monad
44 import Data.List        ( mapAccumL )
45 import Outputable
46 import FastString
47 import Pair
48 import Util
49 import ErrUtils
50 \end{code}
51
52
53 The guts of the simplifier is in this module, but the driver loop for
54 the simplifier is in SimplCore.lhs.
55
56
57 -----------------------------------------
58         *** IMPORTANT NOTE ***
59 -----------------------------------------
60 The simplifier used to guarantee that the output had no shadowing, but
61 it does not do so any more.   (Actually, it never did!)  The reason is
62 documented with simplifyArgs.
63
64
65 -----------------------------------------
66         *** IMPORTANT NOTE ***
67 -----------------------------------------
68 Many parts of the simplifier return a bunch of "floats" as well as an
69 expression. This is wrapped as a datatype SimplUtils.FloatsWith.
70
71 All "floats" are let-binds, not case-binds, but some non-rec lets may
72 be unlifted (with RHS ok-for-speculation).
73
74
75
76 -----------------------------------------
77         ORGANISATION OF FUNCTIONS
78 -----------------------------------------
79 simplTopBinds
80   - simplify all top-level binders
81   - for NonRec, call simplRecOrTopPair
82   - for Rec,    call simplRecBind
83
84
85         ------------------------------
86 simplExpr (applied lambda)      ==> simplNonRecBind
87 simplExpr (Let (NonRec ...) ..) ==> simplNonRecBind
88 simplExpr (Let (Rec ...)    ..) ==> simplify binders; simplRecBind
89
90         ------------------------------
91 simplRecBind    [binders already simplfied]
92   - use simplRecOrTopPair on each pair in turn
93
94 simplRecOrTopPair [binder already simplified]
95   Used for: recursive bindings (top level and nested)
96             top-level non-recursive bindings
97   Returns:
98   - check for PreInlineUnconditionally
99   - simplLazyBind
100
101 simplNonRecBind
102   Used for: non-top-level non-recursive bindings
103             beta reductions (which amount to the same thing)
104   Because it can deal with strict arts, it takes a
105         "thing-inside" and returns an expression
106
107   - check for PreInlineUnconditionally
108   - simplify binder, including its IdInfo
109   - if strict binding
110         simplStrictArg
111         mkAtomicArgs
112         completeNonRecX
113     else
114         simplLazyBind
115         addFloats
116
117 simplNonRecX:   [given a *simplified* RHS, but an *unsimplified* binder]
118   Used for: binding case-binder and constr args in a known-constructor case
119   - check for PreInLineUnconditionally
120   - simplify binder
121   - completeNonRecX
122
123         ------------------------------
124 simplLazyBind:  [binder already simplified, RHS not]
125   Used for: recursive bindings (top level and nested)
126             top-level non-recursive bindings
127             non-top-level, but *lazy* non-recursive bindings
128         [must not be strict or unboxed]
129   Returns floats + an augmented environment, not an expression
130   - substituteIdInfo and add result to in-scope
131         [so that rules are available in rec rhs]
132   - simplify rhs
133   - mkAtomicArgs
134   - float if exposes constructor or PAP
135   - completeBind
136
137
138 completeNonRecX:        [binder and rhs both simplified]
139   - if the the thing needs case binding (unlifted and not ok-for-spec)
140         build a Case
141    else
142         completeBind
143         addFloats
144
145 completeBind:   [given a simplified RHS]
146         [used for both rec and non-rec bindings, top level and not]
147   - try PostInlineUnconditionally
148   - add unfolding [this is the only place we add an unfolding]
149   - add arity
150
151
152
153 Right hand sides and arguments
154 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
155 In many ways we want to treat
156         (a) the right hand side of a let(rec), and
157         (b) a function argument
158 in the same way.  But not always!  In particular, we would
159 like to leave these arguments exactly as they are, so they
160 will match a RULE more easily.
161
162         f (g x, h x)
163         g (+ x)
164
165 It's harder to make the rule match if we ANF-ise the constructor,
166 or eta-expand the PAP:
167
168         f (let { a = g x; b = h x } in (a,b))
169         g (\y. + x y)
170
171 On the other hand if we see the let-defns
172
173         p = (g x, h x)
174         q = + x
175
176 then we *do* want to ANF-ise and eta-expand, so that p and q
177 can be safely inlined.
178
179 Even floating lets out is a bit dubious.  For let RHS's we float lets
180 out if that exposes a value, so that the value can be inlined more vigorously.
181 For example
182
183         r = let x = e in (x,x)
184
185 Here, if we float the let out we'll expose a nice constructor. We did experiments
186 that showed this to be a generally good thing.  But it was a bad thing to float
187 lets out unconditionally, because that meant they got allocated more often.
188
189 For function arguments, there's less reason to expose a constructor (it won't
190 get inlined).  Just possibly it might make a rule match, but I'm pretty skeptical.
191 So for the moment we don't float lets out of function arguments either.
192
193
194 Eta expansion
195 ~~~~~~~~~~~~~~
196 For eta expansion, we want to catch things like
197
198         case e of (a,b) -> \x -> case a of (p,q) -> \y -> r
199
200 If the \x was on the RHS of a let, we'd eta expand to bring the two
201 lambdas together.  And in general that's a good thing to do.  Perhaps
202 we should eta expand wherever we find a (value) lambda?  Then the eta
203 expansion at a let RHS can concentrate solely on the PAP case.
204
205
206 %************************************************************************
207 %*                                                                      *
208 \subsection{Bindings}
209 %*                                                                      *
210 %************************************************************************
211
212 \begin{code}
213 simplTopBinds :: SimplEnv -> [InBind] -> SimplM SimplEnv
214
215 simplTopBinds env0 binds0
216   = do  {       -- Put all the top-level binders into scope at the start
217                 -- so that if a transformation rule has unexpectedly brought
218                 -- anything into scope, then we don't get a complaint about that.
219                 -- It's rather as if the top-level binders were imported.
220                 -- See note [Glomming] in OccurAnal.
221         ; env1 <- simplRecBndrs env0 (bindersOfBinds binds0)
222         ; dflags <- getDynFlags
223         ; let dump_flag = dopt Opt_D_verbose_core2core dflags
224         ; env2 <- simpl_binds dump_flag env1 binds0
225         ; freeTick SimplifierDone
226         ; return env2 }
227   where
228         -- We need to track the zapped top-level binders, because
229         -- they should have their fragile IdInfo zapped (notably occurrence info)
230         -- That's why we run down binds and bndrs' simultaneously.
231         --
232         -- The dump-flag emits a trace for each top-level binding, which
233         -- helps to locate the tracing for inlining and rule firing
234     simpl_binds :: Bool -> SimplEnv -> [InBind] -> SimplM SimplEnv
235     simpl_binds _    env []           = return env
236     simpl_binds dump env (bind:binds) = do { env' <- trace_bind dump bind $
237                                                      simpl_bind env bind
238                                            ; simpl_binds dump env' binds }
239
240     trace_bind True  bind = pprTrace "SimplBind" (ppr (bindersOf bind))
241     trace_bind False _    = \x -> x
242
243     simpl_bind env (Rec pairs)  = simplRecBind      env  TopLevel pairs
244     simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel NonRecursive b b' r
245         where
246           (env', b') = addBndrRules env b (lookupRecBndr env b)
247 \end{code}
248
249
250 %************************************************************************
251 %*                                                                      *
252 \subsection{Lazy bindings}
253 %*                                                                      *
254 %************************************************************************
255
256 simplRecBind is used for
257         * recursive bindings only
258
259 \begin{code}
260 simplRecBind :: SimplEnv -> TopLevelFlag
261              -> [(InId, InExpr)]
262              -> SimplM SimplEnv
263 simplRecBind env0 top_lvl pairs0
264   = do  { let (env_with_info, triples) = mapAccumL add_rules env0 pairs0
265         ; env1 <- go (zapFloats env_with_info) triples
266         ; return (env0 `addRecFloats` env1) }
267         -- addFloats adds the floats from env1,
268         -- _and_ updates env0 with the in-scope set from env1
269   where
270     add_rules :: SimplEnv -> (InBndr,InExpr) -> (SimplEnv, (InBndr, OutBndr, InExpr))
271         -- Add the (substituted) rules to the binder
272     add_rules env (bndr, rhs) = (env', (bndr, bndr', rhs))
273         where
274           (env', bndr') = addBndrRules env bndr (lookupRecBndr env bndr)
275
276     go env [] = return env
277
278     go env ((old_bndr, new_bndr, rhs) : pairs)
279         = do { env' <- simplRecOrTopPair env top_lvl Recursive old_bndr new_bndr rhs
280              ; go env' pairs }
281 \end{code}
282
283 simplOrTopPair is used for
284         * recursive bindings (whether top level or not)
285         * top-level non-recursive bindings
286
287 It assumes the binder has already been simplified, but not its IdInfo.
288
289 \begin{code}
290 simplRecOrTopPair :: SimplEnv
291                   -> TopLevelFlag -> RecFlag
292                   -> InId -> OutBndr -> InExpr  -- Binder and rhs
293                   -> SimplM SimplEnv    -- Returns an env that includes the binding
294
295 simplRecOrTopPair env top_lvl is_rec old_bndr new_bndr rhs
296   = do dflags <- getDynFlags
297        -- Check for unconditional inline
298        if preInlineUnconditionally dflags env top_lvl old_bndr rhs
299            then do tick (PreInlineUnconditionally old_bndr)
300                    return (extendIdSubst env old_bndr (mkContEx env rhs))
301            else simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env
302 \end{code}
303
304
305 simplLazyBind is used for
306   * [simplRecOrTopPair] recursive bindings (whether top level or not)
307   * [simplRecOrTopPair] top-level non-recursive bindings
308   * [simplNonRecE]      non-top-level *lazy* non-recursive bindings
309
310 Nota bene:
311     1. It assumes that the binder is *already* simplified,
312        and is in scope, and its IdInfo too, except unfolding
313
314     2. It assumes that the binder type is lifted.
315
316     3. It does not check for pre-inline-unconditionallly;
317        that should have been done already.
318
319 \begin{code}
320 simplLazyBind :: SimplEnv
321               -> TopLevelFlag -> RecFlag
322               -> InId -> OutId          -- Binder, both pre-and post simpl
323                                         -- The OutId has IdInfo, except arity, unfolding
324               -> InExpr -> SimplEnv     -- The RHS and its environment
325               -> SimplM SimplEnv
326
327 simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
328   = -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $
329     do  { let   rhs_env     = rhs_se `setInScope` env
330                 (tvs, body) = case collectTyBinders rhs of
331                                 (tvs, body) | not_lam body -> (tvs,body)
332                                             | otherwise    -> ([], rhs)
333                 not_lam (Lam _ _) = False
334                 not_lam _         = True
335                         -- Do not do the "abstract tyyvar" thing if there's
336                         -- a lambda inside, because it defeats eta-reduction
337                         --    f = /\a. \x. g a x
338                         -- should eta-reduce
339
340
341         ; (body_env, tvs') <- simplBinders rhs_env tvs
342                 -- See Note [Floating and type abstraction] in SimplUtils
343
344         -- Simplify the RHS
345         ; let   rhs_cont = mkRhsStop (substTy body_env (exprType body))
346         ; (body_env1, body1) <- simplExprF body_env body rhs_cont
347         -- ANF-ise a constructor or PAP rhs
348         ; (body_env2, body2) <- prepareRhs top_lvl body_env1 bndr1 body1
349
350         ; (env', rhs')
351             <-  if not (doFloatFromRhs top_lvl is_rec False body2 body_env2)
352                 then                            -- No floating, revert to body1
353                      do { rhs' <- mkLam tvs' (wrapFloats body_env1 body1) rhs_cont
354                         ; return (env, rhs') }
355
356                 else if null tvs then           -- Simple floating
357                      do { tick LetFloatFromLet
358                         ; return (addFloats env body_env2, body2) }
359
360                 else                            -- Do type-abstraction first
361                      do { tick LetFloatFromLet
362                         ; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2
363                         ; rhs' <- mkLam tvs' body3 rhs_cont
364                         ; env' <- foldlM (addPolyBind top_lvl) env poly_binds
365                         ; return (env', rhs') }
366
367         ; completeBind env' top_lvl bndr bndr1 rhs' }
368 \end{code}
369
370 A specialised variant of simplNonRec used when the RHS is already simplified,
371 notably in knownCon.  It uses case-binding where necessary.
372
373 \begin{code}
374 simplNonRecX :: SimplEnv
375              -> InId            -- Old binder
376              -> OutExpr         -- Simplified RHS
377              -> SimplM SimplEnv
378
379 simplNonRecX env bndr new_rhs
380   | isDeadBinder bndr   -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }
381   = return env          --               Here c is dead, and we avoid creating
382                         --               the binding c = (a,b)
383   | Coercion co <- new_rhs
384   = return (extendCvSubst env bndr co)
385
386   | otherwise
387   = do  { (env', bndr') <- simplBinder env bndr
388         ; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs }
389                 -- simplNonRecX is only used for NotTopLevel things
390
391 completeNonRecX :: TopLevelFlag -> SimplEnv
392                 -> Bool
393                 -> InId                 -- Old binder
394                 -> OutId                -- New binder
395                 -> OutExpr              -- Simplified RHS
396                 -> SimplM SimplEnv
397
398 completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs
399   = do  { (env1, rhs1) <- prepareRhs top_lvl (zapFloats env) new_bndr new_rhs
400         ; (env2, rhs2) <-
401                 if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1
402                 then do { tick LetFloatFromLet
403                         ; return (addFloats env env1, rhs1) }   -- Add the floats to the main env
404                 else return (env, wrapFloats env1 rhs1)         -- Wrap the floats around the RHS
405         ; completeBind env2 NotTopLevel old_bndr new_bndr rhs2 }
406 \end{code}
407
408 {- No, no, no!  Do not try preInlineUnconditionally in completeNonRecX
409    Doing so risks exponential behaviour, because new_rhs has been simplified once already
410    In the cases described by the folowing commment, postInlineUnconditionally will
411    catch many of the relevant cases.
412         -- This happens; for example, the case_bndr during case of
413         -- known constructor:  case (a,b) of x { (p,q) -> ... }
414         -- Here x isn't mentioned in the RHS, so we don't want to
415         -- create the (dead) let-binding  let x = (a,b) in ...
416         --
417         -- Similarly, single occurrences can be inlined vigourously
418         -- e.g.  case (f x, g y) of (a,b) -> ....
419         -- If a,b occur once we can avoid constructing the let binding for them.
420
421    Furthermore in the case-binding case preInlineUnconditionally risks extra thunks
422         -- Consider     case I# (quotInt# x y) of
423         --                I# v -> let w = J# v in ...
424         -- If we gaily inline (quotInt# x y) for v, we end up building an
425         -- extra thunk:
426         --                let w = J# (quotInt# x y) in ...
427         -- because quotInt# can fail.
428
429   | preInlineUnconditionally env NotTopLevel bndr new_rhs
430   = thing_inside (extendIdSubst env bndr (DoneEx new_rhs))
431 -}
432
433 ----------------------------------
434 prepareRhs takes a putative RHS, checks whether it's a PAP or
435 constructor application and, if so, converts it to ANF, so that the
436 resulting thing can be inlined more easily.  Thus
437         x = (f a, g b)
438 becomes
439         t1 = f a
440         t2 = g b
441         x = (t1,t2)
442
443 We also want to deal well cases like this
444         v = (f e1 `cast` co) e2
445 Here we want to make e1,e2 trivial and get
446         x1 = e1; x2 = e2; v = (f x1 `cast` co) v2
447 That's what the 'go' loop in prepareRhs does
448
449 \begin{code}
450 prepareRhs :: TopLevelFlag -> SimplEnv -> OutId -> OutExpr -> SimplM (SimplEnv, OutExpr)
451 -- Adds new floats to the env iff that allows us to return a good RHS
452 prepareRhs top_lvl env id (Cast rhs co)    -- Note [Float coercions]
453   | Pair ty1 _ty2 <- coercionKind co       -- Do *not* do this if rhs has an unlifted type
454   , not (isUnLiftedType ty1)            -- see Note [Float coercions (unlifted)]
455   = do  { (env', rhs') <- makeTrivialWithInfo top_lvl env sanitised_info rhs
456         ; return (env', Cast rhs' co) }
457   where
458     sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info
459                                    `setDemandInfo` demandInfo info
460     info = idInfo id
461
462 prepareRhs top_lvl env0 _ rhs0
463   = do  { (_is_exp, env1, rhs1) <- go 0 env0 rhs0
464         ; return (env1, rhs1) }
465   where
466     go n_val_args env (Cast rhs co)
467         = do { (is_exp, env', rhs') <- go n_val_args env rhs
468              ; return (is_exp, env', Cast rhs' co) }
469     go n_val_args env (App fun (Type ty))
470         = do { (is_exp, env', rhs') <- go n_val_args env fun
471              ; return (is_exp, env', App rhs' (Type ty)) }
472     go n_val_args env (App fun arg)
473         = do { (is_exp, env', fun') <- go (n_val_args+1) env fun
474              ; case is_exp of
475                 True -> do { (env'', arg') <- makeTrivial top_lvl env' arg
476                            ; return (True, env'', App fun' arg') }
477                 False -> return (False, env, App fun arg) }
478     go n_val_args env (Var fun)
479         = return (is_exp, env, Var fun)
480         where
481           is_exp = isExpandableApp fun n_val_args   -- The fun a constructor or PAP
482                         -- See Note [CONLIKE pragma] in BasicTypes
483                         -- The definition of is_exp should match that in
484                         -- OccurAnal.occAnalApp
485
486     go _ env other
487         = return (False, env, other)
488 \end{code}
489
490
491 Note [Float coercions]
492 ~~~~~~~~~~~~~~~~~~~~~~
493 When we find the binding
494         x = e `cast` co
495 we'd like to transform it to
496         x' = e
497         x = x `cast` co         -- A trivial binding
498 There's a chance that e will be a constructor application or function, or something
499 like that, so moving the coerion to the usage site may well cancel the coersions
500 and lead to further optimisation.  Example:
501
502      data family T a :: *
503      data instance T Int = T Int
504
505      foo :: Int -> Int -> Int
506      foo m n = ...
507         where
508           x = T m
509           go 0 = 0
510           go n = case x of { T m -> go (n-m) }
511                 -- This case should optimise
512
513 Note [Preserve strictness when floating coercions]
514 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
515 In the Note [Float coercions] transformation, keep the strictness info.
516 Eg
517         f = e `cast` co    -- f has strictness SSL
518 When we transform to
519         f' = e             -- f' also has strictness SSL
520         f = f' `cast` co   -- f still has strictness SSL
521
522 Its not wrong to drop it on the floor, but better to keep it.
523
524 Note [Float coercions (unlifted)]
525 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
526 BUT don't do [Float coercions] if 'e' has an unlifted type.
527 This *can* happen:
528
529      foo :: Int = (error (# Int,Int #) "urk")
530                   `cast` CoUnsafe (# Int,Int #) Int
531
532 If do the makeTrivial thing to the error call, we'll get
533     foo = case error (# Int,Int #) "urk" of v -> v `cast` ...
534 But 'v' isn't in scope!
535
536 These strange casts can happen as a result of case-of-case
537         bar = case (case x of { T -> (# 2,3 #); F -> error "urk" }) of
538                 (# p,q #) -> p+q
539
540
541 \begin{code}
542 makeTrivialArg :: SimplEnv -> ArgSpec -> SimplM (SimplEnv, ArgSpec)
543 makeTrivialArg env (ValArg e)  = do { (env', e') <- makeTrivial NotTopLevel env e
544                                     ; return (env', ValArg e') }
545 makeTrivialArg env (CastBy co) = return (env, CastBy co)
546
547 makeTrivial :: TopLevelFlag -> SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
548 -- Binds the expression to a variable, if it's not trivial, returning the variable
549 makeTrivial top_lvl env expr = makeTrivialWithInfo top_lvl env vanillaIdInfo expr
550
551 makeTrivialWithInfo :: TopLevelFlag -> SimplEnv -> IdInfo
552                     -> OutExpr -> SimplM (SimplEnv, OutExpr)
553 -- Propagate strictness and demand info to the new binder
554 -- Note [Preserve strictness when floating coercions]
555 -- Returned SimplEnv has same substitution as incoming one
556 makeTrivialWithInfo top_lvl env info expr
557   | exprIsTrivial expr                          -- Already trivial
558   || not (bindingOk top_lvl expr expr_ty)       -- Cannot trivialise
559                                                 --   See Note [Cannot trivialise]
560   = return (env, expr)
561   | otherwise           -- See Note [Take care] below
562   = do  { uniq <- getUniqueM
563         ; let name = mkSystemVarName uniq (fsLit "a")
564               var = mkLocalIdWithInfo name expr_ty info
565         ; env'  <- completeNonRecX top_lvl env False var var expr
566         ; expr' <- simplVar env' var
567         ; return (env', expr') }
568         -- The simplVar is needed becase we're constructing a new binding
569         --     a = rhs
570         -- And if rhs is of form (rhs1 |> co), then we might get
571         --     a1 = rhs1
572         --     a = a1 |> co
573         -- and now a's RHS is trivial and can be substituted out, and that
574         -- is what completeNonRecX will do
575         -- To put it another way, it's as if we'd simplified
576         --    let var = e in var
577   where
578     expr_ty = exprType expr
579
580 bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool
581 -- True iff we can have a binding of this expression at this level
582 -- Precondition: the type is the type of the expression
583 bindingOk top_lvl _ expr_ty
584   | isTopLevel top_lvl = not (isUnLiftedType expr_ty)
585   | otherwise          = True
586 \end{code}
587
588 Note [Cannot trivialise]
589 ~~~~~~~~~~~~~~~~~~~~~~~~
590 Consider tih
591    f :: Int -> Addr#
592
593    foo :: Bar
594    foo = Bar (f 3)
595
596 Then we can't ANF-ise foo, even though we'd like to, because
597 we can't make a top-level binding for the Addr# (f 3). And if
598 so we don't want to turn it into
599    foo = let x = f 3 in Bar x
600 because we'll just end up inlining x back, and that makes the
601 simplifier loop.  Better not to ANF-ise it at all.
602
603 A case in point is literal strings (a MachStr is not regarded as
604 trivial):
605
606    foo = Ptr "blob"#
607
608 We don't want to ANF-ise this.
609
610 %************************************************************************
611 %*                                                                      *
612 \subsection{Completing a lazy binding}
613 %*                                                                      *
614 %************************************************************************
615
616 completeBind
617   * deals only with Ids, not TyVars
618   * takes an already-simplified binder and RHS
619   * is used for both recursive and non-recursive bindings
620   * is used for both top-level and non-top-level bindings
621
622 It does the following:
623   - tries discarding a dead binding
624   - tries PostInlineUnconditionally
625   - add unfolding [this is the only place we add an unfolding]
626   - add arity
627
628 It does *not* attempt to do let-to-case.  Why?  Because it is used for
629   - top-level bindings (when let-to-case is impossible)
630   - many situations where the "rhs" is known to be a WHNF
631                 (so let-to-case is inappropriate).
632
633 Nor does it do the atomic-argument thing
634
635 \begin{code}
636 completeBind :: SimplEnv
637              -> TopLevelFlag            -- Flag stuck into unfolding
638              -> InId                    -- Old binder
639              -> OutId -> OutExpr        -- New binder and RHS
640              -> SimplM SimplEnv
641 -- completeBind may choose to do its work
642 --      * by extending the substitution (e.g. let x = y in ...)
643 --      * or by adding to the floats in the envt
644
645 completeBind env top_lvl old_bndr new_bndr new_rhs
646  | isCoVar old_bndr
647  = case new_rhs of
648      Coercion co -> return (extendCvSubst env old_bndr co)
649      _           -> return (addNonRec env new_bndr new_rhs)
650
651  | otherwise
652  = ASSERT( isId new_bndr )
653    do { let old_info = idInfo old_bndr
654             old_unf  = unfoldingInfo old_info
655             occ_info = occInfo old_info
656
657         -- Do eta-expansion on the RHS of the binding
658         -- See Note [Eta-expanding at let bindings] in SimplUtils
659       ; (new_arity, final_rhs) <- tryEtaExpandRhs env new_bndr new_rhs
660
661         -- Simplify the unfolding
662       ; new_unfolding <- simplUnfolding env top_lvl old_bndr final_rhs old_unf
663
664       ; dflags <- getDynFlags
665       ; if postInlineUnconditionally dflags env top_lvl new_bndr occ_info
666                                      final_rhs new_unfolding
667
668                         -- Inline and discard the binding
669         then do  { tick (PostInlineUnconditionally old_bndr)
670                  ; return (extendIdSubst env old_bndr (DoneEx final_rhs)) }
671                 -- Use the substitution to make quite, quite sure that the
672                 -- substitution will happen, since we are going to discard the binding
673         else
674    do { let info1 = idInfo new_bndr `setArityInfo` new_arity
675
676               -- Unfolding info: Note [Setting the new unfolding]
677             info2 = info1 `setUnfoldingInfo` new_unfolding
678
679               -- Demand info: Note [Setting the demand info]
680               --
681               -- We also have to nuke demand info if for some reason
682               -- eta-expansion *reduces* the arity of the binding to less
683               -- than that of the strictness sig. This can happen: see Note [Arity decrease].
684             info3 | isEvaldUnfolding new_unfolding
685                     || (case strictnessInfo info2 of
686                           StrictSig dmd_ty -> new_arity < dmdTypeDepth dmd_ty)
687                   = zapDemandInfo info2 `orElse` info2
688                   | otherwise
689                   = info2
690
691             final_id = new_bndr `setIdInfo` info3
692
693       ; -- pprTrace "Binding" (ppr final_id <+> ppr new_unfolding) $
694         return (addNonRec env final_id final_rhs) } }
695                 -- The addNonRec adds it to the in-scope set too
696
697 ------------------------------
698 addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplM SimplEnv
699 -- Add a new binding to the environment, complete with its unfolding
700 -- but *do not* do postInlineUnconditionally, because we have already
701 -- processed some of the scope of the binding
702 -- We still want the unfolding though.  Consider
703 --      let
704 --            x = /\a. let y = ... in Just y
705 --      in body
706 -- Then we float the y-binding out (via abstractFloats and addPolyBind)
707 -- but 'x' may well then be inlined in 'body' in which case we'd like the
708 -- opportunity to inline 'y' too.
709 --
710 -- INVARIANT: the arity is correct on the incoming binders
711
712 addPolyBind top_lvl env (NonRec poly_id rhs)
713   = do  { unfolding <- simplUnfolding env top_lvl poly_id rhs noUnfolding
714                         -- Assumes that poly_id did not have an INLINE prag
715                         -- which is perhaps wrong.  ToDo: think about this
716         ; let final_id = setIdInfo poly_id $
717                          idInfo poly_id `setUnfoldingInfo` unfolding
718
719         ; return (addNonRec env final_id rhs) }
720
721 addPolyBind _ env bind@(Rec _)
722   = return (extendFloats env bind)
723         -- Hack: letrecs are more awkward, so we extend "by steam"
724         -- without adding unfoldings etc.  At worst this leads to
725         -- more simplifier iterations
726
727 ------------------------------
728 simplUnfolding :: SimplEnv-> TopLevelFlag
729                -> InId
730                -> OutExpr
731                -> Unfolding -> SimplM Unfolding
732 -- Note [Setting the new unfolding]
733 simplUnfolding env _ _ _ df@(DFunUnfolding { df_bndrs = bndrs, df_args = args })
734   = do { (env', bndrs') <- simplBinders env bndrs
735        ; args' <- mapM (simplExpr env') args
736        ; return (df { df_bndrs = bndrs', df_args  = args' }) }
737
738 simplUnfolding env top_lvl id _
739     (CoreUnfolding { uf_tmpl = expr, uf_arity = arity
740                    , uf_src = src, uf_guidance = guide })
741   | isStableSource src
742   = do { expr' <- simplExpr rule_env expr
743        ; let is_top_lvl = isTopLevel top_lvl
744        ; case guide of
745            UnfWhen sat_ok _    -- Happens for INLINE things
746               -> let guide' = UnfWhen sat_ok (inlineBoringOk expr')
747                      -- Refresh the boring-ok flag, in case expr'
748                      -- has got small. This happens, notably in the inlinings
749                      -- for dfuns for single-method classes; see
750                      -- Note [Single-method classes] in TcInstDcls.
751                      -- A test case is Trac #4138
752                  in return (mkCoreUnfolding src is_top_lvl expr' arity guide')
753                  -- See Note [Top-level flag on inline rules] in CoreUnfold
754
755            _other              -- Happens for INLINABLE things
756               -> let bottoming = isBottomingId id
757                  in bottoming `seq` -- See Note [Force bottoming field]
758                     do dflags <- getDynFlags
759                        return (mkUnfolding dflags src is_top_lvl bottoming expr')
760                 -- If the guidance is UnfIfGoodArgs, this is an INLINABLE
761                 -- unfolding, and we need to make sure the guidance is kept up
762                 -- to date with respect to any changes in the unfolding.
763        }
764   where
765     act      = idInlineActivation id
766     rule_env = updMode (updModeForInlineRules act) env
767                -- See Note [Simplifying inside InlineRules] in SimplUtils
768
769 simplUnfolding _ top_lvl id new_rhs _
770   = let bottoming = isBottomingId id
771     in bottoming `seq`  -- See Note [Force bottoming field]
772        do dflags <- getDynFlags
773           return (mkUnfolding dflags InlineRhs (isTopLevel top_lvl) bottoming new_rhs)
774           -- We make an  unfolding *even for loop-breakers*.
775           -- Reason: (a) It might be useful to know that they are WHNF
776           --         (b) In TidyPgm we currently assume that, if we want to
777           --             expose the unfolding then indeed we *have* an unfolding
778           --             to expose.  (We could instead use the RHS, but currently
779           --             we don't.)  The simple thing is always to have one.
780 \end{code}
781
782 Note [Force bottoming field]
783 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
784 We need to force bottoming, or the new unfolding holds
785 on to the old unfolding (which is part of the id).
786
787 Note [Arity decrease]
788 ~~~~~~~~~~~~~~~~~~~~~
789 Generally speaking the arity of a binding should not decrease.  But it *can*
790 legitimately happen because of RULES.  Eg
791         f = g Int
792 where g has arity 2, will have arity 2.  But if there's a rewrite rule
793         g Int --> h
794 where h has arity 1, then f's arity will decrease.  Here's a real-life example,
795 which is in the output of Specialise:
796
797      Rec {
798         $dm {Arity 2} = \d.\x. op d
799         {-# RULES forall d. $dm Int d = $s$dm #-}
800
801         dInt = MkD .... opInt ...
802         opInt {Arity 1} = $dm dInt
803
804         $s$dm {Arity 0} = \x. op dInt }
805
806 Here opInt has arity 1; but when we apply the rule its arity drops to 0.
807 That's why Specialise goes to a little trouble to pin the right arity
808 on specialised functions too.
809
810 Note [Setting the new unfolding]
811 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
812 * If there's an INLINE pragma, we simplify the RHS gently.  Maybe we
813   should do nothing at all, but simplifying gently might get rid of
814   more crap.
815
816 * If not, we make an unfolding from the new RHS.  But *only* for
817   non-loop-breakers. Making loop breakers not have an unfolding at all
818   means that we can avoid tests in exprIsConApp, for example.  This is
819   important: if exprIsConApp says 'yes' for a recursive thing, then we
820   can get into an infinite loop
821
822 If there's an InlineRule on a loop breaker, we hang on to the inlining.
823 It's pretty dodgy, but the user did say 'INLINE'.  May need to revisit
824 this choice.
825
826 Note [Setting the demand info]
827 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
828 If the unfolding is a value, the demand info may
829 go pear-shaped, so we nuke it.  Example:
830      let x = (a,b) in
831      case x of (p,q) -> h p q x
832 Here x is certainly demanded. But after we've nuked
833 the case, we'll get just
834      let x = (a,b) in h a b x
835 and now x is not demanded (I'm assuming h is lazy)
836 This really happens.  Similarly
837      let f = \x -> e in ...f..f...
838 After inlining f at some of its call sites the original binding may
839 (for example) be no longer strictly demanded.
840 The solution here is a bit ad hoc...
841
842
843 %************************************************************************
844 %*                                                                      *
845 \subsection[Simplify-simplExpr]{The main function: simplExpr}
846 %*                                                                      *
847 %************************************************************************
848
849 The reason for this OutExprStuff stuff is that we want to float *after*
850 simplifying a RHS, not before.  If we do so naively we get quadratic
851 behaviour as things float out.
852
853 To see why it's important to do it after, consider this (real) example:
854
855         let t = f x
856         in fst t
857 ==>
858         let t = let a = e1
859                     b = e2
860                 in (a,b)
861         in fst t
862 ==>
863         let a = e1
864             b = e2
865             t = (a,b)
866         in
867         a       -- Can't inline a this round, cos it appears twice
868 ==>
869         e1
870
871 Each of the ==> steps is a round of simplification.  We'd save a
872 whole round if we float first.  This can cascade.  Consider
873
874         let f = g d
875         in \x -> ...f...
876 ==>
877         let f = let d1 = ..d.. in \y -> e
878         in \x -> ...f...
879 ==>
880         let d1 = ..d..
881         in \x -> ...(\y ->e)...
882
883 Only in this second round can the \y be applied, and it
884 might do the same again.
885
886
887 \begin{code}
888 simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
889 simplExpr env expr = simplExprC env expr (mkBoringStop expr_out_ty)
890   where
891     expr_out_ty :: OutType
892     expr_out_ty = substTy env (exprType expr)
893
894 simplExprC :: SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr
895         -- Simplify an expression, given a continuation
896 simplExprC env expr cont
897   = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seFloats env) ) $
898     do  { (env', expr') <- simplExprF (zapFloats env) expr cont
899         ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $
900           -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $
901           -- pprTrace "simplExprC ret4" (ppr (seFloats env')) $
902           return (wrapFloats env' expr') }
903
904 --------------------------------------------------
905 simplExprF :: SimplEnv -> InExpr -> SimplCont
906            -> SimplM (SimplEnv, OutExpr)
907
908 simplExprF env e cont
909   = {- pprTrace "simplExprF" (vcat
910       [ ppr e
911       , text "cont =" <+> ppr cont
912       , text "inscope =" <+> ppr (seInScope env)
913       , text "tvsubst =" <+> ppr (seTvSubst env)
914       , text "idsubst =" <+> ppr (seIdSubst env)
915       , text "cvsubst =" <+> ppr (seCvSubst env)
916       {- , ppr (seFloats env) -}
917       ]) $ -}
918     simplExprF1 env e cont
919
920 simplExprF1 :: SimplEnv -> InExpr -> SimplCont
921             -> SimplM (SimplEnv, OutExpr)
922 simplExprF1 env (Var v)        cont = simplIdF env v cont
923 simplExprF1 env (Lit lit)      cont = rebuild env (Lit lit) cont
924 simplExprF1 env (Tick t expr)  cont = simplTick env t expr cont
925 simplExprF1 env (Cast body co) cont = simplCast env body co cont
926 simplExprF1 env (Coercion co)  cont = simplCoercionF env co cont
927 simplExprF1 env (Type ty)      cont = ASSERT( contIsRhsOrArg cont )
928                                       rebuild env (Type (substTy env ty)) cont
929 simplExprF1 env (App fun arg)  cont = simplExprF env fun $
930                                       ApplyTo NoDup arg env cont
931
932 simplExprF1 env expr@(Lam {}) cont
933   = simplLam env zapped_bndrs body cont
934         -- The main issue here is under-saturated lambdas
935         --   (\x1. \x2. e) arg1
936         -- Here x1 might have "occurs-once" occ-info, because occ-info
937         -- is computed assuming that a group of lambdas is applied
938         -- all at once.  If there are too few args, we must zap the
939         -- occ-info, UNLESS the remaining binders are one-shot
940   where
941     (bndrs, body) = collectBinders expr
942     zapped_bndrs | need_to_zap = map zap bndrs
943                  | otherwise   = bndrs
944
945     need_to_zap = any zappable_bndr (drop n_args bndrs)
946     n_args = countArgs cont
947         -- NB: countArgs counts all the args (incl type args)
948         -- and likewise drop counts all binders (incl type lambdas)
949
950     zappable_bndr b = isId b && not (isOneShotBndr b)
951     zap b | isTyVar b = b
952           | otherwise = zapLamIdInfo b
953
954 simplExprF1 env (Case scrut bndr alts_ty alts) cont
955   | sm_case_case (getMode env)
956   =     -- Simplify the scrutinee with a Select continuation
957     simplExprF env scrut (Select NoDup bndr alts env cont)
958
959   | otherwise
960   =     -- If case-of-case is off, simply simplify the case expression
961         -- in a vanilla Stop context, and rebuild the result around it
962     do  { case_expr' <- simplExprC env scrut
963                              (Select NoDup bndr alts env (mkBoringStop alts_out_ty))
964         ; rebuild env case_expr' cont }
965   where
966     alts_out_ty = substTy env alts_ty
967
968 simplExprF1 env (Let (Rec pairs) body) cont
969   = do  { env' <- simplRecBndrs env (map fst pairs)
970                 -- NB: bndrs' don't have unfoldings or rules
971                 -- We add them as we go down
972
973         ; env'' <- simplRecBind env' NotTopLevel pairs
974         ; simplExprF env'' body cont }
975
976 simplExprF1 env (Let (NonRec bndr rhs) body) cont
977   = simplNonRecE env bndr (rhs, env) ([], body) cont
978
979 ---------------------------------
980 simplType :: SimplEnv -> InType -> SimplM OutType
981         -- Kept monadic just so we can do the seqType
982 simplType env ty
983   = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $
984     seqType new_ty `seq` return new_ty
985   where
986     new_ty = substTy env ty
987
988 ---------------------------------
989 simplCoercionF :: SimplEnv -> InCoercion -> SimplCont
990                -> SimplM (SimplEnv, OutExpr)
991 simplCoercionF env co cont
992   = do { co' <- simplCoercion env co
993        ; rebuild env (Coercion co') cont }
994
995 simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion
996 simplCoercion env co
997   = let opt_co = optCoercion (getCvSubst env) co
998     in seqCo opt_co `seq` return opt_co
999
1000 -----------------------------------
1001 -- | Push a TickIt context outwards past applications and cases, as
1002 -- long as this is a non-scoping tick, to let case and application
1003 -- optimisations apply.
1004
1005 simplTick :: SimplEnv -> Tickish Id -> InExpr -> SimplCont
1006           -> SimplM (SimplEnv, OutExpr)
1007 simplTick env tickish expr cont
1008   -- A scoped tick turns into a continuation, so that we can spot
1009   -- (scc t (\x . e)) in simplLam and eliminate the scc.  If we didn't do
1010   -- it this way, then it would take two passes of the simplifier to
1011   -- reduce ((scc t (\x . e)) e').
1012   -- NB, don't do this with counting ticks, because if the expr is
1013   -- bottom, then rebuildCall will discard the continuation.
1014
1015 -- XXX: we cannot do this, because the simplifier assumes that
1016 -- the context can be pushed into a case with a single branch. e.g.
1017 --    scc<f>  case expensive of p -> e
1018 -- becomes
1019 --    case expensive of p -> scc<f> e
1020 --
1021 -- So I'm disabling this for now.  It just means we will do more
1022 -- simplifier iterations that necessary in some cases.
1023
1024 --  | tickishScoped tickish && not (tickishCounts tickish)
1025 --  = simplExprF env expr (TickIt tickish cont)
1026
1027   -- For non-scoped ticks, we push the continuation inside the
1028   -- tick.  This has the effect of moving the tick to the outside of a
1029   -- case or application context, allowing the normal case and
1030   -- application optimisations to fire.
1031   | not (tickishScoped tickish)
1032   = do { (env', expr') <- simplExprF env expr cont
1033        ; return (env', mkTick tickish expr')
1034        }
1035
1036   -- For breakpoints, we cannot do any floating of bindings around the
1037   -- tick, because breakpoints cannot be split into tick/scope pairs.
1038   | not (tickishCanSplit tickish)
1039   = no_floating_past_tick
1040
1041   | interesting_cont, Just expr' <- push_tick_inside tickish expr
1042     -- see Note [case-of-scc-of-case]
1043   = simplExprF env expr' cont
1044
1045   | otherwise
1046   = no_floating_past_tick -- was: wrap_floats, see below
1047
1048  where
1049   interesting_cont = case cont of
1050                         Select {} -> True
1051                         _ -> False
1052
1053   push_tick_inside t expr0
1054        = ASSERT(tickishScoped t)
1055          case expr0 of
1056            Tick t' expr
1057               -- scc t (tick t' E)
1058               --   Pull the tick to the outside
1059               -- This one is important for #5363
1060               | not (tickishScoped t')
1061                  -> Just (Tick t' (Tick t expr))
1062
1063               -- scc t (scc t' E)
1064               --   Try to push t' into E first, and if that works,
1065               --   try to push t in again
1066               | Just expr' <- push_tick_inside t' expr
1067                  -> push_tick_inside t expr'
1068
1069               | otherwise -> Nothing
1070
1071            Case scrut bndr ty alts
1072               | not (tickishCanSplit t) -> Nothing
1073               | otherwise -> Just (Case (mkTick t scrut) bndr ty alts')
1074              where t_scope = mkNoCount t -- drop the tick on the dup'd ones
1075                    alts'   = [ (c,bs, mkTick t_scope e) | (c,bs,e) <- alts]
1076
1077            _other -> Nothing
1078     where
1079
1080   no_floating_past_tick =
1081     do { let (inc,outc) = splitCont cont
1082        ; (env', expr') <- simplExprF (zapFloats env) expr inc
1083        ; let tickish' = simplTickish env tickish
1084        ; (env'', expr'') <- rebuild (zapFloats env')
1085                                     (wrapFloats env' expr')
1086                                     (TickIt tickish' outc)
1087        ; return (addFloats env env'', expr'')
1088        }
1089
1090 -- Alternative version that wraps outgoing floats with the tick.  This
1091 -- results in ticks being duplicated, as we don't make any attempt to
1092 -- eliminate the tick if we re-inline the binding (because the tick
1093 -- semantics allows unrestricted inlining of HNFs), so I'm not doing
1094 -- this any more.  FloatOut will catch any real opportunities for
1095 -- floating.
1096 --
1097 --  wrap_floats =
1098 --    do { let (inc,outc) = splitCont cont
1099 --       ; (env', expr') <- simplExprF (zapFloats env) expr inc
1100 --       ; let tickish' = simplTickish env tickish
1101 --       ; let wrap_float (b,rhs) = (zapIdStrictness (setIdArity b 0),
1102 --                                   mkTick (mkNoCount tickish') rhs)
1103 --              -- when wrapping a float with mkTick, we better zap the Id's
1104 --              -- strictness info and arity, because it might be wrong now.
1105 --       ; let env'' = addFloats env (mapFloats env' wrap_float)
1106 --       ; rebuild env'' expr' (TickIt tickish' outc)
1107 --       }
1108
1109
1110   simplTickish env tickish
1111     | Breakpoint n ids <- tickish
1112           = Breakpoint n (map (getDoneId . substId env) ids)
1113     | otherwise = tickish
1114
1115   -- push type application and coercion inside a tick
1116   splitCont :: SimplCont -> (SimplCont, SimplCont)
1117   splitCont (ApplyTo f (Type t) env c) = (ApplyTo f (Type t) env inc, outc)
1118     where (inc,outc) = splitCont c
1119   splitCont (CoerceIt co c) = (CoerceIt co inc, outc)
1120     where (inc,outc) = splitCont c
1121   splitCont other = (mkBoringStop (contInputType other), other)
1122
1123   getDoneId (DoneId id) = id
1124   getDoneId (DoneEx e)  = getIdFromTrivialExpr e -- Note [substTickish] in CoreSubst
1125   getDoneId other = pprPanic "getDoneId" (ppr other)
1126
1127 -- Note [case-of-scc-of-case]
1128 -- It's pretty important to be able to transform case-of-case when
1129 -- there's an SCC in the way.  For example, the following comes up
1130 -- in nofib/real/compress/Encode.hs:
1131 --
1132 --        case scctick<code_string.r1>
1133 --             case $wcode_string_r13s wild_XC w1_s137 w2_s138 l_aje
1134 --             of _ { (# ww1_s13f, ww2_s13g, ww3_s13h #) ->
1135 --             (ww1_s13f, ww2_s13g, ww3_s13h)
1136 --             }
1137 --        of _ { (ww_s12Y, ww1_s12Z, ww2_s130) ->
1138 --        tick<code_string.f1>
1139 --        (ww_s12Y,
1140 --         ww1_s12Z,
1141 --         PTTrees.PT
1142 --           @ GHC.Types.Char @ GHC.Types.Int wild2_Xj ww2_s130 r_ajf)
1143 --        }
1144 --
1145 -- We really want this case-of-case to fire, because then the 3-tuple
1146 -- will go away (indeed, the CPR optimisation is relying on this
1147 -- happening).  But the scctick is in the way - we need to push it
1148 -- inside to expose the case-of-case.  So we perform this
1149 -- transformation on the inner case:
1150 --
1151 --   scctick c (case e of { p1 -> e1; ...; pn -> en })
1152 --    ==>
1153 --   case (scctick c e) of { p1 -> scc c e1; ...; pn -> scc c en }
1154 --
1155 -- So we've moved a constant amount of work out of the scc to expose
1156 -- the case.  We only do this when the continuation is interesting: in
1157 -- for now, it has to be another Case (maybe generalise this later).
1158 \end{code}
1159
1160
1161 %************************************************************************
1162 %*                                                                      *
1163 \subsection{The main rebuilder}
1164 %*                                                                      *
1165 %************************************************************************
1166
1167 \begin{code}
1168 rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr)
1169 -- At this point the substitution in the SimplEnv should be irrelevant
1170 -- only the in-scope set and floats should matter
1171 rebuild env expr cont
1172   = case cont of
1173       Stop {}                       -> return (env, expr)
1174       CoerceIt co cont              -> rebuild env (mkCast expr co) cont
1175                                     -- NB: mkCast implements the (Coercion co |> g) optimisation
1176       Select _ bndr alts se cont    -> rebuildCase (se `setFloats` env) expr bndr alts cont
1177       StrictArg info _ cont         -> rebuildCall env (info `addArgTo` expr) cont
1178       StrictBind b bs body se cont  -> do { env' <- simplNonRecX (se `setFloats` env) b expr
1179                                           ; simplLam env' bs body cont }
1180       ApplyTo dup_flag arg se cont  -- See Note [Avoid redundant simplification]
1181         | isSimplified dup_flag     -> rebuild env (App expr arg) cont
1182         | otherwise                 -> do { arg' <- simplExpr (se `setInScope` env) arg
1183                                           ; rebuild env (App expr arg') cont }
1184       TickIt t cont                 -> rebuild env (mkTick t expr) cont
1185 \end{code}
1186
1187
1188 %************************************************************************
1189 %*                                                                      *
1190 \subsection{Lambdas}
1191 %*                                                                      *
1192 %************************************************************************
1193
1194 \begin{code}
1195 simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont
1196           -> SimplM (SimplEnv, OutExpr)
1197 simplCast env body co0 cont0
1198   = do  { co1 <- simplCoercion env co0
1199         ; -- pprTrace "simplCast" (ppr co1) $
1200           simplExprF env body (addCoerce co1 cont0) }
1201   where
1202        addCoerce co cont = add_coerce co (coercionKind co) cont
1203
1204        add_coerce _co (Pair s1 k1) cont     -- co :: ty~ty
1205          | s1 `eqType` k1 = cont    -- is a no-op
1206
1207        add_coerce co1 (Pair s1 _k2) (CoerceIt co2 cont)
1208          | (Pair _l1 t1) <- coercionKind co2
1209                 --      e |> (g1 :: S1~L) |> (g2 :: L~T1)
1210                 -- ==>
1211                 --      e,                       if S1=T1
1212                 --      e |> (g1 . g2 :: S1~T1)  otherwise
1213                 --
1214                 -- For example, in the initial form of a worker
1215                 -- we may find  (coerce T (coerce S (\x.e))) y
1216                 -- and we'd like it to simplify to e[y/x] in one round
1217                 -- of simplification
1218          , s1 `eqType` t1  = cont            -- The coerces cancel out
1219          | otherwise       = CoerceIt (mkTransCo co1 co2) cont
1220
1221        add_coerce co (Pair s1s2 _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont)
1222                 -- (f |> g) ty  --->   (f ty) |> (g @ ty)
1223                 -- This implements the PushT rule from the paper
1224          | Just (tyvar,_) <- splitForAllTy_maybe s1s2
1225          = ASSERT( isTyVar tyvar )
1226            ApplyTo Simplified (Type arg_ty') (zapSubstEnv arg_se) (addCoerce new_cast cont)
1227          where
1228            new_cast = mkInstCo co arg_ty'
1229            arg_ty' | isSimplified dup = arg_ty
1230                    | otherwise        = substTy (arg_se `setInScope` env) arg_ty
1231
1232        add_coerce co (Pair s1s2 t1t2) (ApplyTo dup arg arg_se cont)
1233          | isFunTy s1s2   -- This implements the Push rule from the paper
1234          , isFunTy t1t2   -- Check t1t2 to ensure 'arg' is a value arg
1235                 --      (e |> (g :: s1s2 ~ t1->t2)) f
1236                 -- ===>
1237                 --      (e (f |> (arg g :: t1~s1))
1238                 --      |> (res g :: s2->t2)
1239                 --
1240                 -- t1t2 must be a function type, t1->t2, because it's applied
1241                 -- to something but s1s2 might conceivably not be
1242                 --
1243                 -- When we build the ApplyTo we can't mix the out-types
1244                 -- with the InExpr in the argument, so we simply substitute
1245                 -- to make it all consistent.  It's a bit messy.
1246                 -- But it isn't a common case.
1247                 --
1248                 -- Example of use: Trac #995
1249          = ApplyTo dup new_arg (zapSubstEnv arg_se) (addCoerce co2 cont)
1250          where
1251            -- we split coercion t1->t2 ~ s1->s2 into t1 ~ s1 and
1252            -- t2 ~ s2 with left and right on the curried form:
1253            --    (->) t1 t2 ~ (->) s1 s2
1254            [co1, co2] = decomposeCo 2 co
1255            new_arg    = mkCast arg' (mkSymCo co1)
1256            arg'       = substExpr (text "move-cast") arg_se' arg
1257            arg_se'    = arg_se `setInScope` env
1258
1259        add_coerce co _ cont = CoerceIt co cont
1260 \end{code}
1261
1262
1263 %************************************************************************
1264 %*                                                                      *
1265 \subsection{Lambdas}
1266 %*                                                                      *
1267 %************************************************************************
1268
1269 Note [Zap unfolding when beta-reducing]
1270 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1271 Lambda-bound variables can have stable unfoldings, such as
1272    $j = \x. \b{Unf=Just x}. e
1273 See Note [Case binders and join points] below; the unfolding for lets
1274 us optimise e better.  However when we beta-reduce it we want to
1275 revert to using the actual value, otherwise we can end up in the
1276 stupid situation of
1277           let x = blah in
1278           let b{Unf=Just x} = y
1279           in ...b...
1280 Here it'd be far better to drop the unfolding and use the actual RHS.
1281
1282 \begin{code}
1283 simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont
1284          -> SimplM (SimplEnv, OutExpr)
1285
1286 simplLam env [] body cont = simplExprF env body cont
1287
1288         -- Beta reduction
1289 simplLam env (bndr:bndrs) body (ApplyTo _ arg arg_se cont)
1290   = do  { tick (BetaReduction bndr)
1291         ; simplNonRecE env (zap_unfolding bndr) (arg, arg_se) (bndrs, body) cont }
1292   where
1293     zap_unfolding bndr  -- See Note [Zap unfolding when beta-reducing]
1294       | isId bndr, isStableUnfolding (realIdUnfolding bndr)
1295       = setIdUnfolding bndr NoUnfolding
1296       | otherwise = bndr
1297
1298       -- discard a non-counting tick on a lambda.  This may change the
1299       -- cost attribution slightly (moving the allocation of the
1300       -- lambda elsewhere), but we don't care: optimisation changes
1301       -- cost attribution all the time.
1302 simplLam env bndrs body (TickIt tickish cont)
1303   | not (tickishCounts tickish)
1304   = simplLam env bndrs body cont
1305
1306         -- Not enough args, so there are real lambdas left to put in the result
1307 simplLam env bndrs body cont
1308   = do  { (env', bndrs') <- simplLamBndrs env bndrs
1309         ; body' <- simplExpr env' body
1310         ; new_lam <- mkLam bndrs' body' cont
1311         ; rebuild env' new_lam cont }
1312
1313 ------------------
1314 simplNonRecE :: SimplEnv
1315              -> InBndr                  -- The binder
1316              -> (InExpr, SimplEnv)      -- Rhs of binding (or arg of lambda)
1317              -> ([InBndr], InExpr)      -- Body of the let/lambda
1318                                         --      \xs.e
1319              -> SimplCont
1320              -> SimplM (SimplEnv, OutExpr)
1321
1322 -- simplNonRecE is used for
1323 --  * non-top-level non-recursive lets in expressions
1324 --  * beta reduction
1325 --
1326 -- It deals with strict bindings, via the StrictBind continuation,
1327 -- which may abort the whole process
1328 --
1329 -- The "body" of the binding comes as a pair of ([InId],InExpr)
1330 -- representing a lambda; so we recurse back to simplLam
1331 -- Why?  Because of the binder-occ-info-zapping done before
1332 --       the call to simplLam in simplExprF (Lam ...)
1333
1334         -- First deal with type applications and type lets
1335         --   (/\a. e) (Type ty)   and   (let a = Type ty in e)
1336 simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont
1337   = ASSERT( isTyVar bndr )
1338     do  { ty_arg' <- simplType (rhs_se `setInScope` env) ty_arg
1339         ; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont }
1340
1341 simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
1342   = do dflags <- getDynFlags
1343        case () of
1344          _
1345           | preInlineUnconditionally dflags env NotTopLevel bndr rhs ->
1346             do  { tick (PreInlineUnconditionally bndr)
1347                 ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $
1348                   simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont }
1349
1350           | isStrictId bndr ->           -- Includes coercions
1351             do  { simplExprF (rhs_se `setFloats` env) rhs
1352                              (StrictBind bndr bndrs body env cont) }
1353
1354           | otherwise ->
1355             ASSERT( not (isTyVar bndr) )
1356             do  { (env1, bndr1) <- simplNonRecBndr env bndr
1357                 ; let (env2, bndr2) = addBndrRules env1 bndr bndr1
1358                 ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
1359                 ; simplLam env3 bndrs body cont }
1360 \end{code}
1361
1362 %************************************************************************
1363 %*                                                                      *
1364                      Variables
1365 %*                                                                      *
1366 %************************************************************************
1367
1368 \begin{code}
1369 simplVar :: SimplEnv -> InVar -> SimplM OutExpr
1370 -- Look up an InVar in the environment
1371 simplVar env var
1372   | isTyVar var = return (Type (substTyVar env var))
1373   | isCoVar var = return (Coercion (substCoVar env var))
1374   | otherwise
1375   = case substId env var of
1376         DoneId var1          -> return (Var var1)
1377         DoneEx e             -> return e
1378         ContEx tvs cvs ids e -> simplExpr (setSubstEnv env tvs cvs ids) e
1379
1380 simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplEnv, OutExpr)
1381 simplIdF env var cont
1382   = case substId env var of
1383         DoneEx e             -> simplExprF (zapSubstEnv env) e cont
1384         ContEx tvs cvs ids e -> simplExprF (setSubstEnv env tvs cvs ids) e cont
1385         DoneId var1          -> completeCall env var1 cont
1386                 -- Note [zapSubstEnv]
1387                 -- The template is already simplified, so don't re-substitute.
1388                 -- This is VITAL.  Consider
1389                 --      let x = e in
1390                 --      let y = \z -> ...x... in
1391                 --      \ x -> ...y...
1392                 -- We'll clone the inner \x, adding x->x' in the id_subst
1393                 -- Then when we inline y, we must *not* replace x by x' in
1394                 -- the inlined copy!!
1395
1396 ---------------------------------------------------------
1397 --      Dealing with a call site
1398
1399 completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplEnv, OutExpr)
1400 completeCall env var cont
1401   = do  {   ------------- Try inlining ----------------
1402           dflags <- getDynFlags
1403         ; let  (lone_variable, arg_infos, call_cont) = contArgs cont
1404                n_val_args = length arg_infos
1405                interesting_cont = interestingCallContext call_cont
1406                unfolding    = activeUnfolding env var
1407                maybe_inline = callSiteInline dflags var unfolding
1408                                              lone_variable arg_infos interesting_cont
1409         ; case maybe_inline of {
1410             Just expr      -- There is an inlining!
1411               ->  do { checkedTick (UnfoldingDone var)
1412                      ; dump_inline dflags expr cont
1413                      ; simplExprF (zapSubstEnv env) expr cont }
1414
1415             ; Nothing -> do               -- No inlining!
1416
1417         { rule_base <- getSimplRules
1418         ; let info = mkArgInfo var (getRules rule_base var) n_val_args call_cont
1419         ; rebuildCall env info cont
1420     }}}
1421   where
1422     dump_inline dflags unfolding cont
1423       | not (dopt Opt_D_dump_inlinings dflags) = return ()
1424       | not (dopt Opt_D_verbose_core2core dflags)
1425       = when (isExternalName (idName var)) $
1426             liftIO $ printInfoForUser dflags alwaysQualify $
1427                 sep [text "Inlining done:", nest 4 (ppr var)]
1428       | otherwise
1429       = liftIO $ printInfoForUser dflags alwaysQualify $
1430            sep [text "Inlining done: " <> ppr var,
1431                 nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding),
1432                               text "Cont:  " <+> ppr cont])]
1433
1434 rebuildCall :: SimplEnv
1435             -> ArgInfo
1436             -> SimplCont
1437             -> SimplM (SimplEnv, OutExpr)
1438 rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) cont
1439   -- When we run out of strictness args, it means
1440   -- that the call is definitely bottom; see SimplUtils.mkArgInfo
1441   -- Then we want to discard the entire strict continuation.  E.g.
1442   --    * case (error "hello") of { ... }
1443   --    * (error "Hello") arg
1444   --    * f (error "Hello") where f is strict
1445   --    etc
1446   -- Then, especially in the first of these cases, we'd like to discard
1447   -- the continuation, leaving just the bottoming expression.  But the
1448   -- type might not be right, so we may have to add a coerce.
1449   | not (contIsTrivial cont)     -- Only do this if there is a non-trivial
1450   = return (env, castBottomExpr res cont_ty)  -- contination to discard, else we do it
1451   where                                       -- again and again!
1452     res     = argInfoExpr fun rev_args
1453     cont_ty = contResultType cont
1454
1455 rebuildCall env info (CoerceIt co cont)
1456   = rebuildCall env (addCastTo info co) cont
1457
1458 rebuildCall env info (ApplyTo dup_flag (Type arg_ty) se cont)
1459   = do { arg_ty' <- if isSimplified dup_flag then return arg_ty
1460                     else simplType (se `setInScope` env) arg_ty
1461        ; rebuildCall env (info `addArgTo` Type arg_ty') cont }
1462
1463 rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty
1464                               , ai_strs = str:strs, ai_discs = disc:discs })
1465             (ApplyTo dup_flag arg arg_se cont)
1466   | isSimplified dup_flag     -- See Note [Avoid redundant simplification]
1467   = rebuildCall env (addArgTo info' arg) cont
1468
1469   | str                 -- Strict argument
1470   = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
1471     simplExprF (arg_se `setFloats` env) arg
1472                (StrictArg info' cci cont)
1473                 -- Note [Shadowing]
1474
1475   | otherwise                           -- Lazy argument
1476         -- DO NOT float anything outside, hence simplExprC
1477         -- There is no benefit (unlike in a let-binding), and we'd
1478         -- have to be very careful about bogus strictness through
1479         -- floating a demanded let.
1480   = do  { arg' <- simplExprC (arg_se `setInScope` env) arg
1481                              (mkLazyArgStop (funArgTy fun_ty) cci)
1482         ; rebuildCall env (addArgTo info' arg') cont }
1483   where
1484     info' = info { ai_strs = strs, ai_discs = discs }
1485     cci | encl_rules = RuleArgCtxt
1486         | disc > 0   = DiscArgCtxt  -- Be keener here
1487         | otherwise  = BoringCtxt   -- Nothing interesting
1488
1489 rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) cont
1490   | null rules
1491   = rebuild env (argInfoExpr fun rev_args) cont      -- No rules, common case
1492
1493   | otherwise
1494   = do {  -- We've accumulated a simplified call in <fun,rev_args>
1495           -- so try rewrite rules; see Note [RULEs apply to simplified arguments]
1496           -- See also Note [Rules for recursive functions]
1497         ; let env' = zapSubstEnv env
1498               (args, cont') = argInfoValArgs env' rev_args cont
1499         ; mb_rule <- tryRules env' rules fun args cont'
1500         ; case mb_rule of {
1501              Just (rule_rhs, cont'') -> simplExprF env' rule_rhs cont''
1502
1503                  -- Rules don't match
1504            ; Nothing -> rebuild env (argInfoExpr fun rev_args) cont      -- No rules
1505     } }
1506 \end{code}
1507
1508 Note [RULES apply to simplified arguments]
1509 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1510 It's very desirable to try RULES once the arguments have been simplified, because
1511 doing so ensures that rule cascades work in one pass.  Consider
1512    {-# RULES g (h x) = k x
1513              f (k x) = x #-}
1514    ...f (g (h x))...
1515 Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If
1516 we match f's rules against the un-simplified RHS, it won't match.  This
1517 makes a particularly big difference when superclass selectors are involved:
1518         op ($p1 ($p2 (df d)))
1519 We want all this to unravel in one sweeep.
1520
1521 Note [Avoid redundant simplification]
1522 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1523 Because RULES apply to simplified arguments, there's a danger of repeatedly
1524 simplifying already-simplified arguments.  An important example is that of
1525         (>>=) d e1 e2
1526 Here e1, e2 are simplified before the rule is applied, but don't really
1527 participate in the rule firing. So we mark them as Simplified to avoid
1528 re-simplifying them.
1529
1530 Note [Shadowing]
1531 ~~~~~~~~~~~~~~~~
1532 This part of the simplifier may break the no-shadowing invariant
1533 Consider
1534         f (...(\a -> e)...) (case y of (a,b) -> e')
1535 where f is strict in its second arg
1536 If we simplify the innermost one first we get (...(\a -> e)...)
1537 Simplifying the second arg makes us float the case out, so we end up with
1538         case y of (a,b) -> f (...(\a -> e)...) e'
1539 So the output does not have the no-shadowing invariant.  However, there is
1540 no danger of getting name-capture, because when the first arg was simplified
1541 we used an in-scope set that at least mentioned all the variables free in its
1542 static environment, and that is enough.
1543
1544 We can't just do innermost first, or we'd end up with a dual problem:
1545         case x of (a,b) -> f e (...(\a -> e')...)
1546
1547 I spent hours trying to recover the no-shadowing invariant, but I just could
1548 not think of an elegant way to do it.  The simplifier is already knee-deep in
1549 continuations.  We have to keep the right in-scope set around; AND we have
1550 to get the effect that finding (error "foo") in a strict arg position will
1551 discard the entire application and replace it with (error "foo").  Getting
1552 all this at once is TOO HARD!
1553
1554
1555 %************************************************************************
1556 %*                                                                      *
1557                 Rewrite rules
1558 %*                                                                      *
1559 %************************************************************************
1560
1561 \begin{code}
1562 tryRules :: SimplEnv -> [CoreRule]
1563          -> Id -> [OutExpr] -> SimplCont
1564          -> SimplM (Maybe (CoreExpr, SimplCont))
1565 -- The SimplEnv already has zapSubstEnv applied to it
1566
1567 tryRules env rules fn args call_cont
1568   | null rules
1569   = return Nothing
1570 {- Disabled until we fix #8326
1571   | fn `hasKey` tagToEnumKey   -- See Note [Optimising tagToEnum#]
1572   , [_type_arg, val_arg] <- args
1573   , Select dup bndr ((_,[],rhs1) : rest_alts) se cont <- call_cont
1574   , isDeadBinder bndr
1575   = do { dflags <- getDynFlags
1576        ; let enum_to_tag :: CoreAlt -> CoreAlt
1577                 -- Takes   K -> e  into   tagK# -> e
1578                 -- where tagK# is the tag of constructor K
1579              enum_to_tag (DataAlt con, [], rhs)
1580                = ASSERT( isEnumerationTyCon (dataConTyCon con) )
1581                 (LitAlt tag, [], rhs)
1582               where
1583                 tag = mkMachInt dflags (toInteger (dataConTag con - fIRST_TAG))
1584              enum_to_tag alt = pprPanic "tryRules: tagToEnum" (ppr alt)
1585
1586              new_alts = (DEFAULT, [], rhs1) : map enum_to_tag rest_alts
1587              new_bndr = setIdType bndr intPrimTy
1588                  -- The binder is dead, but should have the right type
1589       ; return (Just (val_arg, Select dup new_bndr new_alts se cont)) }
1590 -}
1591   | otherwise
1592   = do { dflags <- getDynFlags
1593        ; case lookupRule dflags (getUnfoldingInRuleMatch env) (activeRule env)
1594                          fn args rules of {
1595            Nothing               -> return Nothing ;   -- No rule matches
1596            Just (rule, rule_rhs) ->
1597              do { checkedTick (RuleFired (ru_name rule))
1598                 ; dump dflags rule rule_rhs
1599                 ; let cont' = pushSimplifiedArgs env
1600                                                  (drop (ruleArity rule) args)
1601                                                  call_cont
1602                       -- (ruleArity rule) says how many args the rule consumed
1603                 ; return (Just (rule_rhs, cont')) }}}
1604   where
1605     dump dflags rule rule_rhs
1606       | dopt Opt_D_dump_rule_rewrites dflags
1607       = log_rule dflags Opt_D_dump_rule_rewrites "Rule fired" $ vcat
1608           [ text "Rule:" <+> ftext (ru_name rule)
1609           , text "Before:" <+> hang (ppr fn) 2 (sep (map pprParendExpr args))
1610           , text "After: " <+> pprCoreExpr rule_rhs
1611           , text "Cont:  " <+> ppr call_cont ]
1612
1613       | dopt Opt_D_dump_rule_firings dflags
1614       = log_rule dflags Opt_D_dump_rule_firings "Rule fired:" $
1615           ftext (ru_name rule)
1616
1617       | otherwise
1618       = return ()
1619
1620     log_rule dflags flag hdr details = liftIO . dumpSDoc dflags flag "" $
1621       sep [text hdr, nest 4 details]
1622 \end{code}
1623
1624 Note [Optimising tagToEnum#]
1625 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1626 If we have an enumeration data type:
1627
1628   data Foo = A | B | C
1629
1630 Then we want to transform
1631
1632    case tagToEnum# x of   ==>    case x of
1633      A -> e1                       DEFAULT -> e1
1634      B -> e2                       1#      -> e2
1635      C -> e3                       2#      -> e3
1636
1637 thereby getting rid of the tagToEnum# altogether.  If there was a DEFAULT
1638 alternative we retain it (remember it comes first).  If not the case must
1639 be exhaustive, and we reflect that in the transformed version by adding
1640 a DEFAULT.  Otherwise Lint complains that the new case is not exhaustive.
1641 See #8317.
1642
1643 Note [Rules for recursive functions]
1644 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1645 You might think that we shouldn't apply rules for a loop breaker:
1646 doing so might give rise to an infinite loop, because a RULE is
1647 rather like an extra equation for the function:
1648      RULE:           f (g x) y = x+y
1649      Eqn:            f a     y = a-y
1650
1651 But it's too drastic to disable rules for loop breakers.
1652 Even the foldr/build rule would be disabled, because foldr
1653 is recursive, and hence a loop breaker:
1654      foldr k z (build g) = g k z
1655 So it's up to the programmer: rules can cause divergence
1656
1657
1658 %************************************************************************
1659 %*                                                                      *
1660                 Rebuilding a case expression
1661 %*                                                                      *
1662 %************************************************************************
1663
1664 Note [Case elimination]
1665 ~~~~~~~~~~~~~~~~~~~~~~~
1666 The case-elimination transformation discards redundant case expressions.
1667 Start with a simple situation:
1668
1669         case x# of      ===>   let y# = x# in e
1670           y# -> e
1671
1672 (when x#, y# are of primitive type, of course).  We can't (in general)
1673 do this for algebraic cases, because we might turn bottom into
1674 non-bottom!
1675
1676 The code in SimplUtils.prepareAlts has the effect of generalise this
1677 idea to look for a case where we're scrutinising a variable, and we
1678 know that only the default case can match.  For example:
1679
1680         case x of
1681           0#      -> ...
1682           DEFAULT -> ...(case x of
1683                          0#      -> ...
1684                          DEFAULT -> ...) ...
1685
1686 Here the inner case is first trimmed to have only one alternative, the
1687 DEFAULT, after which it's an instance of the previous case.  This
1688 really only shows up in eliminating error-checking code.
1689
1690 Note that SimplUtils.mkCase combines identical RHSs.  So
1691
1692         case e of       ===> case e of DEFAULT -> r
1693            True  -> r
1694            False -> r
1695
1696 Now again the case may be elminated by the CaseElim transformation.
1697 This includes things like (==# a# b#)::Bool so that we simplify
1698       case ==# a# b# of { True -> x; False -> x }
1699 to just
1700       x
1701 This particular example shows up in default methods for
1702 comparision operations (e.g. in (>=) for Int.Int32)
1703
1704 Note [Case elimination: lifted case]
1705 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1706 We also make sure that we deal with this very common case,
1707 where x has a lifted type:
1708
1709         case e of
1710           x -> ...x...
1711
1712 Here we are using the case as a strict let; if x is used only once
1713 then we want to inline it.  We have to be careful that this doesn't
1714 make the program terminate when it would have diverged before, so we
1715 check that
1716         (a) 'e' is already evaluated (it may so if e is a variable)
1717             Specifically we check (exprIsHNF e)
1718 or
1719         (b) 'x' is not used at all and e is ok-for-speculation
1720
1721 For the (b), consider
1722    case (case a ># b of { True -> (p,q); False -> (q,p) }) of
1723      r -> blah
1724 The scrutinee is ok-for-speculation (it looks inside cases), but we do
1725 not want to transform to
1726    let r = case a ># b of { True -> (p,q); False -> (q,p) }
1727    in blah
1728 because that builds an unnecessary thunk.
1729
1730 Note [Case binder next]
1731 ~~~~~~~~~~~~~~~~~~~~~~~
1732 If we have
1733    case e of f { _ -> f e1 e2 }
1734 then we can safely do CaseElim.   The main criterion is that the
1735 case-binder is evaluated *next*.  Previously we just asked that
1736 the case-binder is used strictly; but that can change
1737     case x of { _ -> error "bad" }
1738     --> error "bad"
1739 which is very puzzling if 'x' is later bound to (error "good").
1740 Where the order of evaluation is specified (via seq or case)
1741 we should respect it.
1742 See also Note [Empty case alternatives] in CoreSyn.
1743
1744 So instead we use case_bndr_evald_next to see when f is the *next*
1745 thing to be eval'd.  This came up when fixing Trac #7542.
1746 See also Note [Eta reduction of an eval'd function] in CoreUtils.
1747
1748   For reference, the old code was an extra disjunct in elim_lifted
1749        || (strict_case_bndr && scrut_is_var scrut)
1750       strict_case_bndr = isStrictDmd (idDemandInfo case_bndr)
1751       scrut_is_var (Cast s _) = scrut_is_var s
1752       scrut_is_var (Var _)    = True
1753       scrut_is_var _          = False
1754
1755       -- True if evaluation of the case_bndr is the next
1756       -- thing to be eval'd.  Then dropping the case
1757
1758 Note [Case elimination: unlifted case]
1759 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1760 Consider
1761    case a +# b of r -> ...r...
1762 Then we do case-elimination (to make a let) followed by inlining,
1763 to get
1764         .....(a +# b)....
1765 If we have
1766    case indexArray# a i of r -> ...r...
1767 we might like to do the same, and inline the (indexArray# a i).
1768 But indexArray# is not okForSpeculation, so we don't build a let
1769 in rebuildCase (lest it get floated *out*), so the inlining doesn't
1770 happen either.
1771
1772 This really isn't a big deal I think. The let can be
1773
1774
1775 Further notes about case elimination
1776 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1777 Consider:       test :: Integer -> IO ()
1778                 test = print
1779
1780 Turns out that this compiles to:
1781     Print.test
1782       = \ eta :: Integer
1783           eta1 :: State# RealWorld ->
1784           case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->
1785           case hPutStr stdout
1786                  (PrelNum.jtos eta ($w[] @ Char))
1787                  eta1
1788           of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s  }}
1789
1790 Notice the strange '<' which has no effect at all. This is a funny one.
1791 It started like this:
1792
1793 f x y = if x < 0 then jtos x
1794           else if y==0 then "" else jtos x
1795
1796 At a particular call site we have (f v 1).  So we inline to get
1797
1798         if v < 0 then jtos x
1799         else if 1==0 then "" else jtos x
1800
1801 Now simplify the 1==0 conditional:
1802
1803         if v<0 then jtos v else jtos v
1804
1805 Now common-up the two branches of the case:
1806
1807         case (v<0) of DEFAULT -> jtos v
1808
1809 Why don't we drop the case?  Because it's strict in v.  It's technically
1810 wrong to drop even unnecessary evaluations, and in practice they
1811 may be a result of 'seq' so we *definitely* don't want to drop those.
1812 I don't really know how to improve this situation.
1813
1814 \begin{code}
1815 ---------------------------------------------------------
1816 --      Eliminate the case if possible
1817
1818 rebuildCase, reallyRebuildCase
1819    :: SimplEnv
1820    -> OutExpr          -- Scrutinee
1821    -> InId             -- Case binder
1822    -> [InAlt]          -- Alternatives (inceasing order)
1823    -> SimplCont
1824    -> SimplM (SimplEnv, OutExpr)
1825
1826 --------------------------------------------------
1827 --      1. Eliminate the case if there's a known constructor
1828 --------------------------------------------------
1829
1830 rebuildCase env scrut case_bndr alts cont
1831   | Lit lit <- scrut    -- No need for same treatment as constructors
1832                         -- because literals are inlined more vigorously
1833   , not (litIsLifted lit)
1834   = do  { tick (KnownBranch case_bndr)
1835         ; case findAlt (LitAlt lit) alts of
1836             Nothing           -> missingAlt env case_bndr alts cont
1837             Just (_, bs, rhs) -> simple_rhs bs rhs }
1838
1839   | Just (con, ty_args, other_args) <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut
1840         -- Works when the scrutinee is a variable with a known unfolding
1841         -- as well as when it's an explicit constructor application
1842   = do  { tick (KnownBranch case_bndr)
1843         ; case findAlt (DataAlt con) alts of
1844             Nothing  -> missingAlt env case_bndr alts cont
1845             Just (DEFAULT, bs, rhs) -> simple_rhs bs rhs
1846             Just (_, bs, rhs)       -> knownCon env scrut con ty_args other_args
1847                                                 case_bndr bs rhs cont
1848         }
1849   where
1850     simple_rhs bs rhs = ASSERT( null bs )
1851                         do { env' <- simplNonRecX env case_bndr scrut
1852                            ; simplExprF env' rhs cont }
1853
1854
1855 --------------------------------------------------
1856 --      2. Eliminate the case if scrutinee is evaluated
1857 --------------------------------------------------
1858
1859 rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont
1860   -- See if we can get rid of the case altogether
1861   -- See Note [Case elimination]
1862   -- mkCase made sure that if all the alternatives are equal,
1863   -- then there is now only one (DEFAULT) rhs
1864  | all isDeadBinder bndrs       -- bndrs are [InId]
1865
1866  , if isUnLiftedType (idType case_bndr)
1867    then elim_unlifted        -- Satisfy the let-binding invariant
1868    else elim_lifted
1869   = do  { -- pprTrace "case elim" (vcat [ppr case_bndr, ppr (exprIsHNF scrut),
1870           --                            ppr ok_for_spec,
1871           --                            ppr scrut]) $
1872           tick (CaseElim case_bndr)
1873         ; env' <- simplNonRecX env case_bndr scrut
1874           -- If case_bndr is dead, simplNonRecX will discard
1875         ; simplExprF env' rhs cont }
1876   where
1877     elim_lifted   -- See Note [Case elimination: lifted case]
1878       = exprIsHNF scrut
1879      || (is_plain_seq && ok_for_spec)
1880               -- Note: not the same as exprIsHNF
1881      || case_bndr_evald_next rhs
1882
1883     elim_unlifted
1884       | is_plain_seq = exprOkForSideEffects scrut
1885             -- The entire case is dead, so we can drop it,
1886             -- _unless_ the scrutinee has side effects
1887       | otherwise    = ok_for_spec
1888             -- The case-binder is alive, but we may be able
1889             -- turn the case into a let, if the expression is ok-for-spec
1890             -- See Note [Case elimination: unlifted case]
1891
1892     ok_for_spec      = exprOkForSpeculation scrut
1893     is_plain_seq     = isDeadBinder case_bndr -- Evaluation *only* for effect
1894
1895     case_bndr_evald_next :: CoreExpr -> Bool
1896       -- See Note [Case binder next]
1897     case_bndr_evald_next (Var v)         = v == case_bndr
1898     case_bndr_evald_next (Cast e _)      = case_bndr_evald_next e
1899     case_bndr_evald_next (App e _)       = case_bndr_evald_next e
1900     case_bndr_evald_next (Case e _ _ _)  = case_bndr_evald_next e
1901     case_bndr_evald_next _               = False
1902       -- Could add a case for Let,
1903       -- but I'm worried it could become expensive
1904
1905 --------------------------------------------------
1906 --      3. Try seq rules; see Note [User-defined RULES for seq] in MkId
1907 --------------------------------------------------
1908
1909 rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont
1910   | all isDeadBinder (case_bndr : bndrs)  -- So this is just 'seq'
1911   = do { let rhs' = substExpr (text "rebuild-case") env rhs
1912              env' = zapSubstEnv env
1913              out_args = [Type (substTy env (idType case_bndr)),
1914                          Type (exprType rhs'), scrut, rhs']
1915                       -- Lazily evaluated, so we don't do most of this
1916
1917        ; rule_base <- getSimplRules
1918        ; mb_rule <- tryRules env' (getRules rule_base seqId) seqId out_args cont
1919        ; case mb_rule of
1920            Just (rule_rhs, cont') -> simplExprF env' rule_rhs cont'
1921            Nothing                -> reallyRebuildCase env scrut case_bndr alts cont }
1922
1923 rebuildCase env scrut case_bndr alts cont
1924   = reallyRebuildCase env scrut case_bndr alts cont
1925
1926 --------------------------------------------------
1927 --      3. Catch-all case
1928 --------------------------------------------------
1929
1930 reallyRebuildCase env scrut case_bndr alts cont
1931   = do  {       -- Prepare the continuation;
1932                 -- The new subst_env is in place
1933           (env', dup_cont, nodup_cont) <- prepareCaseCont env alts cont
1934
1935         -- Simplify the alternatives
1936         ; (scrut', case_bndr', alts') <- simplAlts env' scrut case_bndr alts dup_cont
1937
1938         ; dflags <- getDynFlags
1939         ; let alts_ty' = contResultType dup_cont
1940         ; case_expr <- mkCase dflags scrut' case_bndr' alts_ty' alts'
1941
1942         -- Notice that rebuild gets the in-scope set from env', not alt_env
1943         -- (which in any case is only build in simplAlts)
1944         -- The case binder *not* scope over the whole returned case-expression
1945         ; rebuild env' case_expr nodup_cont }
1946 \end{code}
1947
1948 simplCaseBinder checks whether the scrutinee is a variable, v.  If so,
1949 try to eliminate uses of v in the RHSs in favour of case_bndr; that
1950 way, there's a chance that v will now only be used once, and hence
1951 inlined.
1952
1953 Historical note: we use to do the "case binder swap" in the Simplifier
1954 so there were additional complications if the scrutinee was a variable.
1955 Now the binder-swap stuff is done in the occurrence analyer; see
1956 OccurAnal Note [Binder swap].
1957
1958 Note [knownCon occ info]
1959 ~~~~~~~~~~~~~~~~~~~~~~~~
1960 If the case binder is not dead, then neither are the pattern bound
1961 variables:
1962         case <any> of x { (a,b) ->
1963         case x of { (p,q) -> p } }
1964 Here (a,b) both look dead, but come alive after the inner case is eliminated.
1965 The point is that we bring into the envt a binding
1966         let x = (a,b)
1967 after the outer case, and that makes (a,b) alive.  At least we do unless
1968 the case binder is guaranteed dead.
1969
1970 Note [Case alternative occ info]
1971 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1972 When we are simply reconstructing a case (the common case), we always
1973 zap the occurrence info on the binders in the alternatives.  Even
1974 if the case binder is dead, the scrutinee is usually a variable, and *that*
1975 can bring the case-alternative binders back to life.
1976 See Note [Add unfolding for scrutinee]
1977
1978 Note [Improving seq]
1979 ~~~~~~~~~~~~~~~~~~~
1980 Consider
1981         type family F :: * -> *
1982         type instance F Int = Int
1983
1984         ... case e of x { DEFAULT -> rhs } ...
1985
1986 where x::F Int.  Then we'd like to rewrite (F Int) to Int, getting
1987
1988         case e `cast` co of x'::Int
1989            I# x# -> let x = x' `cast` sym co
1990                     in rhs
1991
1992 so that 'rhs' can take advantage of the form of x'.
1993
1994 Notice that Note [Case of cast] (in OccurAnal) may then apply to the result.
1995
1996 Nota Bene: We only do the [Improving seq] transformation if the
1997 case binder 'x' is actually used in the rhs; that is, if the case
1998 is *not* a *pure* seq.
1999   a) There is no point in adding the cast to a pure seq.
2000   b) There is a good reason not to: doing so would interfere
2001      with seq rules (Note [Built-in RULES for seq] in MkId).
2002      In particular, this [Improving seq] thing *adds* a cast
2003      while [Built-in RULES for seq] *removes* one, so they
2004      just flip-flop.
2005
2006 You might worry about
2007    case v of x { __DEFAULT ->
2008       ... case (v `cast` co) of y { I# -> ... }}
2009 This is a pure seq (since x is unused), so [Improving seq] won't happen.
2010 But it's ok: the simplifier will replace 'v' by 'x' in the rhs to get
2011    case v of x { __DEFAULT ->
2012       ... case (x `cast` co) of y { I# -> ... }}
2013 Now the outer case is not a pure seq, so [Improving seq] will happen,
2014 and then the inner case will disappear.
2015
2016 The need for [Improving seq] showed up in Roman's experiments.  Example:
2017   foo :: F Int -> Int -> Int
2018   foo t n = t `seq` bar n
2019      where
2020        bar 0 = 0
2021        bar n = bar (n - case t of TI i -> i)
2022 Here we'd like to avoid repeated evaluating t inside the loop, by
2023 taking advantage of the `seq`.
2024
2025 At one point I did transformation in LiberateCase, but it's more
2026 robust here.  (Otherwise, there's a danger that we'll simply drop the
2027 'seq' altogether, before LiberateCase gets to see it.)
2028
2029 \begin{code}
2030 simplAlts :: SimplEnv
2031           -> OutExpr
2032           -> InId                       -- Case binder
2033           -> [InAlt]                    -- Non-empty
2034           -> SimplCont
2035           -> SimplM (OutExpr, OutId, [OutAlt])  -- Includes the continuation
2036 -- Like simplExpr, this just returns the simplified alternatives;
2037 -- it does not return an environment
2038 -- The returned alternatives can be empty, none are possible
2039
2040 simplAlts env scrut case_bndr alts cont'
2041   = do  { let env0 = zapFloats env
2042
2043         ; (env1, case_bndr1) <- simplBinder env0 case_bndr
2044
2045         ; fam_envs <- getFamEnvs
2046         ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env1 scrut
2047                                                        case_bndr case_bndr1 alts
2048
2049         ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts
2050           -- NB: it's possible that the returned in_alts is empty: this is handled
2051           -- by the caller (rebuildCase) in the missingAlt function
2052
2053         ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts
2054         ; -- pprTrace "simplAlts" (ppr case_bndr $$ ppr alts_ty $$ ppr alts_ty' $$ ppr alts $$ ppr cont') $
2055           return (scrut', case_bndr', alts') }
2056
2057
2058 ------------------------------------
2059 improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv
2060            -> OutExpr -> InId -> OutId -> [InAlt]
2061            -> SimplM (SimplEnv, OutExpr, OutId)
2062 -- Note [Improving seq]
2063 improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)]
2064   | not (isDeadBinder case_bndr) -- Not a pure seq!  See Note [Improving seq]
2065   , Just (co, ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1)
2066   = do { case_bndr2 <- newId (fsLit "nt") ty2
2067         ; let rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCo co)
2068               env2 = extendIdSubst env case_bndr rhs
2069         ; return (env2, scrut `Cast` co, case_bndr2) }
2070
2071 improveSeq _ env scrut _ case_bndr1 _
2072   = return (env, scrut, case_bndr1)
2073
2074
2075 ------------------------------------
2076 simplAlt :: SimplEnv
2077          -> Maybe OutExpr  -- The scrutinee
2078          -> [AltCon]       -- These constructors can't be present when
2079                            -- matching the DEFAULT alternative
2080          -> OutId          -- The case binder
2081          -> SimplCont
2082          -> InAlt
2083          -> SimplM OutAlt
2084
2085 simplAlt env _ imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs)
2086   = ASSERT( null bndrs )
2087     do  { let env' = addBinderUnfolding env case_bndr'
2088                                         (mkOtherCon imposs_deflt_cons)
2089                 -- Record the constructors that the case-binder *can't* be.
2090         ; rhs' <- simplExprC env' rhs cont'
2091         ; return (DEFAULT, [], rhs') }
2092
2093 simplAlt env scrut' _ case_bndr' cont' (LitAlt lit, bndrs, rhs)
2094   = ASSERT( null bndrs )
2095     do  { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit)
2096         ; rhs' <- simplExprC env' rhs cont'
2097         ; return (LitAlt lit, [], rhs') }
2098
2099 simplAlt env scrut' _ case_bndr' cont' (DataAlt con, vs, rhs)
2100   = do  {       -- Deal with the pattern-bound variables
2101                 -- Mark the ones that are in ! positions in the
2102                 -- data constructor as certainly-evaluated.
2103                 -- NB: simplLamBinders preserves this eval info
2104         ; let vs_with_evals = add_evals (dataConRepStrictness con)
2105         ; (env', vs') <- simplLamBndrs env vs_with_evals
2106
2107                 -- Bind the case-binder to (con args)
2108         ; let inst_tys' = tyConAppArgs (idType case_bndr')
2109               con_app :: OutExpr
2110               con_app   = mkConApp2 con inst_tys' vs'
2111
2112         ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app
2113         ; rhs' <- simplExprC env'' rhs cont'
2114         ; return (DataAlt con, vs', rhs') }
2115   where
2116         -- add_evals records the evaluated-ness of the bound variables of
2117         -- a case pattern.  This is *important*.  Consider
2118         --      data T = T !Int !Int
2119         --
2120         --      case x of { T a b -> T (a+1) b }
2121         --
2122         -- We really must record that b is already evaluated so that we don't
2123         -- go and re-evaluate it when constructing the result.
2124         -- See Note [Data-con worker strictness] in MkId.lhs
2125     add_evals the_strs
2126         = go vs the_strs
2127         where
2128           go [] [] = []
2129           go (v:vs') strs | isTyVar v = v : go vs' strs
2130           go (v:vs') (str:strs)
2131             | isMarkedStrict str = evald_v  : go vs' strs
2132             | otherwise          = zapped_v : go vs' strs
2133             where
2134               zapped_v = zapIdOccInfo v   -- See Note [Case alternative occ info]
2135               evald_v  = zapped_v `setIdUnfolding` evaldUnfolding
2136           go _ _ = pprPanic "cat_evals" (ppr con $$ ppr vs $$ ppr the_strs)
2137
2138
2139 addAltUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> OutExpr -> SimplM SimplEnv
2140 addAltUnfoldings env scrut case_bndr con_app
2141   = do { dflags <- getDynFlags
2142        ; let con_app_unf = mkSimpleUnfolding dflags con_app
2143              env1 = addBinderUnfolding env case_bndr con_app_unf
2144
2145              -- See Note [Add unfolding for scrutinee]
2146              env2 = case scrut of
2147                       Just (Var v)           -> addBinderUnfolding env1 v con_app_unf
2148                       Just (Cast (Var v) co) -> addBinderUnfolding env1 v $
2149                                                 mkSimpleUnfolding dflags (Cast con_app (mkSymCo co))
2150                       _                      -> env1
2151
2152        ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app])
2153        ; return env2 }
2154
2155 addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv
2156 addBinderUnfolding env bndr unf
2157   | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf
2158   = WARN( not (eqType (idType bndr) (exprType tmpl)),
2159           ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl) )
2160     modifyInScope env (bndr `setIdUnfolding` unf)
2161
2162   | otherwise
2163   = modifyInScope env (bndr `setIdUnfolding` unf)
2164
2165 zapBndrOccInfo :: Bool -> Id -> Id
2166 -- Consider  case e of b { (a,b) -> ... }
2167 -- Then if we bind b to (a,b) in "...", and b is not dead,
2168 -- then we must zap the deadness info on a,b
2169 zapBndrOccInfo keep_occ_info pat_id
2170   | keep_occ_info = pat_id
2171   | otherwise     = zapIdOccInfo pat_id
2172 \end{code}
2173
2174 Note [Add unfolding for scrutinee]
2175 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2176 In general it's unlikely that a variable scrutinee will appear
2177 in the case alternatives   case x of { ...x unlikely to appear... }
2178 because the binder-swap in OccAnal has got rid of all such occcurrences
2179 See Note [Binder swap] in OccAnal.
2180
2181 BUT it is still VERY IMPORTANT to add a suitable unfolding for a
2182 variable scrutinee, in simplAlt.  Here's why
2183    case x of y
2184      (a,b) -> case b of c
2185                 I# v -> ...(f y)...
2186 There is no occurrence of 'b' in the (...(f y)...).  But y gets
2187 the unfolding (a,b), and *that* mentions b.  If f has a RULE
2188     RULE f (p, I# q) = ...
2189 we want that rule to match, so we must extend the in-scope env with a
2190 suitable unfolding for 'y'.  It's *essential* for rule matching; but
2191 it's also good for case-elimintation -- suppose that 'f' was inlined
2192 and did multi-level case analysis, then we'd solve it in one
2193 simplifier sweep instead of two.
2194
2195 Exactly the same issue arises in SpecConstr;
2196 see Note [Add scrutinee to ValueEnv too] in SpecConstr
2197
2198 HOWEVER, given
2199   case x of y { Just a -> r1; Nothing -> r2 }
2200 we do not want to add the unfolding x -> y to 'x', which might seem cool,
2201 since 'y' itself has different unfoldings in r1 and r2.  Reason: if we
2202 did that, we'd have to zap y's deadness info and that is a very useful
2203 piece of information.
2204
2205 So instead we add the unfolding x -> Just a, and x -> Nothing in the
2206 respective RHSs.
2207
2208
2209 %************************************************************************
2210 %*                                                                      *
2211 \subsection{Known constructor}
2212 %*                                                                      *
2213 %************************************************************************
2214
2215 We are a bit careful with occurrence info.  Here's an example
2216
2217         (\x* -> case x of (a*, b) -> f a) (h v, e)
2218
2219 where the * means "occurs once".  This effectively becomes
2220         case (h v, e) of (a*, b) -> f a)
2221 and then
2222         let a* = h v; b = e in f a
2223 and then
2224         f (h v)
2225
2226 All this should happen in one sweep.
2227
2228 \begin{code}
2229 knownCon :: SimplEnv
2230          -> OutExpr                             -- The scrutinee
2231          -> DataCon -> [OutType] -> [OutExpr]   -- The scrutinee (in pieces)
2232          -> InId -> [InBndr] -> InExpr          -- The alternative
2233          -> SimplCont
2234          -> SimplM (SimplEnv, OutExpr)
2235
2236 knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont
2237   = do  { env'  <- bind_args env bs dc_args
2238         ; env'' <- bind_case_bndr env'
2239         ; simplExprF env'' rhs cont }
2240   where
2241     zap_occ = zapBndrOccInfo (isDeadBinder bndr)    -- bndr is an InId
2242
2243                   -- Ugh!
2244     bind_args env' [] _  = return env'
2245
2246     bind_args env' (b:bs') (Type ty : args)
2247       = ASSERT( isTyVar b )
2248         bind_args (extendTvSubst env' b ty) bs' args
2249
2250     bind_args env' (b:bs') (arg : args)
2251       = ASSERT( isId b )
2252         do { let b' = zap_occ b
2253              -- Note that the binder might be "dead", because it doesn't
2254              -- occur in the RHS; and simplNonRecX may therefore discard
2255              -- it via postInlineUnconditionally.
2256              -- Nevertheless we must keep it if the case-binder is alive,
2257              -- because it may be used in the con_app.  See Note [knownCon occ info]
2258            ; env'' <- simplNonRecX env' b' arg
2259            ; bind_args env'' bs' args }
2260
2261     bind_args _ _ _ =
2262       pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$
2263                              text "scrut:" <+> ppr scrut
2264
2265        -- It's useful to bind bndr to scrut, rather than to a fresh
2266        -- binding      x = Con arg1 .. argn
2267        -- because very often the scrut is a variable, so we avoid
2268        -- creating, and then subsequently eliminating, a let-binding
2269        -- BUT, if scrut is a not a variable, we must be careful
2270        -- about duplicating the arg redexes; in that case, make
2271        -- a new con-app from the args
2272     bind_case_bndr env
2273       | isDeadBinder bndr   = return env
2274       | exprIsTrivial scrut = return (extendIdSubst env bndr (DoneEx scrut))
2275       | otherwise           = do { dc_args <- mapM (simplVar env) bs
2276                                          -- dc_ty_args are aready OutTypes,
2277                                          -- but bs are InBndrs
2278                                  ; let con_app = Var (dataConWorkId dc)
2279                                                  `mkTyApps` dc_ty_args
2280                                                  `mkApps`   dc_args
2281                                  ; simplNonRecX env bndr con_app }
2282
2283 -------------------
2284 missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont -> SimplM (SimplEnv, OutExpr)
2285                 -- This isn't strictly an error, although it is unusual.
2286                 -- It's possible that the simplifer might "see" that
2287                 -- an inner case has no accessible alternatives before
2288                 -- it "sees" that the entire branch of an outer case is
2289                 -- inaccessible.  So we simply put an error case here instead.
2290 missingAlt env case_bndr _ cont
2291   = WARN( True, ptext (sLit "missingAlt") <+> ppr case_bndr )
2292     return (env, mkImpossibleExpr (contResultType cont))
2293 \end{code}
2294
2295
2296 %************************************************************************
2297 %*                                                                      *
2298 \subsection{Duplicating continuations}
2299 %*                                                                      *
2300 %************************************************************************
2301
2302 \begin{code}
2303 prepareCaseCont :: SimplEnv
2304                 -> [InAlt] -> SimplCont
2305                 -> SimplM (SimplEnv, SimplCont, SimplCont)
2306 -- We are considering
2307 --     K[case _ of { p1 -> r1; ...; pn -> rn }]
2308 -- where K is some enclosing continuation for the case
2309 -- Goal: split K into two pieces Kdup,Knodup so that
2310 --       a) Kdup can be duplicated
2311 --       b) Knodup[Kdup[e]] = K[e]
2312 -- The idea is that we'll transform thus:
2313 --          Knodup[ (case _ of { p1 -> Kdup[r1]; ...; pn -> Kdup[rn] }
2314 --
2315 -- We also return some extra bindings in SimplEnv (that scope over
2316 -- the entire continuation)
2317
2318 prepareCaseCont env alts cont
2319   | many_alts alts = mkDupableCont env cont
2320   | otherwise      = return (env, cont, mkBoringStop (contResultType cont))
2321   where
2322     many_alts :: [InAlt] -> Bool  -- True iff strictly > 1 non-bottom alternative
2323     many_alts []  = False         -- See Note [Bottom alternatives]
2324     many_alts [_] = False
2325     many_alts (alt:alts)
2326       | is_bot_alt alt = many_alts alts
2327       | otherwise      = not (all is_bot_alt alts)
2328
2329     is_bot_alt (_,_,rhs) = exprIsBottom rhs
2330 \end{code}
2331
2332 Note [Bottom alternatives]
2333 ~~~~~~~~~~~~~~~~~~~~~~~~~~
2334 When we have
2335      case (case x of { A -> error .. ; B -> e; C -> error ..)
2336        of alts
2337 then we can just duplicate those alts because the A and C cases
2338 will disappear immediately.  This is more direct than creating
2339 join points and inlining them away; and in some cases we would
2340 not even create the join points (see Note [Single-alternative case])
2341 and we would keep the case-of-case which is silly.  See Trac #4930.
2342
2343 \begin{code}
2344 mkDupableCont :: SimplEnv -> SimplCont
2345               -> SimplM (SimplEnv, SimplCont, SimplCont)
2346
2347 mkDupableCont env cont
2348   | contIsDupable cont
2349   = return (env, cont, mkBoringStop (contResultType cont))
2350
2351 mkDupableCont _   (Stop {}) = panic "mkDupableCont"     -- Handled by previous eqn
2352
2353 mkDupableCont env (CoerceIt ty cont)
2354   = do  { (env', dup, nodup) <- mkDupableCont env cont
2355         ; return (env', CoerceIt ty dup, nodup) }
2356
2357 -- Duplicating ticks for now, not sure if this is good or not
2358 mkDupableCont env cont@(TickIt{})
2359   = return (env, mkBoringStop (contInputType cont), cont)
2360
2361 mkDupableCont env cont@(StrictBind {})
2362   =  return (env, mkBoringStop (contInputType cont), cont)
2363         -- See Note [Duplicating StrictBind]
2364
2365 mkDupableCont env (StrictArg info cci cont)
2366         -- See Note [Duplicating StrictArg]
2367   = do { (env', dup, nodup) <- mkDupableCont env cont
2368        ; (env'', args')     <- mapAccumLM makeTrivialArg env' (ai_args info)
2369        ; return (env'', StrictArg (info { ai_args = args' }) cci dup, nodup) }
2370
2371 mkDupableCont env (ApplyTo _ arg se cont)
2372   =     -- e.g.         [...hole...] (...arg...)
2373         --      ==>
2374         --              let a = ...arg...
2375         --              in [...hole...] a
2376     do  { (env', dup_cont, nodup_cont) <- mkDupableCont env cont
2377         ; arg' <- simplExpr (se `setInScope` env') arg
2378         ; (env'', arg'') <- makeTrivial NotTopLevel env' arg'
2379         ; let app_cont = ApplyTo OkToDup arg'' (zapSubstEnv env'') dup_cont
2380         ; return (env'', app_cont, nodup_cont) }
2381
2382 mkDupableCont env cont@(Select _ case_bndr [(_, bs, _rhs)] _ _)
2383 --  See Note [Single-alternative case]
2384 --  | not (exprIsDupable rhs && contIsDupable case_cont)
2385 --  | not (isDeadBinder case_bndr)
2386   | all isDeadBinder bs  -- InIds
2387     && not (isUnLiftedType (idType case_bndr))
2388     -- Note [Single-alternative-unlifted]
2389   = return (env, mkBoringStop (contInputType cont), cont)
2390
2391 mkDupableCont env (Select _ case_bndr alts se cont)
2392   =     -- e.g.         (case [...hole...] of { pi -> ei })
2393         --      ===>
2394         --              let ji = \xij -> ei
2395         --              in case [...hole...] of { pi -> ji xij }
2396     do  { tick (CaseOfCase case_bndr)
2397         ; (env', dup_cont, nodup_cont) <- prepareCaseCont env alts cont
2398                 -- NB: We call prepareCaseCont here.  If there is only one
2399                 -- alternative, then dup_cont may be big, but that's ok
2400                 -- because we push it into the single alternative, and then
2401                 -- use mkDupableAlt to turn that simplified alternative into
2402                 -- a join point if it's too big to duplicate.
2403                 -- And this is important: see Note [Fusing case continuations]
2404
2405         ; let alt_env = se `setInScope` env'
2406
2407         ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr
2408         ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' dup_cont) alts
2409         -- Safe to say that there are no handled-cons for the DEFAULT case
2410                 -- NB: simplBinder does not zap deadness occ-info, so
2411                 -- a dead case_bndr' will still advertise its deadness
2412                 -- This is really important because in
2413                 --      case e of b { (# p,q #) -> ... }
2414                 -- b is always dead, and indeed we are not allowed to bind b to (# p,q #),
2415                 -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.
2416                 -- In the new alts we build, we have the new case binder, so it must retain
2417                 -- its deadness.
2418         -- NB: we don't use alt_env further; it has the substEnv for
2419         --     the alternatives, and we don't want that
2420
2421         ; (env'', alts'') <- mkDupableAlts env' case_bndr' alts'
2422         ; return (env'',  -- Note [Duplicated env]
2423                   Select OkToDup case_bndr' alts'' (zapSubstEnv env'')
2424                          (mkBoringStop (contInputType nodup_cont)),
2425                   nodup_cont) }
2426
2427
2428 mkDupableAlts :: SimplEnv -> OutId -> [InAlt]
2429               -> SimplM (SimplEnv, [InAlt])
2430 -- Absorbs the continuation into the new alternatives
2431
2432 mkDupableAlts env case_bndr' the_alts
2433   = go env the_alts
2434   where
2435     go env0 [] = return (env0, [])
2436     go env0 (alt:alts)
2437         = do { (env1, alt') <- mkDupableAlt env0 case_bndr' alt
2438              ; (env2, alts') <- go env1 alts
2439              ; return (env2, alt' : alts' ) }
2440
2441 mkDupableAlt :: SimplEnv -> OutId -> (AltCon, [CoreBndr], CoreExpr)
2442               -> SimplM (SimplEnv, (AltCon, [CoreBndr], CoreExpr))
2443 mkDupableAlt env case_bndr (con, bndrs', rhs') = do
2444   dflags <- getDynFlags
2445   if exprIsDupable dflags rhs'  -- Note [Small alternative rhs]
2446    then return (env, (con, bndrs', rhs'))
2447    else
2448     do  { let rhs_ty'  = exprType rhs'
2449               scrut_ty = idType case_bndr
2450               case_bndr_w_unf
2451                 = case con of
2452                       DEFAULT    -> case_bndr
2453                       DataAlt dc -> setIdUnfolding case_bndr unf
2454                           where
2455                                  -- See Note [Case binders and join points]
2456                              unf = mkInlineUnfolding Nothing rhs
2457                              rhs = mkConApp2 dc (tyConAppArgs scrut_ty) bndrs'
2458
2459                       LitAlt {} -> WARN( True, ptext (sLit "mkDupableAlt")
2460                                                 <+> ppr case_bndr <+> ppr con )
2461                                    case_bndr
2462                            -- The case binder is alive but trivial, so why has
2463                            -- it not been substituted away?
2464
2465               used_bndrs' | isDeadBinder case_bndr = filter abstract_over bndrs'
2466                           | otherwise              = bndrs' ++ [case_bndr_w_unf]
2467
2468               abstract_over bndr
2469                   | isTyVar bndr = True -- Abstract over all type variables just in case
2470                   | otherwise    = not (isDeadBinder bndr)
2471                         -- The deadness info on the new Ids is preserved by simplBinders
2472
2473         ; (final_bndrs', final_args)    -- Note [Join point abstraction]
2474                 <- if (any isId used_bndrs')
2475                    then return (used_bndrs', varsToCoreExprs used_bndrs')
2476                     else do { rw_id <- newId (fsLit "w") realWorldStatePrimTy
2477                             ; return ([rw_id], [Var realWorldPrimId]) }
2478
2479         ; join_bndr <- newId (fsLit "$j") (mkPiTypes final_bndrs' rhs_ty')
2480                 -- Note [Funky mkPiTypes]
2481
2482         ; let   -- We make the lambdas into one-shot-lambdas.  The
2483                 -- join point is sure to be applied at most once, and doing so
2484                 -- prevents the body of the join point being floated out by
2485                 -- the full laziness pass
2486                 really_final_bndrs     = map one_shot final_bndrs'
2487                 one_shot v | isId v    = setOneShotLambda v
2488                            | otherwise = v
2489                 join_rhs   = mkLams really_final_bndrs rhs'
2490                 join_arity = exprArity join_rhs
2491                 join_call  = mkApps (Var join_bndr) final_args
2492
2493         ; env' <- addPolyBind NotTopLevel env (NonRec (join_bndr `setIdArity` join_arity) join_rhs)
2494         ; return (env', (con, bndrs', join_call)) }
2495                 -- See Note [Duplicated env]
2496 \end{code}
2497
2498 Note [Fusing case continuations]
2499 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2500 It's important to fuse two successive case continuations when the
2501 first has one alternative.  That's why we call prepareCaseCont here.
2502 Consider this, which arises from thunk splitting (see Note [Thunk
2503 splitting] in WorkWrap):
2504
2505       let
2506         x* = case (case v of {pn -> rn}) of
2507                I# a -> I# a
2508       in body
2509
2510 The simplifier will find
2511     (Var v) with continuation
2512             Select (pn -> rn) (
2513             Select [I# a -> I# a] (
2514             StrictBind body Stop
2515
2516 So we'll call mkDupableCont on
2517    Select [I# a -> I# a] (StrictBind body Stop)
2518 There is just one alternative in the first Select, so we want to
2519 simplify the rhs (I# a) with continuation (StricgtBind body Stop)
2520 Supposing that body is big, we end up with
2521           let $j a = <let x = I# a in body>
2522           in case v of { pn -> case rn of
2523                                  I# a -> $j a }
2524 This is just what we want because the rn produces a box that
2525 the case rn cancels with.
2526
2527 See Trac #4957 a fuller example.
2528
2529 Note [Case binders and join points]
2530 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2531 Consider this
2532    case (case .. ) of c {
2533      I# c# -> ....c....
2534
2535 If we make a join point with c but not c# we get
2536   $j = \c -> ....c....
2537
2538 But if later inlining scrutines the c, thus
2539
2540   $j = \c -> ... case c of { I# y -> ... } ...
2541
2542 we won't see that 'c' has already been scrutinised.  This actually
2543 happens in the 'tabulate' function in wave4main, and makes a significant
2544 difference to allocation.
2545
2546 An alternative plan is this:
2547
2548    $j = \c# -> let c = I# c# in ...c....
2549
2550 but that is bad if 'c' is *not* later scrutinised.
2551
2552 So instead we do both: we pass 'c' and 'c#' , and record in c's inlining
2553 (an InlineRule) that it's really I# c#, thus
2554
2555    $j = \c# -> \c[=I# c#] -> ...c....
2556
2557 Absence analysis may later discard 'c'.
2558
2559 NB: take great care when doing strictness analysis;
2560     see Note [Lamba-bound unfoldings] in DmdAnal.
2561
2562 Also note that we can still end up passing stuff that isn't used.  Before
2563 strictness analysis we have
2564    let $j x y c{=(x,y)} = (h c, ...)
2565    in ...
2566 After strictness analysis we see that h is strict, we end up with
2567    let $j x y c{=(x,y)} = ($wh x y, ...)
2568 and c is unused.
2569
2570 Note [Duplicated env]
2571 ~~~~~~~~~~~~~~~~~~~~~
2572 Some of the alternatives are simplified, but have not been turned into a join point
2573 So they *must* have an zapped subst-env.  So we can't use completeNonRecX to
2574 bind the join point, because it might to do PostInlineUnconditionally, and
2575 we'd lose that when zapping the subst-env.  We could have a per-alt subst-env,
2576 but zapping it (as we do in mkDupableCont, the Select case) is safe, and
2577 at worst delays the join-point inlining.
2578
2579 Note [Small alternative rhs]
2580 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2581 It is worth checking for a small RHS because otherwise we
2582 get extra let bindings that may cause an extra iteration of the simplifier to
2583 inline back in place.  Quite often the rhs is just a variable or constructor.
2584 The Ord instance of Maybe in PrelMaybe.lhs, for example, took several extra
2585 iterations because the version with the let bindings looked big, and so wasn't
2586 inlined, but after the join points had been inlined it looked smaller, and so
2587 was inlined.
2588
2589 NB: we have to check the size of rhs', not rhs.
2590 Duplicating a small InAlt might invalidate occurrence information
2591 However, if it *is* dupable, we return the *un* simplified alternative,
2592 because otherwise we'd need to pair it up with an empty subst-env....
2593 but we only have one env shared between all the alts.
2594 (Remember we must zap the subst-env before re-simplifying something).
2595 Rather than do this we simply agree to re-simplify the original (small) thing later.
2596
2597 Note [Funky mkPiTypes]
2598 ~~~~~~~~~~~~~~~~~~~~~~
2599 Notice the funky mkPiTypes.  If the contructor has existentials
2600 it's possible that the join point will be abstracted over
2601 type varaibles as well as term variables.
2602  Example:  Suppose we have
2603         data T = forall t.  C [t]
2604  Then faced with
2605         case (case e of ...) of
2606             C t xs::[t] -> rhs
2607  We get the join point
2608         let j :: forall t. [t] -> ...
2609             j = /\t \xs::[t] -> rhs
2610         in
2611         case (case e of ...) of
2612             C t xs::[t] -> j t xs
2613
2614 Note [Join point abstraction]
2615 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2616 Join points always have at least one value argument,
2617 for several reasons
2618
2619 * If we try to lift a primitive-typed something out
2620   for let-binding-purposes, we will *caseify* it (!),
2621   with potentially-disastrous strictness results.  So
2622   instead we turn it into a function: \v -> e
2623   where v::State# RealWorld#.  The value passed to this function
2624   is realworld#, which generates (almost) no code.
2625
2626 * CPR.  We used to say "&& isUnLiftedType rhs_ty'" here, but now
2627   we make the join point into a function whenever used_bndrs'
2628   is empty.  This makes the join-point more CPR friendly.
2629   Consider:       let j = if .. then I# 3 else I# 4
2630                   in case .. of { A -> j; B -> j; C -> ... }
2631
2632   Now CPR doesn't w/w j because it's a thunk, so
2633   that means that the enclosing function can't w/w either,
2634   which is a lose.  Here's the example that happened in practice:
2635           kgmod :: Int -> Int -> Int
2636           kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
2637                       then 78
2638                       else 5
2639
2640 * Let-no-escape.  We want a join point to turn into a let-no-escape
2641   so that it is implemented as a jump, and one of the conditions
2642   for LNE is that it's not updatable.  In CoreToStg, see
2643   Note [What is a non-escaping let]
2644
2645 * Floating.  Since a join point will be entered once, no sharing is
2646   gained by floating out, but something might be lost by doing
2647   so because it might be allocated.
2648
2649 I have seen a case alternative like this:
2650         True -> \v -> ...
2651 It's a bit silly to add the realWorld dummy arg in this case, making
2652         $j = \s v -> ...
2653            True -> $j s
2654 (the \v alone is enough to make CPR happy) but I think it's rare
2655
2656 There's a slight infelicity here: we pass the overall
2657 case_bndr to all the join points if it's used in *any* RHS,
2658 because we don't know its usage in each RHS separately
2659
2660
2661 Note [Duplicating StrictArg]
2662 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2663 The original plan had (where E is a big argument)
2664 e.g.    f E [..hole..]
2665         ==>     let $j = \a -> f E a
2666                 in $j [..hole..]
2667
2668 But this is terrible! Here's an example:
2669         && E (case x of { T -> F; F -> T })
2670 Now, && is strict so we end up simplifying the case with
2671
2672 an ArgOf continuation.  If we let-bind it, we get
2673         let $j = \v -> && E v
2674         in simplExpr (case x of { T -> F; F -> T })
2675                      (ArgOf (\r -> $j r)
2676 And after simplifying more we get
2677         let $j = \v -> && E v
2678         in case x of { T -> $j F; F -> $j T }
2679 Which is a Very Bad Thing
2680
2681 What we do now is this
2682         f E [..hole..]
2683         ==>     let a = E
2684                 in f a [..hole..]
2685 Now if the thing in the hole is a case expression (which is when
2686 we'll call mkDupableCont), we'll push the function call into the
2687 branches, which is what we want.  Now RULES for f may fire, and
2688 call-pattern specialisation.  Here's an example from Trac #3116
2689      go (n+1) (case l of
2690                  1  -> bs'
2691                  _  -> Chunk p fpc (o+1) (l-1) bs')
2692 If we can push the call for 'go' inside the case, we get
2693 call-pattern specialisation for 'go', which is *crucial* for
2694 this program.
2695
2696 Here is the (&&) example:
2697         && E (case x of { T -> F; F -> T })
2698   ==>   let a = E in
2699         case x of { T -> && a F; F -> && a T }
2700 Much better!
2701
2702 Notice that
2703   * Arguments to f *after* the strict one are handled by
2704     the ApplyTo case of mkDupableCont.  Eg
2705         f [..hole..] E
2706
2707   * We can only do the let-binding of E because the function
2708     part of a StrictArg continuation is an explicit syntax
2709     tree.  In earlier versions we represented it as a function
2710     (CoreExpr -> CoreEpxr) which we couldn't take apart.
2711
2712 Do *not* duplicate StrictBind and StritArg continuations.  We gain
2713 nothing by propagating them into the expressions, and we do lose a
2714 lot.
2715
2716 The desire not to duplicate is the entire reason that
2717 mkDupableCont returns a pair of continuations.
2718
2719 Note [Duplicating StrictBind]
2720 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2721 Unlike StrictArg, there doesn't seem anything to gain from
2722 duplicating a StrictBind continuation, so we don't.
2723
2724
2725 Note [Single-alternative cases]
2726 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2727 This case is just like the ArgOf case.  Here's an example:
2728         data T a = MkT !a
2729         ...(MkT (abs x))...
2730 Then we get
2731         case (case x of I# x' ->
2732               case x' <# 0# of
2733                 True  -> I# (negate# x')
2734                 False -> I# x') of y {
2735           DEFAULT -> MkT y
2736 Because the (case x) has only one alternative, we'll transform to
2737         case x of I# x' ->
2738         case (case x' <# 0# of
2739                 True  -> I# (negate# x')
2740                 False -> I# x') of y {
2741           DEFAULT -> MkT y
2742 But now we do *NOT* want to make a join point etc, giving
2743         case x of I# x' ->
2744         let $j = \y -> MkT y
2745         in case x' <# 0# of
2746                 True  -> $j (I# (negate# x'))
2747                 False -> $j (I# x')
2748 In this case the $j will inline again, but suppose there was a big
2749 strict computation enclosing the orginal call to MkT.  Then, it won't
2750 "see" the MkT any more, because it's big and won't get duplicated.
2751 And, what is worse, nothing was gained by the case-of-case transform.
2752
2753 So, in circumstances like these, we don't want to build join points
2754 and push the outer case into the branches of the inner one. Instead,
2755 don't duplicate the continuation.
2756
2757 When should we use this strategy?  We should not use it on *every*
2758 single-alternative case:
2759   e.g.  case (case ....) of (a,b) -> (# a,b #)
2760 Here we must push the outer case into the inner one!
2761 Other choices:
2762
2763    * Match [(DEFAULT,_,_)], but in the common case of Int,
2764      the alternative-filling-in code turned the outer case into
2765                 case (...) of y { I# _ -> MkT y }
2766
2767    * Match on single alternative plus (not (isDeadBinder case_bndr))
2768      Rationale: pushing the case inwards won't eliminate the construction.
2769      But there's a risk of
2770                 case (...) of y { (a,b) -> let z=(a,b) in ... }
2771      Now y looks dead, but it'll come alive again.  Still, this
2772      seems like the best option at the moment.
2773
2774    * Match on single alternative plus (all (isDeadBinder bndrs))
2775      Rationale: this is essentially  seq.
2776
2777    * Match when the rhs is *not* duplicable, and hence would lead to a
2778      join point.  This catches the disaster-case above.  We can test
2779      the *un-simplified* rhs, which is fine.  It might get bigger or
2780      smaller after simplification; if it gets smaller, this case might
2781      fire next time round.  NB also that we must test contIsDupable
2782      case_cont *too, because case_cont might be big!
2783
2784      HOWEVER: I found that this version doesn't work well, because
2785      we can get         let x = case (...) of { small } in ...case x...
2786      When x is inlined into its full context, we find that it was a bad
2787      idea to have pushed the outer case inside the (...) case.
2788
2789 Note [Single-alternative-unlifted]
2790 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2791 Here's another single-alternative where we really want to do case-of-case:
2792
2793 data Mk1 = Mk1 Int# | Mk2 Int#
2794
2795 M1.f =
2796     \r [x_s74 y_s6X]
2797         case
2798             case y_s6X of tpl_s7m {
2799               M1.Mk1 ipv_s70 -> ipv_s70;
2800               M1.Mk2 ipv_s72 -> ipv_s72;
2801             }
2802         of
2803         wild_s7c
2804         { __DEFAULT ->
2805               case
2806                   case x_s74 of tpl_s7n {
2807                     M1.Mk1 ipv_s77 -> ipv_s77;
2808                     M1.Mk2 ipv_s79 -> ipv_s79;
2809                   }
2810               of
2811               wild1_s7b
2812               { __DEFAULT -> ==# [wild1_s7b wild_s7c];
2813               };
2814         };
2815
2816 So the outer case is doing *nothing at all*, other than serving as a
2817 join-point.  In this case we really want to do case-of-case and decide
2818 whether to use a real join point or just duplicate the continuation:
2819
2820     let $j s7c = case x of
2821                    Mk1 ipv77 -> (==) s7c ipv77
2822                    Mk1 ipv79 -> (==) s7c ipv79
2823     in
2824     case y of
2825       Mk1 ipv70 -> $j ipv70
2826       Mk2 ipv72 -> $j ipv72
2827
2828 Hence: check whether the case binder's type is unlifted, because then
2829 the outer case is *not* a seq.