2 % (c) The AQUA Project, Glasgow University, 1993-1998
4 \section[Simplify]{The main module of the simplifier}
8 -- The above warning supression flag is a temporary kludge.
9 -- While working on this module you are encouraged to remove it and fix
10 -- any warnings in the module. See
11 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
14 module Simplify ( simplTopBinds, simplExpr ) where
16 #include "HsVersions.h"
20 import Type hiding ( substTy, extendTvSubst )
27 import FamInstEnv ( topNormaliseType )
28 import DataCon ( dataConRepStrictness, dataConUnivTyVars )
30 import NewDemand ( isStrictDmd )
31 import PprCore ( pprParendExpr, pprCoreExpr )
32 import CoreUnfold ( mkUnfolding, callSiteInline )
34 import Rules ( lookupRule )
35 import BasicTypes ( isMarkedStrict )
36 import CostCentre ( currentCCS )
37 import TysPrim ( realWorldStatePrimTy )
38 import PrelInfo ( realWorldPrimId )
39 import BasicTypes ( TopLevelFlag(..), isTopLevel,
40 RecFlag(..), isNonRuleLoopBreaker )
41 import Maybes ( orElse )
47 The guts of the simplifier is in this module, but the driver loop for
48 the simplifier is in SimplCore.lhs.
51 -----------------------------------------
52 *** IMPORTANT NOTE ***
53 -----------------------------------------
54 The simplifier used to guarantee that the output had no shadowing, but
55 it does not do so any more. (Actually, it never did!) The reason is
56 documented with simplifyArgs.
59 -----------------------------------------
60 *** IMPORTANT NOTE ***
61 -----------------------------------------
62 Many parts of the simplifier return a bunch of "floats" as well as an
63 expression. This is wrapped as a datatype SimplUtils.FloatsWith.
65 All "floats" are let-binds, not case-binds, but some non-rec lets may
66 be unlifted (with RHS ok-for-speculation).
70 -----------------------------------------
71 ORGANISATION OF FUNCTIONS
72 -----------------------------------------
74 - simplify all top-level binders
75 - for NonRec, call simplRecOrTopPair
76 - for Rec, call simplRecBind
79 ------------------------------
80 simplExpr (applied lambda) ==> simplNonRecBind
81 simplExpr (Let (NonRec ...) ..) ==> simplNonRecBind
82 simplExpr (Let (Rec ...) ..) ==> simplify binders; simplRecBind
84 ------------------------------
85 simplRecBind [binders already simplfied]
86 - use simplRecOrTopPair on each pair in turn
88 simplRecOrTopPair [binder already simplified]
89 Used for: recursive bindings (top level and nested)
90 top-level non-recursive bindings
92 - check for PreInlineUnconditionally
96 Used for: non-top-level non-recursive bindings
97 beta reductions (which amount to the same thing)
98 Because it can deal with strict arts, it takes a
99 "thing-inside" and returns an expression
101 - check for PreInlineUnconditionally
102 - simplify binder, including its IdInfo
111 simplNonRecX: [given a *simplified* RHS, but an *unsimplified* binder]
112 Used for: binding case-binder and constr args in a known-constructor case
113 - check for PreInLineUnconditionally
117 ------------------------------
118 simplLazyBind: [binder already simplified, RHS not]
119 Used for: recursive bindings (top level and nested)
120 top-level non-recursive bindings
121 non-top-level, but *lazy* non-recursive bindings
122 [must not be strict or unboxed]
123 Returns floats + an augmented environment, not an expression
124 - substituteIdInfo and add result to in-scope
125 [so that rules are available in rec rhs]
128 - float if exposes constructor or PAP
132 completeNonRecX: [binder and rhs both simplified]
133 - if the the thing needs case binding (unlifted and not ok-for-spec)
139 completeBind: [given a simplified RHS]
140 [used for both rec and non-rec bindings, top level and not]
141 - try PostInlineUnconditionally
142 - add unfolding [this is the only place we add an unfolding]
147 Right hand sides and arguments
148 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
149 In many ways we want to treat
150 (a) the right hand side of a let(rec), and
151 (b) a function argument
152 in the same way. But not always! In particular, we would
153 like to leave these arguments exactly as they are, so they
154 will match a RULE more easily.
159 It's harder to make the rule match if we ANF-ise the constructor,
160 or eta-expand the PAP:
162 f (let { a = g x; b = h x } in (a,b))
165 On the other hand if we see the let-defns
170 then we *do* want to ANF-ise and eta-expand, so that p and q
171 can be safely inlined.
173 Even floating lets out is a bit dubious. For let RHS's we float lets
174 out if that exposes a value, so that the value can be inlined more vigorously.
177 r = let x = e in (x,x)
179 Here, if we float the let out we'll expose a nice constructor. We did experiments
180 that showed this to be a generally good thing. But it was a bad thing to float
181 lets out unconditionally, because that meant they got allocated more often.
183 For function arguments, there's less reason to expose a constructor (it won't
184 get inlined). Just possibly it might make a rule match, but I'm pretty skeptical.
185 So for the moment we don't float lets out of function arguments either.
190 For eta expansion, we want to catch things like
192 case e of (a,b) -> \x -> case a of (p,q) -> \y -> r
194 If the \x was on the RHS of a let, we'd eta expand to bring the two
195 lambdas together. And in general that's a good thing to do. Perhaps
196 we should eta expand wherever we find a (value) lambda? Then the eta
197 expansion at a let RHS can concentrate solely on the PAP case.
200 %************************************************************************
202 \subsection{Bindings}
204 %************************************************************************
207 simplTopBinds :: SimplEnv -> [InBind] -> SimplM [OutBind]
209 simplTopBinds env binds
210 = do { -- Put all the top-level binders into scope at the start
211 -- so that if a transformation rule has unexpectedly brought
212 -- anything into scope, then we don't get a complaint about that.
213 -- It's rather as if the top-level binders were imported.
214 ; env <- simplRecBndrs env (bindersOfBinds binds)
215 ; dflags <- getDOptsSmpl
216 ; let dump_flag = dopt Opt_D_dump_inlinings dflags ||
217 dopt Opt_D_dump_rule_firings dflags
218 ; env' <- simpl_binds dump_flag env binds
219 ; freeTick SimplifierDone
220 ; return (getFloats env') }
222 -- We need to track the zapped top-level binders, because
223 -- they should have their fragile IdInfo zapped (notably occurrence info)
224 -- That's why we run down binds and bndrs' simultaneously.
226 -- The dump-flag emits a trace for each top-level binding, which
227 -- helps to locate the tracing for inlining and rule firing
228 simpl_binds :: Bool -> SimplEnv -> [InBind] -> SimplM SimplEnv
229 simpl_binds dump env [] = return env
230 simpl_binds dump env (bind:binds) = do { env' <- trace dump bind $
232 ; simpl_binds dump env' binds }
234 trace True bind = pprTrace "SimplBind" (ppr (bindersOf bind))
235 trace False bind = \x -> x
237 simpl_bind env (NonRec b r) = simplRecOrTopPair env TopLevel b r
238 simpl_bind env (Rec pairs) = simplRecBind env TopLevel pairs
242 %************************************************************************
244 \subsection{Lazy bindings}
246 %************************************************************************
248 simplRecBind is used for
249 * recursive bindings only
252 simplRecBind :: SimplEnv -> TopLevelFlag
255 simplRecBind env top_lvl pairs
256 = do { env' <- go (zapFloats env) pairs
257 ; return (env `addRecFloats` env') }
258 -- addFloats adds the floats from env',
259 -- *and* updates env with the in-scope set from env'
261 go env [] = return env
263 go env ((bndr, rhs) : pairs)
264 = do { env <- simplRecOrTopPair env top_lvl bndr rhs
268 simplOrTopPair is used for
269 * recursive bindings (whether top level or not)
270 * top-level non-recursive bindings
272 It assumes the binder has already been simplified, but not its IdInfo.
275 simplRecOrTopPair :: SimplEnv
277 -> InId -> InExpr -- Binder and rhs
278 -> SimplM SimplEnv -- Returns an env that includes the binding
280 simplRecOrTopPair env top_lvl bndr rhs
281 | preInlineUnconditionally env top_lvl bndr rhs -- Check for unconditional inline
282 = do { tick (PreInlineUnconditionally bndr)
283 ; return (extendIdSubst env bndr (mkContEx env rhs)) }
286 = do { let bndr' = lookupRecBndr env bndr
287 (env', bndr'') = addLetIdInfo env bndr bndr'
288 ; simplLazyBind env' top_lvl Recursive bndr bndr'' rhs env' }
289 -- May not actually be recursive, but it doesn't matter
293 simplLazyBind is used for
294 * [simplRecOrTopPair] recursive bindings (whether top level or not)
295 * [simplRecOrTopPair] top-level non-recursive bindings
296 * [simplNonRecE] non-top-level *lazy* non-recursive bindings
299 1. It assumes that the binder is *already* simplified,
300 and is in scope, and its IdInfo too, except unfolding
302 2. It assumes that the binder type is lifted.
304 3. It does not check for pre-inline-unconditionallly;
305 that should have been done already.
308 simplLazyBind :: SimplEnv
309 -> TopLevelFlag -> RecFlag
310 -> InId -> OutId -- Binder, both pre-and post simpl
311 -- The OutId has IdInfo, except arity, unfolding
312 -> InExpr -> SimplEnv -- The RHS and its environment
315 simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
316 = do { let rhs_env = rhs_se `setInScope` env
317 (tvs, body) = collectTyBinders rhs
318 ; (body_env, tvs') <- simplBinders rhs_env tvs
319 -- See Note [Floating and type abstraction]
322 -- Simplify the RHS; note the mkRhsStop, which tells
323 -- the simplifier that this is the RHS of a let.
324 ; let rhs_cont = mkRhsStop (applyTys (idType bndr1) (mkTyVarTys tvs'))
325 ; (body_env1, body1) <- simplExprF body_env body rhs_cont
327 -- ANF-ise a constructor or PAP rhs
328 ; (body_env2, body2) <- prepareRhs body_env1 body1
331 <- if not (doFloatFromRhs top_lvl is_rec False body2 body_env2)
332 then -- No floating, just wrap up!
333 do { rhs' <- mkLam tvs' (wrapFloats body_env2 body2)
334 ; return (env, rhs') }
336 else if null tvs then -- Simple floating
337 do { tick LetFloatFromLet
338 ; return (addFloats env body_env2, body2) }
340 else -- Do type-abstraction first
341 do { tick LetFloatFromLet
342 ; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2
343 ; rhs' <- mkLam tvs' body3
344 ; return (extendFloats env poly_binds, rhs') }
346 ; completeBind env' top_lvl bndr bndr1 rhs' }
349 A specialised variant of simplNonRec used when the RHS is already simplified,
350 notably in knownCon. It uses case-binding where necessary.
353 simplNonRecX :: SimplEnv
354 -> InId -- Old binder
355 -> OutExpr -- Simplified RHS
358 simplNonRecX env bndr new_rhs
359 = do { (env, bndr') <- simplBinder env bndr
360 ; completeNonRecX env NotTopLevel NonRecursive
361 (isStrictId bndr) bndr bndr' new_rhs }
363 completeNonRecX :: SimplEnv
364 -> TopLevelFlag -> RecFlag -> Bool
365 -> InId -- Old binder
366 -> OutId -- New binder
367 -> OutExpr -- Simplified RHS
370 completeNonRecX env top_lvl is_rec is_strict old_bndr new_bndr new_rhs
371 = do { (env1, rhs1) <- prepareRhs (zapFloats env) new_rhs
373 if doFloatFromRhs top_lvl is_rec is_strict rhs1 env1
374 then do { tick LetFloatFromLet
375 ; return (addFloats env env1, rhs1) } -- Add the floats to the main env
376 else return (env, wrapFloats env1 rhs1) -- Wrap the floats around the RHS
377 ; completeBind env2 NotTopLevel old_bndr new_bndr rhs2 }
380 {- No, no, no! Do not try preInlineUnconditionally in completeNonRecX
381 Doing so risks exponential behaviour, because new_rhs has been simplified once already
382 In the cases described by the folowing commment, postInlineUnconditionally will
383 catch many of the relevant cases.
384 -- This happens; for example, the case_bndr during case of
385 -- known constructor: case (a,b) of x { (p,q) -> ... }
386 -- Here x isn't mentioned in the RHS, so we don't want to
387 -- create the (dead) let-binding let x = (a,b) in ...
389 -- Similarly, single occurrences can be inlined vigourously
390 -- e.g. case (f x, g y) of (a,b) -> ....
391 -- If a,b occur once we can avoid constructing the let binding for them.
393 Furthermore in the case-binding case preInlineUnconditionally risks extra thunks
394 -- Consider case I# (quotInt# x y) of
395 -- I# v -> let w = J# v in ...
396 -- If we gaily inline (quotInt# x y) for v, we end up building an
398 -- let w = J# (quotInt# x y) in ...
399 -- because quotInt# can fail.
401 | preInlineUnconditionally env NotTopLevel bndr new_rhs
402 = thing_inside (extendIdSubst env bndr (DoneEx new_rhs))
405 ----------------------------------
406 prepareRhs takes a putative RHS, checks whether it's a PAP or
407 constructor application and, if so, converts it to ANF, so that the
408 resulting thing can be inlined more easily. Thus
415 We also want to deal well cases like this
416 v = (f e1 `cast` co) e2
417 Here we want to make e1,e2 trivial and get
418 x1 = e1; x2 = e2; v = (f x1 `cast` co) v2
419 That's what the 'go' loop in prepareRhs does
422 prepareRhs :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
423 -- Adds new floats to the env iff that allows us to return a good RHS
424 prepareRhs env (Cast rhs co) -- Note [Float coercions]
425 | (ty1, ty2) <- coercionKind co -- Do *not* do this if rhs has an unlifted type
426 , not (isUnLiftedType ty1) -- see Note [Float coercions (unlifted)]
427 = do { (env', rhs') <- makeTrivial env rhs
428 ; return (env', Cast rhs' co) }
431 = do { (is_val, env', rhs') <- go 0 env rhs
432 ; return (env', rhs') }
434 go n_val_args env (Cast rhs co)
435 = do { (is_val, env', rhs') <- go n_val_args env rhs
436 ; return (is_val, env', Cast rhs' co) }
437 go n_val_args env (App fun (Type ty))
438 = do { (is_val, env', rhs') <- go n_val_args env fun
439 ; return (is_val, env', App rhs' (Type ty)) }
440 go n_val_args env (App fun arg)
441 = do { (is_val, env', fun') <- go (n_val_args+1) env fun
443 True -> do { (env'', arg') <- makeTrivial env' arg
444 ; return (True, env'', App fun' arg') }
445 False -> return (False, env, App fun arg) }
446 go n_val_args env (Var fun)
447 = return (is_val, env, Var fun)
449 is_val = n_val_args > 0 -- There is at least one arg
450 -- ...and the fun a constructor or PAP
451 && (isDataConWorkId fun || n_val_args < idArity fun)
452 go n_val_args env other
453 = return (False, env, other)
457 Note [Float coercions]
458 ~~~~~~~~~~~~~~~~~~~~~~
459 When we find the binding
461 we'd like to transform it to
463 x = x `cast` co -- A trivial binding
464 There's a chance that e will be a constructor application or function, or something
465 like that, so moving the coerion to the usage site may well cancel the coersions
466 and lead to further optimisation. Example:
469 data instance T Int = T Int
471 foo :: Int -> Int -> Int
476 go n = case x of { T m -> go (n-m) }
477 -- This case should optimise
479 Note [Float coercions (unlifted)]
480 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
481 BUT don't do [Float coercions] if 'e' has an unlifted type.
484 foo :: Int = (error (# Int,Int #) "urk")
485 `cast` CoUnsafe (# Int,Int #) Int
487 If do the makeTrivial thing to the error call, we'll get
488 foo = case error (# Int,Int #) "urk" of v -> v `cast` ...
489 But 'v' isn't in scope!
491 These strange casts can happen as a result of case-of-case
492 bar = case (case x of { T -> (# 2,3 #); F -> error "urk" }) of
497 makeTrivial :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
498 -- Binds the expression to a variable, if it's not trivial, returning the variable
502 | otherwise -- See Note [Take care] below
503 = do { var <- newId FSLIT("a") (exprType expr)
504 ; env <- completeNonRecX env NotTopLevel NonRecursive
506 ; return (env, substExpr env (Var var)) }
510 %************************************************************************
512 \subsection{Completing a lazy binding}
514 %************************************************************************
517 * deals only with Ids, not TyVars
518 * takes an already-simplified binder and RHS
519 * is used for both recursive and non-recursive bindings
520 * is used for both top-level and non-top-level bindings
522 It does the following:
523 - tries discarding a dead binding
524 - tries PostInlineUnconditionally
525 - add unfolding [this is the only place we add an unfolding]
528 It does *not* attempt to do let-to-case. Why? Because it is used for
529 - top-level bindings (when let-to-case is impossible)
530 - many situations where the "rhs" is known to be a WHNF
531 (so let-to-case is inappropriate).
533 Nor does it do the atomic-argument thing
536 completeBind :: SimplEnv
537 -> TopLevelFlag -- Flag stuck into unfolding
538 -> InId -- Old binder
539 -> OutId -> OutExpr -- New binder and RHS
541 -- completeBind may choose to do its work
542 -- * by extending the substitution (e.g. let x = y in ...)
543 -- * or by adding to the floats in the envt
545 completeBind env top_lvl old_bndr new_bndr new_rhs
546 | postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs unfolding
547 -- Inline and discard the binding
548 = do { tick (PostInlineUnconditionally old_bndr)
549 ; -- pprTrace "postInlineUnconditionally" (ppr old_bndr <+> ppr new_bndr <+> ppr new_rhs) $
550 return (extendIdSubst env old_bndr (DoneEx new_rhs)) }
551 -- Use the substitution to make quite, quite sure that the
552 -- substitution will happen, since we are going to discard the binding
557 new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs
560 -- Add the unfolding *only* for non-loop-breakers
561 -- Making loop breakers not have an unfolding at all
562 -- means that we can avoid tests in exprIsConApp, for example.
563 -- This is important: if exprIsConApp says 'yes' for a recursive
564 -- thing, then we can get into an infinite loop
567 -- If the unfolding is a value, the demand info may
568 -- go pear-shaped, so we nuke it. Example:
570 -- case x of (p,q) -> h p q x
571 -- Here x is certainly demanded. But after we've nuked
572 -- the case, we'll get just
573 -- let x = (a,b) in h a b x
574 -- and now x is not demanded (I'm assuming h is lazy)
575 -- This really happens. Similarly
576 -- let f = \x -> e in ...f..f...
577 -- After inlining f at some of its call sites the original binding may
578 -- (for example) be no longer strictly demanded.
579 -- The solution here is a bit ad hoc...
580 info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding
581 final_info | loop_breaker = new_bndr_info
582 | isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf
583 | otherwise = info_w_unf
585 final_id = new_bndr `setIdInfo` final_info
587 -- These seqs forces the Id, and hence its IdInfo,
588 -- and hence any inner substitutions
590 -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $
591 return (addNonRec env final_id new_rhs)
593 unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs
594 loop_breaker = isNonRuleLoopBreaker occ_info
595 old_info = idInfo old_bndr
596 occ_info = occInfo old_info
601 %************************************************************************
603 \subsection[Simplify-simplExpr]{The main function: simplExpr}
605 %************************************************************************
607 The reason for this OutExprStuff stuff is that we want to float *after*
608 simplifying a RHS, not before. If we do so naively we get quadratic
609 behaviour as things float out.
611 To see why it's important to do it after, consider this (real) example:
625 a -- Can't inline a this round, cos it appears twice
629 Each of the ==> steps is a round of simplification. We'd save a
630 whole round if we float first. This can cascade. Consider
635 let f = let d1 = ..d.. in \y -> e
639 in \x -> ...(\y ->e)...
641 Only in this second round can the \y be applied, and it
642 might do the same again.
646 simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
647 simplExpr env expr = simplExprC env expr (mkBoringStop expr_ty')
649 expr_ty' = substTy env (exprType expr)
650 -- The type in the Stop continuation, expr_ty', is usually not used
651 -- It's only needed when discarding continuations after finding
652 -- a function that returns bottom.
653 -- Hence the lazy substitution
656 simplExprC :: SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr
657 -- Simplify an expression, given a continuation
658 simplExprC env expr cont
659 = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seFloats env) ) $
660 do { (env', expr') <- simplExprF (zapFloats env) expr cont
661 ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $
662 -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $
663 -- pprTrace "simplExprC ret4" (ppr (seFloats env')) $
664 return (wrapFloats env' expr') }
666 --------------------------------------------------
667 simplExprF :: SimplEnv -> InExpr -> SimplCont
668 -> SimplM (SimplEnv, OutExpr)
670 simplExprF env e cont
671 = -- pprTrace "simplExprF" (ppr e $$ ppr cont $$ ppr (seTvSubst env) $$ ppr (seIdSubst env) {- $$ ppr (seFloats env) -} ) $
672 simplExprF' env e cont
674 simplExprF' env (Var v) cont = simplVar env v cont
675 simplExprF' env (Lit lit) cont = rebuild env (Lit lit) cont
676 simplExprF' env (Note n expr) cont = simplNote env n expr cont
677 simplExprF' env (Cast body co) cont = simplCast env body co cont
678 simplExprF' env (App fun arg) cont = simplExprF env fun $
679 ApplyTo NoDup arg env cont
681 simplExprF' env expr@(Lam _ _) cont
682 = simplLam env (map zap bndrs) body cont
683 -- The main issue here is under-saturated lambdas
684 -- (\x1. \x2. e) arg1
685 -- Here x1 might have "occurs-once" occ-info, because occ-info
686 -- is computed assuming that a group of lambdas is applied
687 -- all at once. If there are too few args, we must zap the
690 n_args = countArgs cont
691 n_params = length bndrs
692 (bndrs, body) = collectBinders expr
693 zap | n_args >= n_params = \b -> b
694 | otherwise = \b -> if isTyVar b then b
696 -- NB: we count all the args incl type args
697 -- so we must count all the binders (incl type lambdas)
699 simplExprF' env (Type ty) cont
700 = ASSERT( contIsRhsOrArg cont )
701 do { ty' <- simplType env ty
702 ; rebuild env (Type ty') cont }
704 simplExprF' env (Case scrut bndr case_ty alts) cont
705 | not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
706 = -- Simplify the scrutinee with a Select continuation
707 simplExprF env scrut (Select NoDup bndr alts env cont)
710 = -- If case-of-case is off, simply simplify the case expression
711 -- in a vanilla Stop context, and rebuild the result around it
712 do { case_expr' <- simplExprC env scrut case_cont
713 ; rebuild env case_expr' cont }
715 case_cont = Select NoDup bndr alts env (mkBoringStop case_ty')
716 case_ty' = substTy env case_ty -- c.f. defn of simplExpr
718 simplExprF' env (Let (Rec pairs) body) cont
719 = do { env <- simplRecBndrs env (map fst pairs)
720 -- NB: bndrs' don't have unfoldings or rules
721 -- We add them as we go down
723 ; env <- simplRecBind env NotTopLevel pairs
724 ; simplExprF env body cont }
726 simplExprF' env (Let (NonRec bndr rhs) body) cont
727 = simplNonRecE env bndr (rhs, env) ([], body) cont
729 ---------------------------------
730 simplType :: SimplEnv -> InType -> SimplM OutType
731 -- Kept monadic just so we can do the seqType
733 = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $
734 seqType new_ty `seq` returnSmpl new_ty
736 new_ty = substTy env ty
740 %************************************************************************
742 \subsection{The main rebuilder}
744 %************************************************************************
747 rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr)
748 -- At this point the substitution in the SimplEnv should be irrelevant
749 -- only the in-scope set and floats should matter
750 rebuild env expr cont
751 = -- pprTrace "rebuild" (ppr expr $$ ppr cont $$ ppr (seFloats env)) $
753 Stop {} -> return (env, expr)
754 CoerceIt co cont -> rebuild env (mkCoerce co expr) cont
755 Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont
756 StrictArg fun ty info cont -> rebuildCall env (fun `App` expr) (funResultTy ty) info cont
757 StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr
758 ; simplLam env' bs body cont }
759 ApplyTo _ arg se cont -> do { arg' <- simplExpr (se `setInScope` env) arg
760 ; rebuild env (App expr arg') cont }
764 %************************************************************************
768 %************************************************************************
771 simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont
772 -> SimplM (SimplEnv, OutExpr)
773 simplCast env body co cont
774 = do { co' <- simplType env co
775 ; simplExprF env body (addCoerce co' cont) }
777 addCoerce co cont = add_coerce co (coercionKind co) cont
779 add_coerce co (s1, k1) cont -- co :: ty~ty
780 | s1 `coreEqType` k1 = cont -- is a no-op
782 add_coerce co1 (s1, k2) (CoerceIt co2 cont)
783 | (l1, t1) <- coercionKind co2
784 -- coerce T1 S1 (coerce S1 K1 e)
787 -- coerce T1 K1 e, otherwise
789 -- For example, in the initial form of a worker
790 -- we may find (coerce T (coerce S (\x.e))) y
791 -- and we'd like it to simplify to e[y/x] in one round
793 , s1 `coreEqType` t1 = cont -- The coerces cancel out
794 | otherwise = CoerceIt (mkTransCoercion co1 co2) cont
796 add_coerce co (s1s2, t1t2) (ApplyTo dup (Type arg_ty) arg_se cont)
797 -- (f `cast` g) ty ---> (f ty) `cast` (g @ ty)
798 -- This implements the PushT rule from the paper
799 | Just (tyvar,_) <- splitForAllTy_maybe s1s2
800 , not (isCoVar tyvar)
801 = ApplyTo dup (Type ty') (zapSubstEnv env) (addCoerce (mkInstCoercion co ty') cont)
803 ty' = substTy arg_se arg_ty
805 -- ToDo: the PushC rule is not implemented at all
807 add_coerce co (s1s2, t1t2) (ApplyTo dup arg arg_se cont)
808 | not (isTypeArg arg) -- This implements the Push rule from the paper
809 , isFunTy s1s2 -- t1t2 must be a function type, becuase it's applied
810 -- co : s1s2 :=: t1t2
811 -- (coerce (T1->T2) (S1->S2) F) E
813 -- coerce T2 S2 (F (coerce S1 T1 E))
815 -- t1t2 must be a function type, T1->T2, because it's applied
816 -- to something but s1s2 might conceivably not be
818 -- When we build the ApplyTo we can't mix the out-types
819 -- with the InExpr in the argument, so we simply substitute
820 -- to make it all consistent. It's a bit messy.
821 -- But it isn't a common case.
823 -- Example of use: Trac #995
824 = ApplyTo dup new_arg (zapSubstEnv env) (addCoerce co2 cont)
826 -- we split coercion t1->t2 :=: s1->s2 into t1 :=: s1 and
827 -- t2 :=: s2 with left and right on the curried form:
828 -- (->) t1 t2 :=: (->) s1 s2
829 [co1, co2] = decomposeCo 2 co
830 new_arg = mkCoerce (mkSymCoercion co1) arg'
831 arg' = substExpr arg_se arg
833 add_coerce co _ cont = CoerceIt co cont
837 %************************************************************************
841 %************************************************************************
844 simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont
845 -> SimplM (SimplEnv, OutExpr)
847 simplLam env [] body cont = simplExprF env body cont
849 -- Type-beta reduction
850 simplLam env (bndr:bndrs) body (ApplyTo _ (Type ty_arg) arg_se cont)
851 = ASSERT( isTyVar bndr )
852 do { tick (BetaReduction bndr)
853 ; ty_arg' <- simplType (arg_se `setInScope` env) ty_arg
854 ; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont }
856 -- Ordinary beta reduction
857 simplLam env (bndr:bndrs) body (ApplyTo _ arg arg_se cont)
858 = do { tick (BetaReduction bndr)
859 ; simplNonRecE env bndr (arg, arg_se) (bndrs, body) cont }
861 -- Not enough args, so there are real lambdas left to put in the result
862 simplLam env bndrs body cont
863 = do { (env, bndrs') <- simplLamBndrs env bndrs
864 ; body' <- simplExpr env body
865 ; new_lam <- mkLam bndrs' body'
866 ; rebuild env new_lam cont }
869 simplNonRecE :: SimplEnv
870 -> InId -- The binder
871 -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda)
872 -> ([InId], InExpr) -- Body of the let/lambda
875 -> SimplM (SimplEnv, OutExpr)
877 -- simplNonRecE is used for
878 -- * non-top-level non-recursive lets in expressions
881 -- It deals with strict bindings, via the StrictBind continuation,
882 -- which may abort the whole process
884 -- The "body" of the binding comes as a pair of ([InId],InExpr)
885 -- representing a lambda; so we recurse back to simplLam
886 -- Why? Because of the binder-occ-info-zapping done before
887 -- the call to simplLam in simplExprF (Lam ...)
889 simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
890 | preInlineUnconditionally env NotTopLevel bndr rhs
891 = do { tick (PreInlineUnconditionally bndr)
892 ; simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont }
895 = do { simplExprF (rhs_se `setFloats` env) rhs
896 (StrictBind bndr bndrs body env cont) }
899 = do { (env, bndr') <- simplNonRecBndr env bndr
900 ; env <- simplLazyBind env NotTopLevel NonRecursive bndr bndr' rhs rhs_se
901 ; simplLam env bndrs body cont }
905 %************************************************************************
909 %************************************************************************
912 -- Hack alert: we only distinguish subsumed cost centre stacks for the
913 -- purposes of inlining. All other CCCSs are mapped to currentCCS.
914 simplNote env (SCC cc) e cont
915 = do { e' <- simplExpr (setEnclosingCC env currentCCS) e
916 ; rebuild env (mkSCC cc e') cont }
918 -- See notes with SimplMonad.inlineMode
919 simplNote env InlineMe e cont
920 | Just (inside, outside) <- splitInlineCont cont -- Boring boring continuation; see notes above
921 = do { -- Don't inline inside an INLINE expression
922 e' <- simplExprC (setMode inlineMode env) e inside
923 ; rebuild env (mkInlineMe e') outside }
925 | otherwise -- Dissolve the InlineMe note if there's
926 -- an interesting context of any kind to combine with
927 -- (even a type application -- anything except Stop)
928 = simplExprF env e cont
930 simplNote env (CoreNote s) e cont
931 = simplExpr env e `thenSmpl` \ e' ->
932 rebuild env (Note (CoreNote s) e') cont
936 %************************************************************************
938 \subsection{Dealing with calls}
940 %************************************************************************
943 simplVar env var cont
944 = case substId env var of
945 DoneEx e -> simplExprF (zapSubstEnv env) e cont
946 ContEx tvs ids e -> simplExprF (setSubstEnv env tvs ids) e cont
947 DoneId var1 -> completeCall (zapSubstEnv env) var1 cont
948 -- Note [zapSubstEnv]
949 -- The template is already simplified, so don't re-substitute.
950 -- This is VITAL. Consider
952 -- let y = \z -> ...x... in
954 -- We'll clone the inner \x, adding x->x' in the id_subst
955 -- Then when we inline y, we must *not* replace x by x' in
956 -- the inlined copy!!
958 ---------------------------------------------------------
959 -- Dealing with a call site
961 completeCall env var cont
962 = do { dflags <- getDOptsSmpl
963 ; let (args,call_cont) = contArgs cont
964 -- The args are OutExprs, obtained by *lazily* substituting
965 -- in the args found in cont. These args are only examined
966 -- to limited depth (unless a rule fires). But we must do
967 -- the substitution; rule matching on un-simplified args would
970 ------------- First try rules ----------------
971 -- Do this before trying inlining. Some functions have
972 -- rules *and* are strict; in this case, we don't want to
973 -- inline the wrapper of the non-specialised thing; better
974 -- to call the specialised thing instead.
976 -- We used to use the black-listing mechanism to ensure that inlining of
977 -- the wrapper didn't occur for things that have specialisations till a
978 -- later phase, so but now we just try RULES first
980 -- Note [Self-recursive rules]
981 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
982 -- You might think that we shouldn't apply rules for a loop breaker:
983 -- doing so might give rise to an infinite loop, because a RULE is
984 -- rather like an extra equation for the function:
985 -- RULE: f (g x) y = x+y
988 -- But it's too drastic to disable rules for loop breakers.
989 -- Even the foldr/build rule would be disabled, because foldr
990 -- is recursive, and hence a loop breaker:
991 -- foldr k z (build g) = g k z
992 -- So it's up to the programmer: rules can cause divergence
994 ; let in_scope = getInScope env
995 maybe_rule = case activeRule dflags env of
996 Nothing -> Nothing -- No rules apply
997 Just act_fn -> lookupRule act_fn in_scope
999 ; case maybe_rule of {
1000 Just (rule, rule_rhs) ->
1001 tick (RuleFired (ru_name rule)) `thenSmpl_`
1002 (if dopt Opt_D_dump_rule_firings dflags then
1003 pprTrace "Rule fired" (vcat [
1004 text "Rule:" <+> ftext (ru_name rule),
1005 text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
1006 text "After: " <+> pprCoreExpr rule_rhs,
1007 text "Cont: " <+> ppr call_cont])
1010 simplExprF env rule_rhs (dropArgs (ruleArity rule) cont)
1011 -- The ruleArity says how many args the rule consumed
1013 ; Nothing -> do -- No rules
1015 ------------- Next try inlining ----------------
1016 { let arg_infos = [interestingArg arg | arg <- args, isValArg arg]
1017 n_val_args = length arg_infos
1018 interesting_cont = interestingCallContext (notNull args)
1021 active_inline = activeInline env var
1022 maybe_inline = callSiteInline dflags active_inline
1023 var arg_infos interesting_cont
1024 ; case maybe_inline of {
1025 Just unfolding -- There is an inlining!
1026 -> do { tick (UnfoldingDone var)
1027 ; (if dopt Opt_D_dump_inlinings dflags then
1028 pprTrace ("Inlining done" ++ showSDoc (ppr var)) (vcat [
1029 text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
1030 text "Inlined fn: " <+> nest 2 (ppr unfolding),
1031 text "Cont: " <+> ppr call_cont])
1034 simplExprF env unfolding cont }
1036 ; Nothing -> -- No inlining!
1038 ------------- No inlining! ----------------
1039 -- Next, look for rules or specialisations that match
1041 rebuildCall env (Var var) (idType var)
1042 (mkArgInfo var n_val_args call_cont) cont
1045 rebuildCall :: SimplEnv
1046 -> OutExpr -> OutType -- Function and its type
1047 -> (Bool, [Bool]) -- See SimplUtils.mkArgInfo
1049 -> SimplM (SimplEnv, OutExpr)
1050 rebuildCall env fun fun_ty (has_rules, []) cont
1051 -- When we run out of strictness args, it means
1052 -- that the call is definitely bottom; see SimplUtils.mkArgInfo
1053 -- Then we want to discard the entire strict continuation. E.g.
1054 -- * case (error "hello") of { ... }
1055 -- * (error "Hello") arg
1056 -- * f (error "Hello") where f is strict
1058 -- Then, especially in the first of these cases, we'd like to discard
1059 -- the continuation, leaving just the bottoming expression. But the
1060 -- type might not be right, so we may have to add a coerce.
1061 | not (contIsTrivial cont) -- Only do this if there is a non-trivial
1062 = return (env, mk_coerce fun) -- contination to discard, else we do it
1063 where -- again and again!
1064 cont_ty = contResultType cont
1065 co = mkUnsafeCoercion fun_ty cont_ty
1066 mk_coerce expr | cont_ty `coreEqType` fun_ty = fun
1067 | otherwise = mkCoerce co fun
1069 rebuildCall env fun fun_ty info (ApplyTo _ (Type arg_ty) se cont)
1070 = do { ty' <- simplType (se `setInScope` env) arg_ty
1071 ; rebuildCall env (fun `App` Type ty') (applyTy fun_ty ty') info cont }
1073 rebuildCall env fun fun_ty (has_rules, str:strs) (ApplyTo _ arg arg_se cont)
1074 | str || isStrictType arg_ty -- Strict argument
1075 = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
1076 simplExprF (arg_se `setFloats` env) arg
1077 (StrictArg fun fun_ty (has_rules, strs) cont)
1080 | otherwise -- Lazy argument
1081 -- DO NOT float anything outside, hence simplExprC
1082 -- There is no benefit (unlike in a let-binding), and we'd
1083 -- have to be very careful about bogus strictness through
1084 -- floating a demanded let.
1085 = do { arg' <- simplExprC (arg_se `setInScope` env) arg
1086 (mkLazyArgStop arg_ty has_rules)
1087 ; rebuildCall env (fun `App` arg') res_ty (has_rules, strs) cont }
1089 (arg_ty, res_ty) = splitFunTy fun_ty
1091 rebuildCall env fun fun_ty info cont
1092 = rebuild env fun cont
1097 This part of the simplifier may break the no-shadowing invariant
1099 f (...(\a -> e)...) (case y of (a,b) -> e')
1100 where f is strict in its second arg
1101 If we simplify the innermost one first we get (...(\a -> e)...)
1102 Simplifying the second arg makes us float the case out, so we end up with
1103 case y of (a,b) -> f (...(\a -> e)...) e'
1104 So the output does not have the no-shadowing invariant. However, there is
1105 no danger of getting name-capture, because when the first arg was simplified
1106 we used an in-scope set that at least mentioned all the variables free in its
1107 static environment, and that is enough.
1109 We can't just do innermost first, or we'd end up with a dual problem:
1110 case x of (a,b) -> f e (...(\a -> e')...)
1112 I spent hours trying to recover the no-shadowing invariant, but I just could
1113 not think of an elegant way to do it. The simplifier is already knee-deep in
1114 continuations. We have to keep the right in-scope set around; AND we have
1115 to get the effect that finding (error "foo") in a strict arg position will
1116 discard the entire application and replace it with (error "foo"). Getting
1117 all this at once is TOO HARD!
1119 %************************************************************************
1121 Rebuilding a cse expression
1123 %************************************************************************
1125 Blob of helper functions for the "case-of-something-else" situation.
1128 ---------------------------------------------------------
1129 -- Eliminate the case if possible
1131 rebuildCase :: SimplEnv
1132 -> OutExpr -- Scrutinee
1133 -> InId -- Case binder
1134 -> [InAlt] -- Alternatives (inceasing order)
1136 -> SimplM (SimplEnv, OutExpr)
1138 --------------------------------------------------
1139 -- 1. Eliminate the case if there's a known constructor
1140 --------------------------------------------------
1142 rebuildCase env scrut case_bndr alts cont
1143 | Just (con,args) <- exprIsConApp_maybe scrut
1144 -- Works when the scrutinee is a variable with a known unfolding
1145 -- as well as when it's an explicit constructor application
1146 = knownCon env scrut (DataAlt con) args case_bndr alts cont
1148 | Lit lit <- scrut -- No need for same treatment as constructors
1149 -- because literals are inlined more vigorously
1150 = knownCon env scrut (LitAlt lit) [] case_bndr alts cont
1153 --------------------------------------------------
1154 -- 2. Eliminate the case if scrutinee is evaluated
1155 --------------------------------------------------
1157 rebuildCase env scrut case_bndr [(con,bndrs,rhs)] cont
1158 -- See if we can get rid of the case altogether
1159 -- See the extensive notes on case-elimination above
1160 -- mkCase made sure that if all the alternatives are equal,
1161 -- then there is now only one (DEFAULT) rhs
1162 | all isDeadBinder bndrs -- bndrs are [InId]
1164 -- Check that the scrutinee can be let-bound instead of case-bound
1165 , exprOkForSpeculation scrut
1166 -- OK not to evaluate it
1167 -- This includes things like (==# a# b#)::Bool
1168 -- so that we simplify
1169 -- case ==# a# b# of { True -> x; False -> x }
1172 -- This particular example shows up in default methods for
1173 -- comparision operations (e.g. in (>=) for Int.Int32)
1174 || exprIsHNF scrut -- It's already evaluated
1175 || var_demanded_later scrut -- It'll be demanded later
1177 -- || not opt_SimplPedanticBottoms) -- Or we don't care!
1178 -- We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on,
1179 -- but that breaks badly for the dataToTag# primop, which relies on a case to evaluate
1180 -- its argument: case x of { y -> dataToTag# y }
1181 -- Here we must *not* discard the case, because dataToTag# just fetches the tag from
1182 -- the info pointer. So we'll be pedantic all the time, and see if that gives any
1184 -- Also we don't want to discard 'seq's
1185 = do { tick (CaseElim case_bndr)
1186 ; env <- simplNonRecX env case_bndr scrut
1187 ; simplExprF env rhs cont }
1189 -- The case binder is going to be evaluated later,
1190 -- and the scrutinee is a simple variable
1191 var_demanded_later (Var v) = isStrictDmd (idNewDemandInfo case_bndr)
1192 && not (isTickBoxOp v)
1193 -- ugly hack; covering this case is what
1194 -- exprOkForSpeculation was intended for.
1195 var_demanded_later other = False
1198 --------------------------------------------------
1199 -- 3. Catch-all case
1200 --------------------------------------------------
1202 rebuildCase env scrut case_bndr alts cont
1203 = do { -- Prepare the continuation;
1204 -- The new subst_env is in place
1205 (env, dup_cont, nodup_cont) <- prepareCaseCont env alts cont
1207 -- Simplify the alternatives
1208 ; (scrut', case_bndr', alts') <- simplAlts env scrut case_bndr alts dup_cont
1209 ; let res_ty' = contResultType dup_cont
1210 ; case_expr <- mkCase scrut' case_bndr' res_ty' alts'
1212 -- Notice that rebuildDone returns the in-scope set from env, not alt_env
1213 -- The case binder *not* scope over the whole returned case-expression
1214 ; rebuild env case_expr nodup_cont }
1217 simplCaseBinder checks whether the scrutinee is a variable, v. If so,
1218 try to eliminate uses of v in the RHSs in favour of case_bndr; that
1219 way, there's a chance that v will now only be used once, and hence
1222 Note [no-case-of-case]
1223 ~~~~~~~~~~~~~~~~~~~~~~
1224 There is a time we *don't* want to do that, namely when
1225 -fno-case-of-case is on. This happens in the first simplifier pass,
1226 and enhances full laziness. Here's the bad case:
1227 f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )
1228 If we eliminate the inner case, we trap it inside the I# v -> arm,
1229 which might prevent some full laziness happening. I've seen this
1230 in action in spectral/cichelli/Prog.hs:
1231 [(m,n) | m <- [1..max], n <- [1..max]]
1232 Hence the check for NoCaseOfCase.
1234 Note [Suppressing the case binder-swap]
1235 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1236 There is another situation when it might make sense to suppress the
1237 case-expression binde-swap. If we have
1239 case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }
1240 ...other cases .... }
1242 We'll perform the binder-swap for the outer case, giving
1244 case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }
1245 ...other cases .... }
1247 But there is no point in doing it for the inner case, because w1 can't
1248 be inlined anyway. Furthermore, doing the case-swapping involves
1249 zapping w2's occurrence info (see paragraphs that follow), and that
1250 forces us to bind w2 when doing case merging. So we get
1252 case x of w1 { A -> let w2 = w1 in e1
1253 B -> let w2 = w1 in e2
1254 ...other cases .... }
1256 This is plain silly in the common case where w2 is dead.
1258 Even so, I can't see a good way to implement this idea. I tried
1259 not doing the binder-swap if the scrutinee was already evaluated
1260 but that failed big-time:
1264 case v of w { MkT x ->
1265 case x of x1 { I# y1 ->
1266 case x of x2 { I# y2 -> ...
1268 Notice that because MkT is strict, x is marked "evaluated". But to
1269 eliminate the last case, we must either make sure that x (as well as
1270 x1) has unfolding MkT y1. THe straightforward thing to do is to do
1271 the binder-swap. So this whole note is a no-op.
1275 If we replace the scrutinee, v, by tbe case binder, then we have to nuke
1276 any occurrence info (eg IAmDead) in the case binder, because the
1277 case-binder now effectively occurs whenever v does. AND we have to do
1278 the same for the pattern-bound variables! Example:
1280 (case x of { (a,b) -> a }) (case x of { (p,q) -> q })
1282 Here, b and p are dead. But when we move the argment inside the first
1283 case RHS, and eliminate the second case, we get
1285 case x of { (a,b) -> a b }
1287 Urk! b is alive! Reason: the scrutinee was a variable, and case elimination
1290 Indeed, this can happen anytime the case binder isn't dead:
1291 case <any> of x { (a,b) ->
1292 case x of { (p,q) -> p } }
1293 Here (a,b) both look dead, but come alive after the inner case is eliminated.
1294 The point is that we bring into the envt a binding
1296 after the outer case, and that makes (a,b) alive. At least we do unless
1297 the case binder is guaranteed dead.
1301 Consider case (v `cast` co) of x { I# ->
1302 ... (case (v `cast` co) of {...}) ...
1303 We'd like to eliminate the inner case. We can get this neatly by
1304 arranging that inside the outer case we add the unfolding
1305 v |-> x `cast` (sym co)
1306 to v. Then we should inline v at the inner case, cancel the casts, and away we go
1308 Note [Improving seq]
1311 type family F :: * -> *
1312 type instance F Int = Int
1314 ... case e of x { DEFAULT -> rhs } ...
1316 where x::F Int. Then we'd like to rewrite (F Int) to Int, getting
1318 case e `cast` co of x'::Int
1319 I# x# -> let x = x' `cast` sym co
1322 so that 'rhs' can take advantage of hte form of x'. Notice that Note
1323 [Case of cast] may then apply to the result.
1325 This showed up in Roman's experiments. Example:
1326 foo :: F Int -> Int -> Int
1327 foo t n = t `seq` bar n
1330 bar n = bar (n - case t of TI i -> i)
1331 Here we'd like to avoid repeated evaluating t inside the loop, by
1332 taking advantage of the `seq`.
1334 At one point I did transformation in LiberateCase, but it's more robust here.
1335 (Otherwise, there's a danger that we'll simply drop the 'seq' altogether, before
1336 LiberateCase gets to see it.)
1338 Note [Case elimination]
1339 ~~~~~~~~~~~~~~~~~~~~~~~
1340 The case-elimination transformation discards redundant case expressions.
1341 Start with a simple situation:
1343 case x# of ===> e[x#/y#]
1346 (when x#, y# are of primitive type, of course). We can't (in general)
1347 do this for algebraic cases, because we might turn bottom into
1350 The code in SimplUtils.prepareAlts has the effect of generalise this
1351 idea to look for a case where we're scrutinising a variable, and we
1352 know that only the default case can match. For example:
1356 DEFAULT -> ...(case x of
1360 Here the inner case is first trimmed to have only one alternative, the
1361 DEFAULT, after which it's an instance of the previous case. This
1362 really only shows up in eliminating error-checking code.
1364 We also make sure that we deal with this very common case:
1369 Here we are using the case as a strict let; if x is used only once
1370 then we want to inline it. We have to be careful that this doesn't
1371 make the program terminate when it would have diverged before, so we
1373 - e is already evaluated (it may so if e is a variable)
1374 - x is used strictly, or
1376 Lastly, the code in SimplUtils.mkCase combines identical RHSs. So
1378 case e of ===> case e of DEFAULT -> r
1382 Now again the case may be elminated by the CaseElim transformation.
1385 Further notes about case elimination
1386 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1387 Consider: test :: Integer -> IO ()
1390 Turns out that this compiles to:
1393 eta1 :: State# RealWorld ->
1394 case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->
1396 (PrelNum.jtos eta ($w[] @ Char))
1398 of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s }}
1400 Notice the strange '<' which has no effect at all. This is a funny one.
1401 It started like this:
1403 f x y = if x < 0 then jtos x
1404 else if y==0 then "" else jtos x
1406 At a particular call site we have (f v 1). So we inline to get
1408 if v < 0 then jtos x
1409 else if 1==0 then "" else jtos x
1411 Now simplify the 1==0 conditional:
1413 if v<0 then jtos v else jtos v
1415 Now common-up the two branches of the case:
1417 case (v<0) of DEFAULT -> jtos v
1419 Why don't we drop the case? Because it's strict in v. It's technically
1420 wrong to drop even unnecessary evaluations, and in practice they
1421 may be a result of 'seq' so we *definitely* don't want to drop those.
1422 I don't really know how to improve this situation.
1426 simplCaseBinder :: SimplEnv -> OutExpr -> OutId -> [InAlt]
1427 -> SimplM (SimplEnv, OutExpr, OutId)
1428 simplCaseBinder env scrut case_bndr alts
1429 = do { (env1, case_bndr1) <- simplBinder env case_bndr
1431 ; fam_envs <- getFamEnvs
1432 ; (env2, scrut2, case_bndr2) <- improve_seq fam_envs env1 scrut
1433 case_bndr case_bndr1 alts
1434 -- Note [Improving seq]
1436 ; let (env3, case_bndr3) = improve_case_bndr env2 scrut2 case_bndr2
1437 -- Note [Case of cast]
1439 ; return (env3, scrut2, case_bndr3) }
1442 improve_seq fam_envs env1 scrut case_bndr case_bndr1 [(DEFAULT,_,_)]
1443 | Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1)
1444 = do { case_bndr2 <- newId FSLIT("nt") ty2
1445 ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co)
1446 env2 = extendIdSubst env1 case_bndr rhs
1447 ; return (env2, scrut `Cast` co, case_bndr2) }
1449 improve_seq fam_envs env1 scrut case_bndr case_bndr1 alts
1450 = return (env1, scrut, case_bndr1)
1453 improve_case_bndr env scrut case_bndr
1454 | switchIsOn (getSwitchChecker env) NoCaseOfCase
1455 -- See Note [no-case-of-case]
1458 | otherwise -- Failed try [see Note 2 above]
1459 -- not (isEvaldUnfolding (idUnfolding v))
1461 Var v -> (modifyInScope env1 v case_bndr', case_bndr')
1462 -- Note about using modifyInScope for v here
1463 -- We could extend the substitution instead, but it would be
1464 -- a hack because then the substitution wouldn't be idempotent
1465 -- any more (v is an OutId). And this does just as well.
1467 Cast (Var v) co -> (addBinderUnfolding env1 v rhs, case_bndr')
1469 rhs = Cast (Var case_bndr') (mkSymCoercion co)
1471 other -> (env, case_bndr)
1473 case_bndr' = zapOccInfo case_bndr
1474 env1 = modifyInScope env case_bndr case_bndr'
1477 zapOccInfo :: InId -> InId -- See Note [zapOccInfo]
1478 zapOccInfo b = b `setIdOccInfo` NoOccInfo
1482 simplAlts does two things:
1484 1. Eliminate alternatives that cannot match, including the
1485 DEFAULT alternative.
1487 2. If the DEFAULT alternative can match only one possible constructor,
1488 then make that constructor explicit.
1490 case e of x { DEFAULT -> rhs }
1492 case e of x { (a,b) -> rhs }
1493 where the type is a single constructor type. This gives better code
1494 when rhs also scrutinises x or e.
1496 Here "cannot match" includes knowledge from GADTs
1498 It's a good idea do do this stuff before simplifying the alternatives, to
1499 avoid simplifying alternatives we know can't happen, and to come up with
1500 the list of constructors that are handled, to put into the IdInfo of the
1501 case binder, for use when simplifying the alternatives.
1503 Eliminating the default alternative in (1) isn't so obvious, but it can
1506 data Colour = Red | Green | Blue
1515 DEFAULT -> [ case y of ... ]
1517 If we inline h into f, the default case of the inlined h can't happen.
1518 If we don't notice this, we may end up filtering out *all* the cases
1519 of the inner case y, which give us nowhere to go!
1523 simplAlts :: SimplEnv
1525 -> InId -- Case binder
1526 -> [InAlt] -> SimplCont
1527 -> SimplM (OutExpr, OutId, [OutAlt]) -- Includes the continuation
1528 -- Like simplExpr, this just returns the simplified alternatives;
1529 -- it not return an environment
1531 simplAlts env scrut case_bndr alts cont'
1532 = -- pprTrace "simplAlts" (ppr alts $$ ppr (seIdSubst env)) $
1533 do { let alt_env = zapFloats env
1534 ; (alt_env, scrut', case_bndr') <- simplCaseBinder alt_env scrut case_bndr alts
1536 ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut case_bndr' alts
1538 ; alts' <- mapM (simplAlt alt_env imposs_deflt_cons case_bndr' cont') in_alts
1539 ; return (scrut', case_bndr', alts') }
1541 ------------------------------------
1542 simplAlt :: SimplEnv
1543 -> [AltCon] -- These constructors can't be present when
1544 -- matching the DEFAULT alternative
1545 -> OutId -- The case binder
1550 simplAlt env imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs)
1551 = ASSERT( null bndrs )
1552 do { let env' = addBinderOtherCon env case_bndr' imposs_deflt_cons
1553 -- Record the constructors that the case-binder *can't* be.
1554 ; rhs' <- simplExprC env' rhs cont'
1555 ; return (DEFAULT, [], rhs') }
1557 simplAlt env imposs_deflt_cons case_bndr' cont' (LitAlt lit, bndrs, rhs)
1558 = ASSERT( null bndrs )
1559 do { let env' = addBinderUnfolding env case_bndr' (Lit lit)
1560 ; rhs' <- simplExprC env' rhs cont'
1561 ; return (LitAlt lit, [], rhs') }
1563 simplAlt env imposs_deflt_cons case_bndr' cont' (DataAlt con, vs, rhs)
1564 = do { -- Deal with the pattern-bound variables
1565 (env, vs') <- simplBinders env (add_evals con vs)
1567 -- Mark the ones that are in ! positions in the
1568 -- data constructor as certainly-evaluated.
1569 ; let vs'' = add_evals con vs'
1571 -- Bind the case-binder to (con args)
1572 ; let inst_tys' = tyConAppArgs (idType case_bndr')
1573 con_args = map Type inst_tys' ++ varsToCoreExprs vs''
1574 env' = addBinderUnfolding env case_bndr' (mkConApp con con_args)
1576 ; rhs' <- simplExprC env' rhs cont'
1577 ; return (DataAlt con, vs'', rhs') }
1579 -- add_evals records the evaluated-ness of the bound variables of
1580 -- a case pattern. This is *important*. Consider
1581 -- data T = T !Int !Int
1583 -- case x of { T a b -> T (a+1) b }
1585 -- We really must record that b is already evaluated so that we don't
1586 -- go and re-evaluate it when constructing the result.
1587 -- See Note [Data-con worker strictness] in MkId.lhs
1588 add_evals dc vs = cat_evals dc vs (dataConRepStrictness dc)
1590 cat_evals dc vs strs
1594 go (v:vs) strs | isTyVar v = v : go vs strs
1595 go (v:vs) (str:strs)
1596 | isMarkedStrict str = evald_v : go vs strs
1597 | otherwise = zapped_v : go vs strs
1599 zapped_v = zap_occ_info v
1600 evald_v = zapped_v `setIdUnfolding` evaldUnfolding
1601 go _ _ = pprPanic "cat_evals" (ppr dc $$ ppr vs $$ ppr strs)
1603 -- If the case binder is alive, then we add the unfolding
1605 -- to the envt; so vs are now very much alive
1606 -- Note [Aug06] I can't see why this actually matters
1607 zap_occ_info | isDeadBinder case_bndr' = \id -> id
1608 | otherwise = zapOccInfo
1610 addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv
1611 addBinderUnfolding env bndr rhs
1612 = modifyInScope env bndr (bndr `setIdUnfolding` mkUnfolding False rhs)
1614 addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv
1615 addBinderOtherCon env bndr cons
1616 = modifyInScope env bndr (bndr `setIdUnfolding` mkOtherCon cons)
1620 %************************************************************************
1622 \subsection{Known constructor}
1624 %************************************************************************
1626 We are a bit careful with occurrence info. Here's an example
1628 (\x* -> case x of (a*, b) -> f a) (h v, e)
1630 where the * means "occurs once". This effectively becomes
1631 case (h v, e) of (a*, b) -> f a)
1633 let a* = h v; b = e in f a
1637 All this should happen in one sweep.
1640 knownCon :: SimplEnv -> OutExpr -> AltCon -> [OutExpr]
1641 -> InId -> [InAlt] -> SimplCont
1642 -> SimplM (SimplEnv, OutExpr)
1644 knownCon env scrut con args bndr alts cont
1645 = do { tick (KnownBranch bndr)
1646 ; knownAlt env scrut args bndr (findAlt con alts) cont }
1648 knownAlt env scrut args bndr (DEFAULT, bs, rhs) cont
1650 do { env <- simplNonRecX env bndr scrut
1651 -- This might give rise to a binding with non-atomic args
1652 -- like x = Node (f x) (g x)
1653 -- but simplNonRecX will atomic-ify it
1654 ; simplExprF env rhs cont }
1656 knownAlt env scrut args bndr (LitAlt lit, bs, rhs) cont
1658 do { env <- simplNonRecX env bndr scrut
1659 ; simplExprF env rhs cont }
1661 knownAlt env scrut args bndr (DataAlt dc, bs, rhs) cont
1662 = do { let dead_bndr = isDeadBinder bndr -- bndr is an InId
1663 n_drop_tys = length (dataConUnivTyVars dc)
1664 ; env <- bind_args env dead_bndr bs (drop n_drop_tys args)
1666 -- It's useful to bind bndr to scrut, rather than to a fresh
1667 -- binding x = Con arg1 .. argn
1668 -- because very often the scrut is a variable, so we avoid
1669 -- creating, and then subsequently eliminating, a let-binding
1670 -- BUT, if scrut is a not a variable, we must be careful
1671 -- about duplicating the arg redexes; in that case, make
1672 -- a new con-app from the args
1673 bndr_rhs = case scrut of
1676 con_app = mkConApp dc (take n_drop_tys args ++ con_args)
1677 con_args = [substExpr env (varToCoreExpr b) | b <- bs]
1678 -- args are aready OutExprs, but bs are InIds
1680 ; env <- simplNonRecX env bndr bndr_rhs
1681 ; -- pprTrace "knownCon2" (ppr bs $$ ppr rhs $$ ppr (seIdSubst env)) $
1682 simplExprF env rhs cont }
1685 bind_args env dead_bndr [] _ = return env
1687 bind_args env dead_bndr (b:bs) (Type ty : args)
1688 = ASSERT( isTyVar b )
1689 bind_args (extendTvSubst env b ty) dead_bndr bs args
1691 bind_args env dead_bndr (b:bs) (arg : args)
1693 do { let b' = if dead_bndr then b else zapOccInfo b
1694 -- Note that the binder might be "dead", because it doesn't occur
1695 -- in the RHS; and simplNonRecX may therefore discard it via postInlineUnconditionally
1696 -- Nevertheless we must keep it if the case-binder is alive, because it may
1697 -- be used in the con_app. See Note [zapOccInfo]
1698 ; env <- simplNonRecX env b' arg
1699 ; bind_args env dead_bndr bs args }
1702 pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr args $$
1703 text "scrut:" <+> ppr scrut
1707 %************************************************************************
1709 \subsection{Duplicating continuations}
1711 %************************************************************************
1714 prepareCaseCont :: SimplEnv
1715 -> [InAlt] -> SimplCont
1716 -> SimplM (SimplEnv, SimplCont,SimplCont)
1717 -- Return a duplicatable continuation, a non-duplicable part
1718 -- plus some extra bindings (that scope over the entire
1721 -- No need to make it duplicatable if there's only one alternative
1722 prepareCaseCont env [alt] cont = return (env, cont, mkBoringStop (contResultType cont))
1723 prepareCaseCont env alts cont = mkDupableCont env cont
1727 mkDupableCont :: SimplEnv -> SimplCont
1728 -> SimplM (SimplEnv, SimplCont, SimplCont)
1730 mkDupableCont env cont
1731 | contIsDupable cont
1732 = returnSmpl (env, cont, mkBoringStop (contResultType cont))
1734 mkDupableCont env (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn
1736 mkDupableCont env (CoerceIt ty cont)
1737 = do { (env, dup, nodup) <- mkDupableCont env cont
1738 ; return (env, CoerceIt ty dup, nodup) }
1740 mkDupableCont env cont@(StrictBind bndr _ _ se _)
1741 = return (env, mkBoringStop (substTy se (idType bndr)), cont)
1742 -- See Note [Duplicating strict continuations]
1744 mkDupableCont env cont@(StrictArg _ fun_ty _ _)
1745 = return (env, mkBoringStop (funArgTy fun_ty), cont)
1746 -- See Note [Duplicating strict continuations]
1748 mkDupableCont env (ApplyTo _ arg se cont)
1749 = -- e.g. [...hole...] (...arg...)
1751 -- let a = ...arg...
1752 -- in [...hole...] a
1753 do { (env, dup_cont, nodup_cont) <- mkDupableCont env cont
1754 ; arg <- simplExpr (se `setInScope` env) arg
1755 ; (env, arg) <- makeTrivial env arg
1756 ; let app_cont = ApplyTo OkToDup arg (zapSubstEnv env) dup_cont
1757 ; return (env, app_cont, nodup_cont) }
1759 mkDupableCont env cont@(Select _ case_bndr [(_,bs,rhs)] se case_cont)
1760 -- See Note [Single-alternative case]
1761 -- | not (exprIsDupable rhs && contIsDupable case_cont)
1762 -- | not (isDeadBinder case_bndr)
1763 | all isDeadBinder bs -- InIds
1764 = return (env, mkBoringStop scrut_ty, cont)
1766 scrut_ty = substTy se (idType case_bndr)
1768 mkDupableCont env (Select _ case_bndr alts se cont)
1769 = -- e.g. (case [...hole...] of { pi -> ei })
1771 -- let ji = \xij -> ei
1772 -- in case [...hole...] of { pi -> ji xij }
1773 do { tick (CaseOfCase case_bndr)
1774 ; (env, dup_cont, nodup_cont) <- mkDupableCont env cont
1775 -- NB: call mkDupableCont here, *not* prepareCaseCont
1776 -- We must make a duplicable continuation, whereas prepareCaseCont
1777 -- doesn't when there is a single case branch
1779 ; let alt_env = se `setInScope` env
1780 ; (alt_env, case_bndr') <- simplBinder alt_env case_bndr
1781 ; alts' <- mapM (simplAlt alt_env [] case_bndr' dup_cont) alts
1782 -- Safe to say that there are no handled-cons for the DEFAULT case
1783 -- NB: simplBinder does not zap deadness occ-info, so
1784 -- a dead case_bndr' will still advertise its deadness
1785 -- This is really important because in
1786 -- case e of b { (# p,q #) -> ... }
1787 -- b is always dead, and indeed we are not allowed to bind b to (# p,q #),
1788 -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.
1789 -- In the new alts we build, we have the new case binder, so it must retain
1791 -- NB: we don't use alt_env further; it has the substEnv for
1792 -- the alternatives, and we don't want that
1794 ; (env, alts') <- mkDupableAlts env case_bndr' alts'
1795 ; return (env, -- Note [Duplicated env]
1796 Select OkToDup case_bndr' alts' (zapSubstEnv env)
1797 (mkBoringStop (contResultType dup_cont)),
1801 mkDupableAlts :: SimplEnv -> OutId -> [InAlt]
1802 -> SimplM (SimplEnv, [InAlt])
1803 -- Absorbs the continuation into the new alternatives
1805 mkDupableAlts env case_bndr' alts
1808 go env [] = return (env, [])
1810 = do { (env, alt') <- mkDupableAlt env case_bndr' alt
1811 ; (env, alts') <- go env alts
1812 ; return (env, alt' : alts' ) }
1814 mkDupableAlt env case_bndr' (con, bndrs', rhs')
1815 | exprIsDupable rhs' -- Note [Small alternative rhs]
1816 = return (env, (con, bndrs', rhs'))
1818 = do { let rhs_ty' = exprType rhs'
1819 used_bndrs' = filter abstract_over (case_bndr' : bndrs')
1821 | isTyVar bndr = True -- Abstract over all type variables just in case
1822 | otherwise = not (isDeadBinder bndr)
1823 -- The deadness info on the new Ids is preserved by simplBinders
1825 ; (final_bndrs', final_args) -- Note [Join point abstraction]
1826 <- if (any isId used_bndrs')
1827 then return (used_bndrs', varsToCoreExprs used_bndrs')
1828 else do { rw_id <- newId FSLIT("w") realWorldStatePrimTy
1829 ; return ([rw_id], [Var realWorldPrimId]) }
1831 ; join_bndr <- newId FSLIT("$j") (mkPiTypes final_bndrs' rhs_ty')
1832 -- Note [Funky mkPiTypes]
1834 ; let -- We make the lambdas into one-shot-lambdas. The
1835 -- join point is sure to be applied at most once, and doing so
1836 -- prevents the body of the join point being floated out by
1837 -- the full laziness pass
1838 really_final_bndrs = map one_shot final_bndrs'
1839 one_shot v | isId v = setOneShotLambda v
1841 join_rhs = mkLams really_final_bndrs rhs'
1842 join_call = mkApps (Var join_bndr) final_args
1844 ; return (addNonRec env join_bndr join_rhs, (con, bndrs', join_call)) }
1845 -- See Note [Duplicated env]
1848 Note [Duplicated env]
1849 ~~~~~~~~~~~~~~~~~~~~~
1850 Some of the alternatives are simplified, but have not been turned into a join point
1851 So they *must* have an zapped subst-env. So we can't use completeNonRecX to
1852 bind the join point, because it might to do PostInlineUnconditionally, and
1853 we'd lose that when zapping the subst-env. We could have a per-alt subst-env,
1854 but zapping it (as we do in mkDupableCont, the Select case) is safe, and
1855 at worst delays the join-point inlining.
1857 Note [Small alterantive rhs]
1858 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1859 It is worth checking for a small RHS because otherwise we
1860 get extra let bindings that may cause an extra iteration of the simplifier to
1861 inline back in place. Quite often the rhs is just a variable or constructor.
1862 The Ord instance of Maybe in PrelMaybe.lhs, for example, took several extra
1863 iterations because the version with the let bindings looked big, and so wasn't
1864 inlined, but after the join points had been inlined it looked smaller, and so
1867 NB: we have to check the size of rhs', not rhs.
1868 Duplicating a small InAlt might invalidate occurrence information
1869 However, if it *is* dupable, we return the *un* simplified alternative,
1870 because otherwise we'd need to pair it up with an empty subst-env....
1871 but we only have one env shared between all the alts.
1872 (Remember we must zap the subst-env before re-simplifying something).
1873 Rather than do this we simply agree to re-simplify the original (small) thing later.
1875 Note [Funky mkPiTypes]
1876 ~~~~~~~~~~~~~~~~~~~~~~
1877 Notice the funky mkPiTypes. If the contructor has existentials
1878 it's possible that the join point will be abstracted over
1879 type varaibles as well as term variables.
1880 Example: Suppose we have
1881 data T = forall t. C [t]
1883 case (case e of ...) of
1885 We get the join point
1886 let j :: forall t. [t] -> ...
1887 j = /\t \xs::[t] -> rhs
1889 case (case e of ...) of
1890 C t xs::[t] -> j t xs
1892 Note [Join point abstaction]
1893 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1894 If we try to lift a primitive-typed something out
1895 for let-binding-purposes, we will *caseify* it (!),
1896 with potentially-disastrous strictness results. So
1897 instead we turn it into a function: \v -> e
1898 where v::State# RealWorld#. The value passed to this function
1899 is realworld#, which generates (almost) no code.
1901 There's a slight infelicity here: we pass the overall
1902 case_bndr to all the join points if it's used in *any* RHS,
1903 because we don't know its usage in each RHS separately
1905 We used to say "&& isUnLiftedType rhs_ty'" here, but now
1906 we make the join point into a function whenever used_bndrs'
1907 is empty. This makes the join-point more CPR friendly.
1908 Consider: let j = if .. then I# 3 else I# 4
1909 in case .. of { A -> j; B -> j; C -> ... }
1911 Now CPR doesn't w/w j because it's a thunk, so
1912 that means that the enclosing function can't w/w either,
1913 which is a lose. Here's the example that happened in practice:
1914 kgmod :: Int -> Int -> Int
1915 kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
1919 I have seen a case alternative like this:
1921 It's a bit silly to add the realWorld dummy arg in this case, making
1924 (the \v alone is enough to make CPR happy) but I think it's rare
1926 Note [Duplicating strict continuations]
1927 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1928 Do *not* duplicate StrictBind and StritArg continuations. We gain
1929 nothing by propagating them into the expressions, and we do lose a
1930 lot. Here's an example:
1931 && (case x of { T -> F; F -> T }) E
1932 Now, && is strict so we end up simplifying the case with
1933 an ArgOf continuation. If we let-bind it, we get
1935 let $j = \v -> && v E
1936 in simplExpr (case x of { T -> F; F -> T })
1938 And after simplifying more we get
1940 let $j = \v -> && v E
1941 in case x of { T -> $j F; F -> $j T }
1942 Which is a Very Bad Thing
1944 The desire not to duplicate is the entire reason that
1945 mkDupableCont returns a pair of continuations.
1947 The original plan had:
1948 e.g. (...strict-fn...) [...hole...]
1950 let $j = \a -> ...strict-fn...
1953 Note [Single-alternative cases]
1954 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1955 This case is just like the ArgOf case. Here's an example:
1959 case (case x of I# x' ->
1961 True -> I# (negate# x')
1962 False -> I# x') of y {
1964 Because the (case x) has only one alternative, we'll transform to
1966 case (case x' <# 0# of
1967 True -> I# (negate# x')
1968 False -> I# x') of y {
1970 But now we do *NOT* want to make a join point etc, giving
1972 let $j = \y -> MkT y
1974 True -> $j (I# (negate# x'))
1976 In this case the $j will inline again, but suppose there was a big
1977 strict computation enclosing the orginal call to MkT. Then, it won't
1978 "see" the MkT any more, because it's big and won't get duplicated.
1979 And, what is worse, nothing was gained by the case-of-case transform.
1981 When should use this case of mkDupableCont?
1982 However, matching on *any* single-alternative case is a *disaster*;
1983 e.g. case (case ....) of (a,b) -> (# a,b #)
1984 We must push the outer case into the inner one!
1987 * Match [(DEFAULT,_,_)], but in the common case of Int,
1988 the alternative-filling-in code turned the outer case into
1989 case (...) of y { I# _ -> MkT y }
1991 * Match on single alternative plus (not (isDeadBinder case_bndr))
1992 Rationale: pushing the case inwards won't eliminate the construction.
1993 But there's a risk of
1994 case (...) of y { (a,b) -> let z=(a,b) in ... }
1995 Now y looks dead, but it'll come alive again. Still, this
1996 seems like the best option at the moment.
1998 * Match on single alternative plus (all (isDeadBinder bndrs))
1999 Rationale: this is essentially seq.
2001 * Match when the rhs is *not* duplicable, and hence would lead to a
2002 join point. This catches the disaster-case above. We can test
2003 the *un-simplified* rhs, which is fine. It might get bigger or
2004 smaller after simplification; if it gets smaller, this case might
2005 fire next time round. NB also that we must test contIsDupable
2006 case_cont *btoo, because case_cont might be big!
2008 HOWEVER: I found that this version doesn't work well, because
2009 we can get let x = case (...) of { small } in ...case x...
2010 When x is inlined into its full context, we find that it was a bad
2011 idea to have pushed the outer case inside the (...) case.