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 = do { (env', rhs') <- makeTrivial env rhs
426 ; return (env', Cast rhs' co) }
429 = do { (is_val, env', rhs') <- go 0 env rhs
430 ; return (env', rhs') }
432 go n_val_args env (Cast rhs co)
433 = do { (is_val, env', rhs') <- go n_val_args env rhs
434 ; return (is_val, env', Cast rhs' co) }
435 go n_val_args env (App fun (Type ty))
436 = do { (is_val, env', rhs') <- go n_val_args env fun
437 ; return (is_val, env', App rhs' (Type ty)) }
438 go n_val_args env (App fun arg)
439 = do { (is_val, env', fun') <- go (n_val_args+1) env fun
441 True -> do { (env'', arg') <- makeTrivial env' arg
442 ; return (True, env'', App fun' arg') }
443 False -> return (False, env, App fun arg) }
444 go n_val_args env (Var fun)
445 = return (is_val, env, Var fun)
447 is_val = n_val_args > 0 -- There is at least one arg
448 -- ...and the fun a constructor or PAP
449 && (isDataConWorkId fun || n_val_args < idArity fun)
450 go n_val_args env other
451 = return (False, env, other)
455 Note [Float coercions]
456 ~~~~~~~~~~~~~~~~~~~~~~
457 When we find the binding
459 we'd like to transform it to
461 x = x `cast` co -- A trivial binding
462 There's a chance that e will be a constructor application or function, or something
463 like that, so moving the coerion to the usage site may well cancel the coersions
464 and lead to further optimisation. Example:
467 data instance T Int = T Int
469 foo :: Int -> Int -> Int
474 go n = case x of { T m -> go (n-m) }
475 -- This case should optimise
479 makeTrivial :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
480 -- Binds the expression to a variable, if it's not trivial, returning the variable
484 | otherwise -- See Note [Take care] below
485 = do { var <- newId FSLIT("a") (exprType expr)
486 ; env <- completeNonRecX env NotTopLevel NonRecursive
488 ; return (env, substExpr env (Var var)) }
492 %************************************************************************
494 \subsection{Completing a lazy binding}
496 %************************************************************************
499 * deals only with Ids, not TyVars
500 * takes an already-simplified binder and RHS
501 * is used for both recursive and non-recursive bindings
502 * is used for both top-level and non-top-level bindings
504 It does the following:
505 - tries discarding a dead binding
506 - tries PostInlineUnconditionally
507 - add unfolding [this is the only place we add an unfolding]
510 It does *not* attempt to do let-to-case. Why? Because it is used for
511 - top-level bindings (when let-to-case is impossible)
512 - many situations where the "rhs" is known to be a WHNF
513 (so let-to-case is inappropriate).
515 Nor does it do the atomic-argument thing
518 completeBind :: SimplEnv
519 -> TopLevelFlag -- Flag stuck into unfolding
520 -> InId -- Old binder
521 -> OutId -> OutExpr -- New binder and RHS
523 -- completeBind may choose to do its work
524 -- * by extending the substitution (e.g. let x = y in ...)
525 -- * or by adding to the floats in the envt
527 completeBind env top_lvl old_bndr new_bndr new_rhs
528 | postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs unfolding
529 -- Inline and discard the binding
530 = do { tick (PostInlineUnconditionally old_bndr)
531 ; -- pprTrace "postInlineUnconditionally" (ppr old_bndr <+> ppr new_bndr <+> ppr new_rhs) $
532 return (extendIdSubst env old_bndr (DoneEx new_rhs)) }
533 -- Use the substitution to make quite, quite sure that the
534 -- substitution will happen, since we are going to discard the binding
539 new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs
542 -- Add the unfolding *only* for non-loop-breakers
543 -- Making loop breakers not have an unfolding at all
544 -- means that we can avoid tests in exprIsConApp, for example.
545 -- This is important: if exprIsConApp says 'yes' for a recursive
546 -- thing, then we can get into an infinite loop
549 -- If the unfolding is a value, the demand info may
550 -- go pear-shaped, so we nuke it. Example:
552 -- case x of (p,q) -> h p q x
553 -- Here x is certainly demanded. But after we've nuked
554 -- the case, we'll get just
555 -- let x = (a,b) in h a b x
556 -- and now x is not demanded (I'm assuming h is lazy)
557 -- This really happens. Similarly
558 -- let f = \x -> e in ...f..f...
559 -- After inlining f at some of its call sites the original binding may
560 -- (for example) be no longer strictly demanded.
561 -- The solution here is a bit ad hoc...
562 info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding
563 final_info | loop_breaker = new_bndr_info
564 | isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf
565 | otherwise = info_w_unf
567 final_id = new_bndr `setIdInfo` final_info
569 -- These seqs forces the Id, and hence its IdInfo,
570 -- and hence any inner substitutions
572 -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $
573 return (addNonRec env final_id new_rhs)
575 unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs
576 loop_breaker = isNonRuleLoopBreaker occ_info
577 old_info = idInfo old_bndr
578 occ_info = occInfo old_info
583 %************************************************************************
585 \subsection[Simplify-simplExpr]{The main function: simplExpr}
587 %************************************************************************
589 The reason for this OutExprStuff stuff is that we want to float *after*
590 simplifying a RHS, not before. If we do so naively we get quadratic
591 behaviour as things float out.
593 To see why it's important to do it after, consider this (real) example:
607 a -- Can't inline a this round, cos it appears twice
611 Each of the ==> steps is a round of simplification. We'd save a
612 whole round if we float first. This can cascade. Consider
617 let f = let d1 = ..d.. in \y -> e
621 in \x -> ...(\y ->e)...
623 Only in this second round can the \y be applied, and it
624 might do the same again.
628 simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
629 simplExpr env expr = simplExprC env expr (mkBoringStop expr_ty')
631 expr_ty' = substTy env (exprType expr)
632 -- The type in the Stop continuation, expr_ty', is usually not used
633 -- It's only needed when discarding continuations after finding
634 -- a function that returns bottom.
635 -- Hence the lazy substitution
638 simplExprC :: SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr
639 -- Simplify an expression, given a continuation
640 simplExprC env expr cont
641 = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seFloats env) ) $
642 do { (env', expr') <- simplExprF (zapFloats env) expr cont
643 ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $
644 -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $
645 -- pprTrace "simplExprC ret4" (ppr (seFloats env')) $
646 return (wrapFloats env' expr') }
648 --------------------------------------------------
649 simplExprF :: SimplEnv -> InExpr -> SimplCont
650 -> SimplM (SimplEnv, OutExpr)
652 simplExprF env e cont
653 = -- pprTrace "simplExprF" (ppr e $$ ppr cont $$ ppr (seTvSubst env) $$ ppr (seIdSubst env) {- $$ ppr (seFloats env) -} ) $
654 simplExprF' env e cont
656 simplExprF' env (Var v) cont = simplVar env v cont
657 simplExprF' env (Lit lit) cont = rebuild env (Lit lit) cont
658 simplExprF' env (Note n expr) cont = simplNote env n expr cont
659 simplExprF' env (Cast body co) cont = simplCast env body co cont
660 simplExprF' env (App fun arg) cont = simplExprF env fun $
661 ApplyTo NoDup arg env cont
663 simplExprF' env expr@(Lam _ _) cont
664 = simplLam env (map zap bndrs) body cont
665 -- The main issue here is under-saturated lambdas
666 -- (\x1. \x2. e) arg1
667 -- Here x1 might have "occurs-once" occ-info, because occ-info
668 -- is computed assuming that a group of lambdas is applied
669 -- all at once. If there are too few args, we must zap the
672 n_args = countArgs cont
673 n_params = length bndrs
674 (bndrs, body) = collectBinders expr
675 zap | n_args >= n_params = \b -> b
676 | otherwise = \b -> if isTyVar b then b
678 -- NB: we count all the args incl type args
679 -- so we must count all the binders (incl type lambdas)
681 simplExprF' env (Type ty) cont
682 = ASSERT( contIsRhsOrArg cont )
683 do { ty' <- simplType env ty
684 ; rebuild env (Type ty') cont }
686 simplExprF' env (Case scrut bndr case_ty alts) cont
687 | not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
688 = -- Simplify the scrutinee with a Select continuation
689 simplExprF env scrut (Select NoDup bndr alts env cont)
692 = -- If case-of-case is off, simply simplify the case expression
693 -- in a vanilla Stop context, and rebuild the result around it
694 do { case_expr' <- simplExprC env scrut case_cont
695 ; rebuild env case_expr' cont }
697 case_cont = Select NoDup bndr alts env (mkBoringStop case_ty')
698 case_ty' = substTy env case_ty -- c.f. defn of simplExpr
700 simplExprF' env (Let (Rec pairs) body) cont
701 = do { env <- simplRecBndrs env (map fst pairs)
702 -- NB: bndrs' don't have unfoldings or rules
703 -- We add them as we go down
705 ; env <- simplRecBind env NotTopLevel pairs
706 ; simplExprF env body cont }
708 simplExprF' env (Let (NonRec bndr rhs) body) cont
709 = simplNonRecE env bndr (rhs, env) ([], body) cont
711 ---------------------------------
712 simplType :: SimplEnv -> InType -> SimplM OutType
713 -- Kept monadic just so we can do the seqType
715 = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $
716 seqType new_ty `seq` returnSmpl new_ty
718 new_ty = substTy env ty
722 %************************************************************************
724 \subsection{The main rebuilder}
726 %************************************************************************
729 rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr)
730 -- At this point the substitution in the SimplEnv should be irrelevant
731 -- only the in-scope set and floats should matter
732 rebuild env expr cont
733 = -- pprTrace "rebuild" (ppr expr $$ ppr cont $$ ppr (seFloats env)) $
735 Stop {} -> return (env, expr)
736 CoerceIt co cont -> rebuild env (mkCoerce co expr) cont
737 Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont
738 StrictArg fun ty info cont -> rebuildCall env (fun `App` expr) (funResultTy ty) info cont
739 StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr
740 ; simplLam env' bs body cont }
741 ApplyTo _ arg se cont -> do { arg' <- simplExpr (se `setInScope` env) arg
742 ; rebuild env (App expr arg') cont }
746 %************************************************************************
750 %************************************************************************
753 simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont
754 -> SimplM (SimplEnv, OutExpr)
755 simplCast env body co cont
756 = do { co' <- simplType env co
757 ; simplExprF env body (addCoerce co' cont) }
759 addCoerce co cont = add_coerce co (coercionKind co) cont
761 add_coerce co (s1, k1) cont -- co :: ty~ty
762 | s1 `coreEqType` k1 = cont -- is a no-op
764 add_coerce co1 (s1, k2) (CoerceIt co2 cont)
765 | (l1, t1) <- coercionKind co2
766 -- coerce T1 S1 (coerce S1 K1 e)
769 -- coerce T1 K1 e, otherwise
771 -- For example, in the initial form of a worker
772 -- we may find (coerce T (coerce S (\x.e))) y
773 -- and we'd like it to simplify to e[y/x] in one round
775 , s1 `coreEqType` t1 = cont -- The coerces cancel out
776 | otherwise = CoerceIt (mkTransCoercion co1 co2) cont
778 add_coerce co (s1s2, t1t2) (ApplyTo dup (Type arg_ty) arg_se cont)
779 -- (f `cast` g) ty ---> (f ty) `cast` (g @ ty)
780 -- This implements the PushT rule from the paper
781 | Just (tyvar,_) <- splitForAllTy_maybe s1s2
782 , not (isCoVar tyvar)
783 = ApplyTo dup (Type ty') (zapSubstEnv env) (addCoerce (mkInstCoercion co ty') cont)
785 ty' = substTy arg_se arg_ty
787 -- ToDo: the PushC rule is not implemented at all
789 add_coerce co (s1s2, t1t2) (ApplyTo dup arg arg_se cont)
790 | not (isTypeArg arg) -- This implements the Push rule from the paper
791 , isFunTy s1s2 -- t1t2 must be a function type, becuase it's applied
792 -- co : s1s2 :=: t1t2
793 -- (coerce (T1->T2) (S1->S2) F) E
795 -- coerce T2 S2 (F (coerce S1 T1 E))
797 -- t1t2 must be a function type, T1->T2, because it's applied
798 -- to something but s1s2 might conceivably not be
800 -- When we build the ApplyTo we can't mix the out-types
801 -- with the InExpr in the argument, so we simply substitute
802 -- to make it all consistent. It's a bit messy.
803 -- But it isn't a common case.
805 -- Example of use: Trac #995
806 = ApplyTo dup new_arg (zapSubstEnv env) (addCoerce co2 cont)
808 -- we split coercion t1->t2 :=: s1->s2 into t1 :=: s1 and
809 -- t2 :=: s2 with left and right on the curried form:
810 -- (->) t1 t2 :=: (->) s1 s2
811 [co1, co2] = decomposeCo 2 co
812 new_arg = mkCoerce (mkSymCoercion co1) arg'
813 arg' = substExpr arg_se arg
815 add_coerce co _ cont = CoerceIt co cont
819 %************************************************************************
823 %************************************************************************
826 simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont
827 -> SimplM (SimplEnv, OutExpr)
829 simplLam env [] body cont = simplExprF env body cont
831 -- Type-beta reduction
832 simplLam env (bndr:bndrs) body (ApplyTo _ (Type ty_arg) arg_se cont)
833 = ASSERT( isTyVar bndr )
834 do { tick (BetaReduction bndr)
835 ; ty_arg' <- simplType (arg_se `setInScope` env) ty_arg
836 ; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont }
838 -- Ordinary beta reduction
839 simplLam env (bndr:bndrs) body (ApplyTo _ arg arg_se cont)
840 = do { tick (BetaReduction bndr)
841 ; simplNonRecE env bndr (arg, arg_se) (bndrs, body) cont }
843 -- Not enough args, so there are real lambdas left to put in the result
844 simplLam env bndrs body cont
845 = do { (env, bndrs') <- simplLamBndrs env bndrs
846 ; body' <- simplExpr env body
847 ; new_lam <- mkLam bndrs' body'
848 ; rebuild env new_lam cont }
851 simplNonRecE :: SimplEnv
852 -> InId -- The binder
853 -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda)
854 -> ([InId], InExpr) -- Body of the let/lambda
857 -> SimplM (SimplEnv, OutExpr)
859 -- simplNonRecE is used for
860 -- * non-top-level non-recursive lets in expressions
863 -- It deals with strict bindings, via the StrictBind continuation,
864 -- which may abort the whole process
866 -- The "body" of the binding comes as a pair of ([InId],InExpr)
867 -- representing a lambda; so we recurse back to simplLam
868 -- Why? Because of the binder-occ-info-zapping done before
869 -- the call to simplLam in simplExprF (Lam ...)
871 simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
872 | preInlineUnconditionally env NotTopLevel bndr rhs
873 = do { tick (PreInlineUnconditionally bndr)
874 ; simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont }
877 = do { simplExprF (rhs_se `setFloats` env) rhs
878 (StrictBind bndr bndrs body env cont) }
881 = do { (env, bndr') <- simplNonRecBndr env bndr
882 ; env <- simplLazyBind env NotTopLevel NonRecursive bndr bndr' rhs rhs_se
883 ; simplLam env bndrs body cont }
887 %************************************************************************
891 %************************************************************************
894 -- Hack alert: we only distinguish subsumed cost centre stacks for the
895 -- purposes of inlining. All other CCCSs are mapped to currentCCS.
896 simplNote env (SCC cc) e cont
897 = do { e' <- simplExpr (setEnclosingCC env currentCCS) e
898 ; rebuild env (mkSCC cc e') cont }
900 -- See notes with SimplMonad.inlineMode
901 simplNote env InlineMe e cont
902 | Just (inside, outside) <- splitInlineCont cont -- Boring boring continuation; see notes above
903 = do { -- Don't inline inside an INLINE expression
904 e' <- simplExprC (setMode inlineMode env) e inside
905 ; rebuild env (mkInlineMe e') outside }
907 | otherwise -- Dissolve the InlineMe note if there's
908 -- an interesting context of any kind to combine with
909 -- (even a type application -- anything except Stop)
910 = simplExprF env e cont
912 simplNote env (CoreNote s) e cont
913 = simplExpr env e `thenSmpl` \ e' ->
914 rebuild env (Note (CoreNote s) e') cont
918 %************************************************************************
920 \subsection{Dealing with calls}
922 %************************************************************************
925 simplVar env var cont
926 = case substId env var of
927 DoneEx e -> simplExprF (zapSubstEnv env) e cont
928 ContEx tvs ids e -> simplExprF (setSubstEnv env tvs ids) e cont
929 DoneId var1 -> completeCall (zapSubstEnv env) var1 cont
930 -- Note [zapSubstEnv]
931 -- The template is already simplified, so don't re-substitute.
932 -- This is VITAL. Consider
934 -- let y = \z -> ...x... in
936 -- We'll clone the inner \x, adding x->x' in the id_subst
937 -- Then when we inline y, we must *not* replace x by x' in
938 -- the inlined copy!!
940 ---------------------------------------------------------
941 -- Dealing with a call site
943 completeCall env var cont
944 = do { dflags <- getDOptsSmpl
945 ; let (args,call_cont) = contArgs cont
946 -- The args are OutExprs, obtained by *lazily* substituting
947 -- in the args found in cont. These args are only examined
948 -- to limited depth (unless a rule fires). But we must do
949 -- the substitution; rule matching on un-simplified args would
952 ------------- First try rules ----------------
953 -- Do this before trying inlining. Some functions have
954 -- rules *and* are strict; in this case, we don't want to
955 -- inline the wrapper of the non-specialised thing; better
956 -- to call the specialised thing instead.
958 -- We used to use the black-listing mechanism to ensure that inlining of
959 -- the wrapper didn't occur for things that have specialisations till a
960 -- later phase, so but now we just try RULES first
962 -- Note [Self-recursive rules]
963 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
964 -- You might think that we shouldn't apply rules for a loop breaker:
965 -- doing so might give rise to an infinite loop, because a RULE is
966 -- rather like an extra equation for the function:
967 -- RULE: f (g x) y = x+y
970 -- But it's too drastic to disable rules for loop breakers.
971 -- Even the foldr/build rule would be disabled, because foldr
972 -- is recursive, and hence a loop breaker:
973 -- foldr k z (build g) = g k z
974 -- So it's up to the programmer: rules can cause divergence
976 ; let in_scope = getInScope env
977 maybe_rule = case activeRule dflags env of
978 Nothing -> Nothing -- No rules apply
979 Just act_fn -> lookupRule act_fn in_scope
981 ; case maybe_rule of {
982 Just (rule, rule_rhs) ->
983 tick (RuleFired (ru_name rule)) `thenSmpl_`
984 (if dopt Opt_D_dump_rule_firings dflags then
985 pprTrace "Rule fired" (vcat [
986 text "Rule:" <+> ftext (ru_name rule),
987 text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
988 text "After: " <+> pprCoreExpr rule_rhs,
989 text "Cont: " <+> ppr call_cont])
992 simplExprF env rule_rhs (dropArgs (ruleArity rule) cont)
993 -- The ruleArity says how many args the rule consumed
995 ; Nothing -> do -- No rules
997 ------------- Next try inlining ----------------
998 { let arg_infos = [interestingArg arg | arg <- args, isValArg arg]
999 n_val_args = length arg_infos
1000 interesting_cont = interestingCallContext (notNull args)
1003 active_inline = activeInline env var
1004 maybe_inline = callSiteInline dflags active_inline
1005 var arg_infos interesting_cont
1006 ; case maybe_inline of {
1007 Just unfolding -- There is an inlining!
1008 -> do { tick (UnfoldingDone var)
1009 ; (if dopt Opt_D_dump_inlinings dflags then
1010 pprTrace "Inlining done" (vcat [
1011 text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
1012 text "Inlined fn: " <+> nest 2 (ppr unfolding),
1013 text "Cont: " <+> ppr call_cont])
1016 simplExprF env unfolding cont }
1018 ; Nothing -> -- No inlining!
1020 ------------- No inlining! ----------------
1021 -- Next, look for rules or specialisations that match
1023 rebuildCall env (Var var) (idType var)
1024 (mkArgInfo var n_val_args call_cont) cont
1027 rebuildCall :: SimplEnv
1028 -> OutExpr -> OutType -- Function and its type
1029 -> (Bool, [Bool]) -- See SimplUtils.mkArgInfo
1031 -> SimplM (SimplEnv, OutExpr)
1032 rebuildCall env fun fun_ty (has_rules, []) cont
1033 -- When we run out of strictness args, it means
1034 -- that the call is definitely bottom; see SimplUtils.mkArgInfo
1035 -- Then we want to discard the entire strict continuation. E.g.
1036 -- * case (error "hello") of { ... }
1037 -- * (error "Hello") arg
1038 -- * f (error "Hello") where f is strict
1040 -- Then, especially in the first of these cases, we'd like to discard
1041 -- the continuation, leaving just the bottoming expression. But the
1042 -- type might not be right, so we may have to add a coerce.
1043 | not (contIsTrivial cont) -- Only do this if there is a non-trivial
1044 = return (env, mk_coerce fun) -- contination to discard, else we do it
1045 where -- again and again!
1046 cont_ty = contResultType cont
1047 co = mkUnsafeCoercion fun_ty cont_ty
1048 mk_coerce expr | cont_ty `coreEqType` fun_ty = fun
1049 | otherwise = mkCoerce co fun
1051 rebuildCall env fun fun_ty info (ApplyTo _ (Type arg_ty) se cont)
1052 = do { ty' <- simplType (se `setInScope` env) arg_ty
1053 ; rebuildCall env (fun `App` Type ty') (applyTy fun_ty ty') info cont }
1055 rebuildCall env fun fun_ty (has_rules, str:strs) (ApplyTo _ arg arg_se cont)
1056 | str || isStrictType arg_ty -- Strict argument
1057 = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
1058 simplExprF (arg_se `setFloats` env) arg
1059 (StrictArg fun fun_ty (has_rules, strs) cont)
1062 | otherwise -- Lazy argument
1063 -- DO NOT float anything outside, hence simplExprC
1064 -- There is no benefit (unlike in a let-binding), and we'd
1065 -- have to be very careful about bogus strictness through
1066 -- floating a demanded let.
1067 = do { arg' <- simplExprC (arg_se `setInScope` env) arg
1068 (mkLazyArgStop arg_ty has_rules)
1069 ; rebuildCall env (fun `App` arg') res_ty (has_rules, strs) cont }
1071 (arg_ty, res_ty) = splitFunTy fun_ty
1073 rebuildCall env fun fun_ty info cont
1074 = rebuild env fun cont
1079 This part of the simplifier may break the no-shadowing invariant
1081 f (...(\a -> e)...) (case y of (a,b) -> e')
1082 where f is strict in its second arg
1083 If we simplify the innermost one first we get (...(\a -> e)...)
1084 Simplifying the second arg makes us float the case out, so we end up with
1085 case y of (a,b) -> f (...(\a -> e)...) e'
1086 So the output does not have the no-shadowing invariant. However, there is
1087 no danger of getting name-capture, because when the first arg was simplified
1088 we used an in-scope set that at least mentioned all the variables free in its
1089 static environment, and that is enough.
1091 We can't just do innermost first, or we'd end up with a dual problem:
1092 case x of (a,b) -> f e (...(\a -> e')...)
1094 I spent hours trying to recover the no-shadowing invariant, but I just could
1095 not think of an elegant way to do it. The simplifier is already knee-deep in
1096 continuations. We have to keep the right in-scope set around; AND we have
1097 to get the effect that finding (error "foo") in a strict arg position will
1098 discard the entire application and replace it with (error "foo"). Getting
1099 all this at once is TOO HARD!
1101 %************************************************************************
1103 Rebuilding a cse expression
1105 %************************************************************************
1107 Blob of helper functions for the "case-of-something-else" situation.
1110 ---------------------------------------------------------
1111 -- Eliminate the case if possible
1113 rebuildCase :: SimplEnv
1114 -> OutExpr -- Scrutinee
1115 -> InId -- Case binder
1116 -> [InAlt] -- Alternatives (inceasing order)
1118 -> SimplM (SimplEnv, OutExpr)
1120 --------------------------------------------------
1121 -- 1. Eliminate the case if there's a known constructor
1122 --------------------------------------------------
1124 rebuildCase env scrut case_bndr alts cont
1125 | Just (con,args) <- exprIsConApp_maybe scrut
1126 -- Works when the scrutinee is a variable with a known unfolding
1127 -- as well as when it's an explicit constructor application
1128 = knownCon env scrut (DataAlt con) args case_bndr alts cont
1130 | Lit lit <- scrut -- No need for same treatment as constructors
1131 -- because literals are inlined more vigorously
1132 = knownCon env scrut (LitAlt lit) [] case_bndr alts cont
1135 --------------------------------------------------
1136 -- 2. Eliminate the case if scrutinee is evaluated
1137 --------------------------------------------------
1139 rebuildCase env scrut case_bndr [(con,bndrs,rhs)] cont
1140 -- See if we can get rid of the case altogether
1141 -- See the extensive notes on case-elimination above
1142 -- mkCase made sure that if all the alternatives are equal,
1143 -- then there is now only one (DEFAULT) rhs
1144 | all isDeadBinder bndrs -- bndrs are [InId]
1146 -- Check that the scrutinee can be let-bound instead of case-bound
1147 , exprOkForSpeculation scrut
1148 -- OK not to evaluate it
1149 -- This includes things like (==# a# b#)::Bool
1150 -- so that we simplify
1151 -- case ==# a# b# of { True -> x; False -> x }
1154 -- This particular example shows up in default methods for
1155 -- comparision operations (e.g. in (>=) for Int.Int32)
1156 || exprIsHNF scrut -- It's already evaluated
1157 || var_demanded_later scrut -- It'll be demanded later
1159 -- || not opt_SimplPedanticBottoms) -- Or we don't care!
1160 -- We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on,
1161 -- but that breaks badly for the dataToTag# primop, which relies on a case to evaluate
1162 -- its argument: case x of { y -> dataToTag# y }
1163 -- Here we must *not* discard the case, because dataToTag# just fetches the tag from
1164 -- the info pointer. So we'll be pedantic all the time, and see if that gives any
1166 -- Also we don't want to discard 'seq's
1167 = do { tick (CaseElim case_bndr)
1168 ; env <- simplNonRecX env case_bndr scrut
1169 ; simplExprF env rhs cont }
1171 -- The case binder is going to be evaluated later,
1172 -- and the scrutinee is a simple variable
1173 var_demanded_later (Var v) = isStrictDmd (idNewDemandInfo case_bndr)
1174 && not (isTickBoxOp v)
1175 -- ugly hack; covering this case is what
1176 -- exprOkForSpeculation was intended for.
1177 var_demanded_later other = False
1180 --------------------------------------------------
1181 -- 3. Catch-all case
1182 --------------------------------------------------
1184 rebuildCase env scrut case_bndr alts cont
1185 = do { -- Prepare the continuation;
1186 -- The new subst_env is in place
1187 (env, dup_cont, nodup_cont) <- prepareCaseCont env alts cont
1189 -- Simplify the alternatives
1190 ; (scrut', case_bndr', alts') <- simplAlts env scrut case_bndr alts dup_cont
1191 ; let res_ty' = contResultType dup_cont
1192 ; case_expr <- mkCase scrut' case_bndr' res_ty' alts'
1194 -- Notice that rebuildDone returns the in-scope set from env, not alt_env
1195 -- The case binder *not* scope over the whole returned case-expression
1196 ; rebuild env case_expr nodup_cont }
1199 simplCaseBinder checks whether the scrutinee is a variable, v. If so,
1200 try to eliminate uses of v in the RHSs in favour of case_bndr; that
1201 way, there's a chance that v will now only be used once, and hence
1204 Note [no-case-of-case]
1205 ~~~~~~~~~~~~~~~~~~~~~~
1206 There is a time we *don't* want to do that, namely when
1207 -fno-case-of-case is on. This happens in the first simplifier pass,
1208 and enhances full laziness. Here's the bad case:
1209 f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )
1210 If we eliminate the inner case, we trap it inside the I# v -> arm,
1211 which might prevent some full laziness happening. I've seen this
1212 in action in spectral/cichelli/Prog.hs:
1213 [(m,n) | m <- [1..max], n <- [1..max]]
1214 Hence the check for NoCaseOfCase.
1216 Note [Suppressing the case binder-swap]
1217 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1218 There is another situation when it might make sense to suppress the
1219 case-expression binde-swap. If we have
1221 case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }
1222 ...other cases .... }
1224 We'll perform the binder-swap for the outer case, giving
1226 case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }
1227 ...other cases .... }
1229 But there is no point in doing it for the inner case, because w1 can't
1230 be inlined anyway. Furthermore, doing the case-swapping involves
1231 zapping w2's occurrence info (see paragraphs that follow), and that
1232 forces us to bind w2 when doing case merging. So we get
1234 case x of w1 { A -> let w2 = w1 in e1
1235 B -> let w2 = w1 in e2
1236 ...other cases .... }
1238 This is plain silly in the common case where w2 is dead.
1240 Even so, I can't see a good way to implement this idea. I tried
1241 not doing the binder-swap if the scrutinee was already evaluated
1242 but that failed big-time:
1246 case v of w { MkT x ->
1247 case x of x1 { I# y1 ->
1248 case x of x2 { I# y2 -> ...
1250 Notice that because MkT is strict, x is marked "evaluated". But to
1251 eliminate the last case, we must either make sure that x (as well as
1252 x1) has unfolding MkT y1. THe straightforward thing to do is to do
1253 the binder-swap. So this whole note is a no-op.
1257 If we replace the scrutinee, v, by tbe case binder, then we have to nuke
1258 any occurrence info (eg IAmDead) in the case binder, because the
1259 case-binder now effectively occurs whenever v does. AND we have to do
1260 the same for the pattern-bound variables! Example:
1262 (case x of { (a,b) -> a }) (case x of { (p,q) -> q })
1264 Here, b and p are dead. But when we move the argment inside the first
1265 case RHS, and eliminate the second case, we get
1267 case x of { (a,b) -> a b }
1269 Urk! b is alive! Reason: the scrutinee was a variable, and case elimination
1272 Indeed, this can happen anytime the case binder isn't dead:
1273 case <any> of x { (a,b) ->
1274 case x of { (p,q) -> p } }
1275 Here (a,b) both look dead, but come alive after the inner case is eliminated.
1276 The point is that we bring into the envt a binding
1278 after the outer case, and that makes (a,b) alive. At least we do unless
1279 the case binder is guaranteed dead.
1283 Consider case (v `cast` co) of x { I# ->
1284 ... (case (v `cast` co) of {...}) ...
1285 We'd like to eliminate the inner case. We can get this neatly by
1286 arranging that inside the outer case we add the unfolding
1287 v |-> x `cast` (sym co)
1288 to v. Then we should inline v at the inner case, cancel the casts, and away we go
1290 Note [Improving seq]
1293 type family F :: * -> *
1294 type instance F Int = Int
1296 ... case e of x { DEFAULT -> rhs } ...
1298 where x::F Int. Then we'd like to rewrite (F Int) to Int, getting
1300 case e `cast` co of x'::Int
1301 I# x# -> let x = x' `cast` sym co
1304 so that 'rhs' can take advantage of hte form of x'. Notice that Note
1305 [Case of cast] may then apply to the result.
1307 This showed up in Roman's experiments. Example:
1308 foo :: F Int -> Int -> Int
1309 foo t n = t `seq` bar n
1312 bar n = bar (n - case t of TI i -> i)
1313 Here we'd like to avoid repeated evaluating t inside the loop, by
1314 taking advantage of the `seq`.
1316 At one point I did transformation in LiberateCase, but it's more robust here.
1317 (Otherwise, there's a danger that we'll simply drop the 'seq' altogether, before
1318 LiberateCase gets to see it.)
1320 Note [Case elimination]
1321 ~~~~~~~~~~~~~~~~~~~~~~~
1322 The case-elimination transformation discards redundant case expressions.
1323 Start with a simple situation:
1325 case x# of ===> e[x#/y#]
1328 (when x#, y# are of primitive type, of course). We can't (in general)
1329 do this for algebraic cases, because we might turn bottom into
1332 The code in SimplUtils.prepareAlts has the effect of generalise this
1333 idea to look for a case where we're scrutinising a variable, and we
1334 know that only the default case can match. For example:
1338 DEFAULT -> ...(case x of
1342 Here the inner case is first trimmed to have only one alternative, the
1343 DEFAULT, after which it's an instance of the previous case. This
1344 really only shows up in eliminating error-checking code.
1346 We also make sure that we deal with this very common case:
1351 Here we are using the case as a strict let; if x is used only once
1352 then we want to inline it. We have to be careful that this doesn't
1353 make the program terminate when it would have diverged before, so we
1355 - e is already evaluated (it may so if e is a variable)
1356 - x is used strictly, or
1358 Lastly, the code in SimplUtils.mkCase combines identical RHSs. So
1360 case e of ===> case e of DEFAULT -> r
1364 Now again the case may be elminated by the CaseElim transformation.
1367 Further notes about case elimination
1368 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1369 Consider: test :: Integer -> IO ()
1372 Turns out that this compiles to:
1375 eta1 :: State# RealWorld ->
1376 case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->
1378 (PrelNum.jtos eta ($w[] @ Char))
1380 of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s }}
1382 Notice the strange '<' which has no effect at all. This is a funny one.
1383 It started like this:
1385 f x y = if x < 0 then jtos x
1386 else if y==0 then "" else jtos x
1388 At a particular call site we have (f v 1). So we inline to get
1390 if v < 0 then jtos x
1391 else if 1==0 then "" else jtos x
1393 Now simplify the 1==0 conditional:
1395 if v<0 then jtos v else jtos v
1397 Now common-up the two branches of the case:
1399 case (v<0) of DEFAULT -> jtos v
1401 Why don't we drop the case? Because it's strict in v. It's technically
1402 wrong to drop even unnecessary evaluations, and in practice they
1403 may be a result of 'seq' so we *definitely* don't want to drop those.
1404 I don't really know how to improve this situation.
1408 simplCaseBinder :: SimplEnv -> OutExpr -> OutId -> [InAlt]
1409 -> SimplM (SimplEnv, OutExpr, OutId)
1410 simplCaseBinder env scrut case_bndr alts
1411 = do { (env1, case_bndr1) <- simplBinder env case_bndr
1413 ; fam_envs <- getFamEnvs
1414 ; (env2, scrut2, case_bndr2) <- improve_seq fam_envs env1 scrut
1415 case_bndr case_bndr1 alts
1416 -- Note [Improving seq]
1418 ; let (env3, case_bndr3) = improve_case_bndr env2 scrut2 case_bndr2
1419 -- Note [Case of cast]
1421 ; return (env3, scrut2, case_bndr3) }
1424 improve_seq fam_envs env1 scrut case_bndr case_bndr1 [(DEFAULT,_,_)]
1425 | Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1)
1426 = do { case_bndr2 <- newId FSLIT("nt") ty2
1427 ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co)
1428 env2 = extendIdSubst env1 case_bndr rhs
1429 ; return (env2, scrut `Cast` co, case_bndr2) }
1431 improve_seq fam_envs env1 scrut case_bndr case_bndr1 alts
1432 = return (env1, scrut, case_bndr1)
1435 improve_case_bndr env scrut case_bndr
1436 | switchIsOn (getSwitchChecker env) NoCaseOfCase
1437 -- See Note [no-case-of-case]
1440 | otherwise -- Failed try [see Note 2 above]
1441 -- not (isEvaldUnfolding (idUnfolding v))
1443 Var v -> (modifyInScope env1 v case_bndr', case_bndr')
1444 -- Note about using modifyInScope for v here
1445 -- We could extend the substitution instead, but it would be
1446 -- a hack because then the substitution wouldn't be idempotent
1447 -- any more (v is an OutId). And this does just as well.
1449 Cast (Var v) co -> (addBinderUnfolding env1 v rhs, case_bndr')
1451 rhs = Cast (Var case_bndr') (mkSymCoercion co)
1453 other -> (env, case_bndr)
1455 case_bndr' = zapOccInfo case_bndr
1456 env1 = modifyInScope env case_bndr case_bndr'
1459 zapOccInfo :: InId -> InId -- See Note [zapOccInfo]
1460 zapOccInfo b = b `setIdOccInfo` NoOccInfo
1464 simplAlts does two things:
1466 1. Eliminate alternatives that cannot match, including the
1467 DEFAULT alternative.
1469 2. If the DEFAULT alternative can match only one possible constructor,
1470 then make that constructor explicit.
1472 case e of x { DEFAULT -> rhs }
1474 case e of x { (a,b) -> rhs }
1475 where the type is a single constructor type. This gives better code
1476 when rhs also scrutinises x or e.
1478 Here "cannot match" includes knowledge from GADTs
1480 It's a good idea do do this stuff before simplifying the alternatives, to
1481 avoid simplifying alternatives we know can't happen, and to come up with
1482 the list of constructors that are handled, to put into the IdInfo of the
1483 case binder, for use when simplifying the alternatives.
1485 Eliminating the default alternative in (1) isn't so obvious, but it can
1488 data Colour = Red | Green | Blue
1497 DEFAULT -> [ case y of ... ]
1499 If we inline h into f, the default case of the inlined h can't happen.
1500 If we don't notice this, we may end up filtering out *all* the cases
1501 of the inner case y, which give us nowhere to go!
1505 simplAlts :: SimplEnv
1507 -> InId -- Case binder
1508 -> [InAlt] -> SimplCont
1509 -> SimplM (OutExpr, OutId, [OutAlt]) -- Includes the continuation
1510 -- Like simplExpr, this just returns the simplified alternatives;
1511 -- it not return an environment
1513 simplAlts env scrut case_bndr alts cont'
1514 = -- pprTrace "simplAlts" (ppr alts $$ ppr (seIdSubst env)) $
1515 do { let alt_env = zapFloats env
1516 ; (alt_env, scrut', case_bndr') <- simplCaseBinder alt_env scrut case_bndr alts
1518 ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut case_bndr' alts
1520 ; alts' <- mapM (simplAlt alt_env imposs_deflt_cons case_bndr' cont') in_alts
1521 ; return (scrut', case_bndr', alts') }
1523 ------------------------------------
1524 simplAlt :: SimplEnv
1525 -> [AltCon] -- These constructors can't be present when
1526 -- matching the DEFAULT alternative
1527 -> OutId -- The case binder
1532 simplAlt env imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs)
1533 = ASSERT( null bndrs )
1534 do { let env' = addBinderOtherCon env case_bndr' imposs_deflt_cons
1535 -- Record the constructors that the case-binder *can't* be.
1536 ; rhs' <- simplExprC env' rhs cont'
1537 ; return (DEFAULT, [], rhs') }
1539 simplAlt env imposs_deflt_cons case_bndr' cont' (LitAlt lit, bndrs, rhs)
1540 = ASSERT( null bndrs )
1541 do { let env' = addBinderUnfolding env case_bndr' (Lit lit)
1542 ; rhs' <- simplExprC env' rhs cont'
1543 ; return (LitAlt lit, [], rhs') }
1545 simplAlt env imposs_deflt_cons case_bndr' cont' (DataAlt con, vs, rhs)
1546 = do { -- Deal with the pattern-bound variables
1547 (env, vs') <- simplBinders env (add_evals con vs)
1549 -- Mark the ones that are in ! positions in the
1550 -- data constructor as certainly-evaluated.
1551 ; let vs'' = add_evals con vs'
1553 -- Bind the case-binder to (con args)
1554 ; let inst_tys' = tyConAppArgs (idType case_bndr')
1555 con_args = map Type inst_tys' ++ varsToCoreExprs vs''
1556 env' = addBinderUnfolding env case_bndr' (mkConApp con con_args)
1558 ; rhs' <- simplExprC env' rhs cont'
1559 ; return (DataAlt con, vs'', rhs') }
1561 -- add_evals records the evaluated-ness of the bound variables of
1562 -- a case pattern. This is *important*. Consider
1563 -- data T = T !Int !Int
1565 -- case x of { T a b -> T (a+1) b }
1567 -- We really must record that b is already evaluated so that we don't
1568 -- go and re-evaluate it when constructing the result.
1569 -- See Note [Data-con worker strictness] in MkId.lhs
1570 add_evals dc vs = cat_evals dc vs (dataConRepStrictness dc)
1572 cat_evals dc vs strs
1576 go (v:vs) strs | isTyVar v = v : go vs strs
1577 go (v:vs) (str:strs)
1578 | isMarkedStrict str = evald_v : go vs strs
1579 | otherwise = zapped_v : go vs strs
1581 zapped_v = zap_occ_info v
1582 evald_v = zapped_v `setIdUnfolding` evaldUnfolding
1583 go _ _ = pprPanic "cat_evals" (ppr dc $$ ppr vs $$ ppr strs)
1585 -- If the case binder is alive, then we add the unfolding
1587 -- to the envt; so vs are now very much alive
1588 -- Note [Aug06] I can't see why this actually matters
1589 zap_occ_info | isDeadBinder case_bndr' = \id -> id
1590 | otherwise = zapOccInfo
1592 addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv
1593 addBinderUnfolding env bndr rhs
1594 = modifyInScope env bndr (bndr `setIdUnfolding` mkUnfolding False rhs)
1596 addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv
1597 addBinderOtherCon env bndr cons
1598 = modifyInScope env bndr (bndr `setIdUnfolding` mkOtherCon cons)
1602 %************************************************************************
1604 \subsection{Known constructor}
1606 %************************************************************************
1608 We are a bit careful with occurrence info. Here's an example
1610 (\x* -> case x of (a*, b) -> f a) (h v, e)
1612 where the * means "occurs once". This effectively becomes
1613 case (h v, e) of (a*, b) -> f a)
1615 let a* = h v; b = e in f a
1619 All this should happen in one sweep.
1622 knownCon :: SimplEnv -> OutExpr -> AltCon -> [OutExpr]
1623 -> InId -> [InAlt] -> SimplCont
1624 -> SimplM (SimplEnv, OutExpr)
1626 knownCon env scrut con args bndr alts cont
1627 = do { tick (KnownBranch bndr)
1628 ; knownAlt env scrut args bndr (findAlt con alts) cont }
1630 knownAlt env scrut args bndr (DEFAULT, bs, rhs) cont
1632 do { env <- simplNonRecX env bndr scrut
1633 -- This might give rise to a binding with non-atomic args
1634 -- like x = Node (f x) (g x)
1635 -- but simplNonRecX will atomic-ify it
1636 ; simplExprF env rhs cont }
1638 knownAlt env scrut args bndr (LitAlt lit, bs, rhs) cont
1640 do { env <- simplNonRecX env bndr scrut
1641 ; simplExprF env rhs cont }
1643 knownAlt env scrut args bndr (DataAlt dc, bs, rhs) cont
1644 = do { let dead_bndr = isDeadBinder bndr -- bndr is an InId
1645 n_drop_tys = length (dataConUnivTyVars dc)
1646 ; env <- bind_args env dead_bndr bs (drop n_drop_tys args)
1648 -- It's useful to bind bndr to scrut, rather than to a fresh
1649 -- binding x = Con arg1 .. argn
1650 -- because very often the scrut is a variable, so we avoid
1651 -- creating, and then subsequently eliminating, a let-binding
1652 -- BUT, if scrut is a not a variable, we must be careful
1653 -- about duplicating the arg redexes; in that case, make
1654 -- a new con-app from the args
1655 bndr_rhs = case scrut of
1658 con_app = mkConApp dc (take n_drop_tys args ++ con_args)
1659 con_args = [substExpr env (varToCoreExpr b) | b <- bs]
1660 -- args are aready OutExprs, but bs are InIds
1662 ; env <- simplNonRecX env bndr bndr_rhs
1663 ; -- pprTrace "knownCon2" (ppr bs $$ ppr rhs $$ ppr (seIdSubst env)) $
1664 simplExprF env rhs cont }
1667 bind_args env dead_bndr [] _ = return env
1669 bind_args env dead_bndr (b:bs) (Type ty : args)
1670 = ASSERT( isTyVar b )
1671 bind_args (extendTvSubst env b ty) dead_bndr bs args
1673 bind_args env dead_bndr (b:bs) (arg : args)
1675 do { let b' = if dead_bndr then b else zapOccInfo b
1676 -- Note that the binder might be "dead", because it doesn't occur
1677 -- in the RHS; and simplNonRecX may therefore discard it via postInlineUnconditionally
1678 -- Nevertheless we must keep it if the case-binder is alive, because it may
1679 -- be used in the con_app. See Note [zapOccInfo]
1680 ; env <- simplNonRecX env b' arg
1681 ; bind_args env dead_bndr bs args }
1683 bind_args _ _ _ _ = panic "bind_args"
1687 %************************************************************************
1689 \subsection{Duplicating continuations}
1691 %************************************************************************
1694 prepareCaseCont :: SimplEnv
1695 -> [InAlt] -> SimplCont
1696 -> SimplM (SimplEnv, SimplCont,SimplCont)
1697 -- Return a duplicatable continuation, a non-duplicable part
1698 -- plus some extra bindings (that scope over the entire
1701 -- No need to make it duplicatable if there's only one alternative
1702 prepareCaseCont env [alt] cont = return (env, cont, mkBoringStop (contResultType cont))
1703 prepareCaseCont env alts cont = mkDupableCont env cont
1707 mkDupableCont :: SimplEnv -> SimplCont
1708 -> SimplM (SimplEnv, SimplCont, SimplCont)
1710 mkDupableCont env cont
1711 | contIsDupable cont
1712 = returnSmpl (env, cont, mkBoringStop (contResultType cont))
1714 mkDupableCont env (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn
1716 mkDupableCont env (CoerceIt ty cont)
1717 = do { (env, dup, nodup) <- mkDupableCont env cont
1718 ; return (env, CoerceIt ty dup, nodup) }
1720 mkDupableCont env cont@(StrictBind bndr _ _ se _)
1721 = return (env, mkBoringStop (substTy se (idType bndr)), cont)
1722 -- See Note [Duplicating strict continuations]
1724 mkDupableCont env cont@(StrictArg _ fun_ty _ _)
1725 = return (env, mkBoringStop (funArgTy fun_ty), cont)
1726 -- See Note [Duplicating strict continuations]
1728 mkDupableCont env (ApplyTo _ arg se cont)
1729 = -- e.g. [...hole...] (...arg...)
1731 -- let a = ...arg...
1732 -- in [...hole...] a
1733 do { (env, dup_cont, nodup_cont) <- mkDupableCont env cont
1734 ; arg <- simplExpr (se `setInScope` env) arg
1735 ; (env, arg) <- makeTrivial env arg
1736 ; let app_cont = ApplyTo OkToDup arg (zapSubstEnv env) dup_cont
1737 ; return (env, app_cont, nodup_cont) }
1739 mkDupableCont env cont@(Select _ case_bndr [(_,bs,rhs)] se case_cont)
1740 -- See Note [Single-alternative case]
1741 -- | not (exprIsDupable rhs && contIsDupable case_cont)
1742 -- | not (isDeadBinder case_bndr)
1743 | all isDeadBinder bs -- InIds
1744 = return (env, mkBoringStop scrut_ty, cont)
1746 scrut_ty = substTy se (idType case_bndr)
1748 mkDupableCont env (Select _ case_bndr alts se cont)
1749 = -- e.g. (case [...hole...] of { pi -> ei })
1751 -- let ji = \xij -> ei
1752 -- in case [...hole...] of { pi -> ji xij }
1753 do { tick (CaseOfCase case_bndr)
1754 ; (env, dup_cont, nodup_cont) <- mkDupableCont env cont
1755 -- NB: call mkDupableCont here, *not* prepareCaseCont
1756 -- We must make a duplicable continuation, whereas prepareCaseCont
1757 -- doesn't when there is a single case branch
1759 ; let alt_env = se `setInScope` env
1760 ; (alt_env, case_bndr') <- simplBinder alt_env case_bndr
1761 ; alts' <- mapM (simplAlt alt_env [] case_bndr' dup_cont) alts
1762 -- Safe to say that there are no handled-cons for the DEFAULT case
1763 -- NB: simplBinder does not zap deadness occ-info, so
1764 -- a dead case_bndr' will still advertise its deadness
1765 -- This is really important because in
1766 -- case e of b { (# p,q #) -> ... }
1767 -- b is always dead, and indeed we are not allowed to bind b to (# p,q #),
1768 -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.
1769 -- In the new alts we build, we have the new case binder, so it must retain
1771 -- NB: we don't use alt_env further; it has the substEnv for
1772 -- the alternatives, and we don't want that
1774 ; (env, alts') <- mkDupableAlts env case_bndr' alts'
1775 ; return (env, -- Note [Duplicated env]
1776 Select OkToDup case_bndr' alts' (zapSubstEnv env)
1777 (mkBoringStop (contResultType dup_cont)),
1781 mkDupableAlts :: SimplEnv -> OutId -> [InAlt]
1782 -> SimplM (SimplEnv, [InAlt])
1783 -- Absorbs the continuation into the new alternatives
1785 mkDupableAlts env case_bndr' alts
1788 go env [] = return (env, [])
1790 = do { (env, alt') <- mkDupableAlt env case_bndr' alt
1791 ; (env, alts') <- go env alts
1792 ; return (env, alt' : alts' ) }
1794 mkDupableAlt env case_bndr' (con, bndrs', rhs')
1795 | exprIsDupable rhs' -- Note [Small alternative rhs]
1796 = return (env, (con, bndrs', rhs'))
1798 = do { let rhs_ty' = exprType rhs'
1799 used_bndrs' = filter abstract_over (case_bndr' : bndrs')
1801 | isTyVar bndr = True -- Abstract over all type variables just in case
1802 | otherwise = not (isDeadBinder bndr)
1803 -- The deadness info on the new Ids is preserved by simplBinders
1805 ; (final_bndrs', final_args) -- Note [Join point abstraction]
1806 <- if (any isId used_bndrs')
1807 then return (used_bndrs', varsToCoreExprs used_bndrs')
1808 else do { rw_id <- newId FSLIT("w") realWorldStatePrimTy
1809 ; return ([rw_id], [Var realWorldPrimId]) }
1811 ; join_bndr <- newId FSLIT("$j") (mkPiTypes final_bndrs' rhs_ty')
1812 -- Note [Funky mkPiTypes]
1814 ; let -- We make the lambdas into one-shot-lambdas. The
1815 -- join point is sure to be applied at most once, and doing so
1816 -- prevents the body of the join point being floated out by
1817 -- the full laziness pass
1818 really_final_bndrs = map one_shot final_bndrs'
1819 one_shot v | isId v = setOneShotLambda v
1821 join_rhs = mkLams really_final_bndrs rhs'
1822 join_call = mkApps (Var join_bndr) final_args
1824 ; return (addNonRec env join_bndr join_rhs, (con, bndrs', join_call)) }
1825 -- See Note [Duplicated env]
1828 Note [Duplicated env]
1829 ~~~~~~~~~~~~~~~~~~~~~
1830 Some of the alternatives are simplified, but have not been turned into a join point
1831 So they *must* have an zapped subst-env. So we can't use completeNonRecX to
1832 bind the join point, because it might to do PostInlineUnconditionally, and
1833 we'd lose that when zapping the subst-env. We could have a per-alt subst-env,
1834 but zapping it (as we do in mkDupableCont, the Select case) is safe, and
1835 at worst delays the join-point inlining.
1837 Note [Small alterantive rhs]
1838 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1839 It is worth checking for a small RHS because otherwise we
1840 get extra let bindings that may cause an extra iteration of the simplifier to
1841 inline back in place. Quite often the rhs is just a variable or constructor.
1842 The Ord instance of Maybe in PrelMaybe.lhs, for example, took several extra
1843 iterations because the version with the let bindings looked big, and so wasn't
1844 inlined, but after the join points had been inlined it looked smaller, and so
1847 NB: we have to check the size of rhs', not rhs.
1848 Duplicating a small InAlt might invalidate occurrence information
1849 However, if it *is* dupable, we return the *un* simplified alternative,
1850 because otherwise we'd need to pair it up with an empty subst-env....
1851 but we only have one env shared between all the alts.
1852 (Remember we must zap the subst-env before re-simplifying something).
1853 Rather than do this we simply agree to re-simplify the original (small) thing later.
1855 Note [Funky mkPiTypes]
1856 ~~~~~~~~~~~~~~~~~~~~~~
1857 Notice the funky mkPiTypes. If the contructor has existentials
1858 it's possible that the join point will be abstracted over
1859 type varaibles as well as term variables.
1860 Example: Suppose we have
1861 data T = forall t. C [t]
1863 case (case e of ...) of
1865 We get the join point
1866 let j :: forall t. [t] -> ...
1867 j = /\t \xs::[t] -> rhs
1869 case (case e of ...) of
1870 C t xs::[t] -> j t xs
1872 Note [Join point abstaction]
1873 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1874 If we try to lift a primitive-typed something out
1875 for let-binding-purposes, we will *caseify* it (!),
1876 with potentially-disastrous strictness results. So
1877 instead we turn it into a function: \v -> e
1878 where v::State# RealWorld#. The value passed to this function
1879 is realworld#, which generates (almost) no code.
1881 There's a slight infelicity here: we pass the overall
1882 case_bndr to all the join points if it's used in *any* RHS,
1883 because we don't know its usage in each RHS separately
1885 We used to say "&& isUnLiftedType rhs_ty'" here, but now
1886 we make the join point into a function whenever used_bndrs'
1887 is empty. This makes the join-point more CPR friendly.
1888 Consider: let j = if .. then I# 3 else I# 4
1889 in case .. of { A -> j; B -> j; C -> ... }
1891 Now CPR doesn't w/w j because it's a thunk, so
1892 that means that the enclosing function can't w/w either,
1893 which is a lose. Here's the example that happened in practice:
1894 kgmod :: Int -> Int -> Int
1895 kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
1899 I have seen a case alternative like this:
1901 It's a bit silly to add the realWorld dummy arg in this case, making
1904 (the \v alone is enough to make CPR happy) but I think it's rare
1906 Note [Duplicating strict continuations]
1907 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1908 Do *not* duplicate StrictBind and StritArg continuations. We gain
1909 nothing by propagating them into the expressions, and we do lose a
1910 lot. Here's an example:
1911 && (case x of { T -> F; F -> T }) E
1912 Now, && is strict so we end up simplifying the case with
1913 an ArgOf continuation. If we let-bind it, we get
1915 let $j = \v -> && v E
1916 in simplExpr (case x of { T -> F; F -> T })
1918 And after simplifying more we get
1920 let $j = \v -> && v E
1921 in case x of { T -> $j F; F -> $j T }
1922 Which is a Very Bad Thing
1924 The desire not to duplicate is the entire reason that
1925 mkDupableCont returns a pair of continuations.
1927 The original plan had:
1928 e.g. (...strict-fn...) [...hole...]
1930 let $j = \a -> ...strict-fn...
1933 Note [Single-alternative cases]
1934 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1935 This case is just like the ArgOf case. Here's an example:
1939 case (case x of I# x' ->
1941 True -> I# (negate# x')
1942 False -> I# x') of y {
1944 Because the (case x) has only one alternative, we'll transform to
1946 case (case x' <# 0# of
1947 True -> I# (negate# x')
1948 False -> I# x') of y {
1950 But now we do *NOT* want to make a join point etc, giving
1952 let $j = \y -> MkT y
1954 True -> $j (I# (negate# x'))
1956 In this case the $j will inline again, but suppose there was a big
1957 strict computation enclosing the orginal call to MkT. Then, it won't
1958 "see" the MkT any more, because it's big and won't get duplicated.
1959 And, what is worse, nothing was gained by the case-of-case transform.
1961 When should use this case of mkDupableCont?
1962 However, matching on *any* single-alternative case is a *disaster*;
1963 e.g. case (case ....) of (a,b) -> (# a,b #)
1964 We must push the outer case into the inner one!
1967 * Match [(DEFAULT,_,_)], but in the common case of Int,
1968 the alternative-filling-in code turned the outer case into
1969 case (...) of y { I# _ -> MkT y }
1971 * Match on single alternative plus (not (isDeadBinder case_bndr))
1972 Rationale: pushing the case inwards won't eliminate the construction.
1973 But there's a risk of
1974 case (...) of y { (a,b) -> let z=(a,b) in ... }
1975 Now y looks dead, but it'll come alive again. Still, this
1976 seems like the best option at the moment.
1978 * Match on single alternative plus (all (isDeadBinder bndrs))
1979 Rationale: this is essentially seq.
1981 * Match when the rhs is *not* duplicable, and hence would lead to a
1982 join point. This catches the disaster-case above. We can test
1983 the *un-simplified* rhs, which is fine. It might get bigger or
1984 smaller after simplification; if it gets smaller, this case might
1985 fire next time round. NB also that we must test contIsDupable
1986 case_cont *btoo, because case_cont might be big!
1988 HOWEVER: I found that this version doesn't work well, because
1989 we can get let x = case (...) of { small } in ...case x...
1990 When x is inlined into its full context, we find that it was a bad
1991 idea to have pushed the outer case inside the (...) case.