2 % (c) The AQUA Project, Glasgow University, 1993-1998
4 \section[Simplify]{The main module of the simplifier}
7 module Simplify ( simplTopBinds, simplExpr ) where
9 #include "HsVersions.h"
13 import Type hiding ( substTy, extendTvSubst )
16 import MkId ( rUNTIME_ERROR_ID )
21 import FamInstEnv ( topNormaliseType )
22 import DataCon ( dataConRepStrictness, dataConUnivTyVars )
24 import NewDemand ( isStrictDmd, splitStrictSig )
25 import PprCore ( pprParendExpr, pprCoreExpr )
26 import CoreUnfold ( mkUnfolding, callSiteInline, CallCtxt(..) )
28 import Rules ( lookupRule, getRules )
29 import BasicTypes ( isMarkedStrict )
30 import CostCentre ( currentCCS )
31 import TysPrim ( realWorldStatePrimTy )
32 import PrelInfo ( realWorldPrimId )
33 import BasicTypes ( TopLevelFlag(..), isTopLevel,
34 RecFlag(..), isNonRuleLoopBreaker )
35 import Maybes ( orElse )
36 import Data.List ( mapAccumL )
42 The guts of the simplifier is in this module, but the driver loop for
43 the simplifier is in SimplCore.lhs.
46 -----------------------------------------
47 *** IMPORTANT NOTE ***
48 -----------------------------------------
49 The simplifier used to guarantee that the output had no shadowing, but
50 it does not do so any more. (Actually, it never did!) The reason is
51 documented with simplifyArgs.
54 -----------------------------------------
55 *** IMPORTANT NOTE ***
56 -----------------------------------------
57 Many parts of the simplifier return a bunch of "floats" as well as an
58 expression. This is wrapped as a datatype SimplUtils.FloatsWith.
60 All "floats" are let-binds, not case-binds, but some non-rec lets may
61 be unlifted (with RHS ok-for-speculation).
65 -----------------------------------------
66 ORGANISATION OF FUNCTIONS
67 -----------------------------------------
69 - simplify all top-level binders
70 - for NonRec, call simplRecOrTopPair
71 - for Rec, call simplRecBind
74 ------------------------------
75 simplExpr (applied lambda) ==> simplNonRecBind
76 simplExpr (Let (NonRec ...) ..) ==> simplNonRecBind
77 simplExpr (Let (Rec ...) ..) ==> simplify binders; simplRecBind
79 ------------------------------
80 simplRecBind [binders already simplfied]
81 - use simplRecOrTopPair on each pair in turn
83 simplRecOrTopPair [binder already simplified]
84 Used for: recursive bindings (top level and nested)
85 top-level non-recursive bindings
87 - check for PreInlineUnconditionally
91 Used for: non-top-level non-recursive bindings
92 beta reductions (which amount to the same thing)
93 Because it can deal with strict arts, it takes a
94 "thing-inside" and returns an expression
96 - check for PreInlineUnconditionally
97 - simplify binder, including its IdInfo
106 simplNonRecX: [given a *simplified* RHS, but an *unsimplified* binder]
107 Used for: binding case-binder and constr args in a known-constructor case
108 - check for PreInLineUnconditionally
112 ------------------------------
113 simplLazyBind: [binder already simplified, RHS not]
114 Used for: recursive bindings (top level and nested)
115 top-level non-recursive bindings
116 non-top-level, but *lazy* non-recursive bindings
117 [must not be strict or unboxed]
118 Returns floats + an augmented environment, not an expression
119 - substituteIdInfo and add result to in-scope
120 [so that rules are available in rec rhs]
123 - float if exposes constructor or PAP
127 completeNonRecX: [binder and rhs both simplified]
128 - if the the thing needs case binding (unlifted and not ok-for-spec)
134 completeBind: [given a simplified RHS]
135 [used for both rec and non-rec bindings, top level and not]
136 - try PostInlineUnconditionally
137 - add unfolding [this is the only place we add an unfolding]
142 Right hand sides and arguments
143 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
144 In many ways we want to treat
145 (a) the right hand side of a let(rec), and
146 (b) a function argument
147 in the same way. But not always! In particular, we would
148 like to leave these arguments exactly as they are, so they
149 will match a RULE more easily.
154 It's harder to make the rule match if we ANF-ise the constructor,
155 or eta-expand the PAP:
157 f (let { a = g x; b = h x } in (a,b))
160 On the other hand if we see the let-defns
165 then we *do* want to ANF-ise and eta-expand, so that p and q
166 can be safely inlined.
168 Even floating lets out is a bit dubious. For let RHS's we float lets
169 out if that exposes a value, so that the value can be inlined more vigorously.
172 r = let x = e in (x,x)
174 Here, if we float the let out we'll expose a nice constructor. We did experiments
175 that showed this to be a generally good thing. But it was a bad thing to float
176 lets out unconditionally, because that meant they got allocated more often.
178 For function arguments, there's less reason to expose a constructor (it won't
179 get inlined). Just possibly it might make a rule match, but I'm pretty skeptical.
180 So for the moment we don't float lets out of function arguments either.
185 For eta expansion, we want to catch things like
187 case e of (a,b) -> \x -> case a of (p,q) -> \y -> r
189 If the \x was on the RHS of a let, we'd eta expand to bring the two
190 lambdas together. And in general that's a good thing to do. Perhaps
191 we should eta expand wherever we find a (value) lambda? Then the eta
192 expansion at a let RHS can concentrate solely on the PAP case.
195 %************************************************************************
197 \subsection{Bindings}
199 %************************************************************************
202 simplTopBinds :: SimplEnv -> [InBind] -> SimplM [OutBind]
204 simplTopBinds env0 binds0
205 = do { -- Put all the top-level binders into scope at the start
206 -- so that if a transformation rule has unexpectedly brought
207 -- anything into scope, then we don't get a complaint about that.
208 -- It's rather as if the top-level binders were imported.
209 ; env1 <- simplRecBndrs env0 (bindersOfBinds binds0)
210 ; dflags <- getDOptsSmpl
211 ; let dump_flag = dopt Opt_D_dump_inlinings dflags ||
212 dopt Opt_D_dump_rule_firings dflags
213 ; env2 <- simpl_binds dump_flag env1 binds0
214 ; freeTick SimplifierDone
215 ; return (getFloats env2) }
217 -- We need to track the zapped top-level binders, because
218 -- they should have their fragile IdInfo zapped (notably occurrence info)
219 -- That's why we run down binds and bndrs' simultaneously.
221 -- The dump-flag emits a trace for each top-level binding, which
222 -- helps to locate the tracing for inlining and rule firing
223 simpl_binds :: Bool -> SimplEnv -> [InBind] -> SimplM SimplEnv
224 simpl_binds _ env [] = return env
225 simpl_binds dump env (bind:binds) = do { env' <- trace_bind dump bind $
227 ; simpl_binds dump env' binds }
229 trace_bind True bind = pprTrace "SimplBind" (ppr (bindersOf bind))
230 trace_bind False _ = \x -> x
232 simpl_bind env (Rec pairs) = simplRecBind env TopLevel pairs
233 simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel b b' r
235 (env', b') = addBndrRules env b (lookupRecBndr env b)
239 %************************************************************************
241 \subsection{Lazy bindings}
243 %************************************************************************
245 simplRecBind is used for
246 * recursive bindings only
249 simplRecBind :: SimplEnv -> TopLevelFlag
252 simplRecBind env0 top_lvl pairs0
253 = do { let (env_with_info, triples) = mapAccumL add_rules env0 pairs0
254 ; env1 <- go (zapFloats env_with_info) triples
255 ; return (env0 `addRecFloats` env1) }
256 -- addFloats adds the floats from env1,
257 -- _and_ updates env0 with the in-scope set from env1
259 add_rules :: SimplEnv -> (InBndr,InExpr) -> (SimplEnv, (InBndr, OutBndr, InExpr))
260 -- Add the (substituted) rules to the binder
261 add_rules env (bndr, rhs) = (env', (bndr, bndr', rhs))
263 (env', bndr') = addBndrRules env bndr (lookupRecBndr env bndr)
265 go env [] = return env
267 go env ((old_bndr, new_bndr, rhs) : pairs)
268 = do { env' <- simplRecOrTopPair env top_lvl old_bndr new_bndr rhs
272 simplOrTopPair is used for
273 * recursive bindings (whether top level or not)
274 * top-level non-recursive bindings
276 It assumes the binder has already been simplified, but not its IdInfo.
279 simplRecOrTopPair :: SimplEnv
281 -> InId -> OutBndr -> InExpr -- Binder and rhs
282 -> SimplM SimplEnv -- Returns an env that includes the binding
284 simplRecOrTopPair env top_lvl old_bndr new_bndr rhs
285 | preInlineUnconditionally env top_lvl old_bndr rhs -- Check for unconditional inline
286 = do { tick (PreInlineUnconditionally old_bndr)
287 ; return (extendIdSubst env old_bndr (mkContEx env rhs)) }
290 = simplLazyBind env top_lvl Recursive old_bndr new_bndr rhs env
291 -- May not actually be recursive, but it doesn't matter
295 simplLazyBind is used for
296 * [simplRecOrTopPair] recursive bindings (whether top level or not)
297 * [simplRecOrTopPair] top-level non-recursive bindings
298 * [simplNonRecE] non-top-level *lazy* non-recursive bindings
301 1. It assumes that the binder is *already* simplified,
302 and is in scope, and its IdInfo too, except unfolding
304 2. It assumes that the binder type is lifted.
306 3. It does not check for pre-inline-unconditionallly;
307 that should have been done already.
310 simplLazyBind :: SimplEnv
311 -> TopLevelFlag -> RecFlag
312 -> InId -> OutId -- Binder, both pre-and post simpl
313 -- The OutId has IdInfo, except arity, unfolding
314 -> InExpr -> SimplEnv -- The RHS and its environment
317 simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
318 = do { let rhs_env = rhs_se `setInScope` env
319 (tvs, body) = case collectTyBinders rhs of
320 (tvs, body) | not_lam body -> (tvs,body)
321 | otherwise -> ([], rhs)
322 not_lam (Lam _ _) = False
324 -- Do not do the "abstract tyyvar" thing if there's
325 -- a lambda inside, becuase it defeats eta-reduction
326 -- f = /\a. \x. g a x
329 ; (body_env, tvs') <- simplBinders rhs_env tvs
330 -- See Note [Floating and type abstraction] in SimplUtils
333 ; (body_env1, body1) <- simplExprF body_env body mkBoringStop
335 -- ANF-ise a constructor or PAP rhs
336 ; (body_env2, body2) <- prepareRhs body_env1 body1
339 <- if not (doFloatFromRhs top_lvl is_rec False body2 body_env2)
340 then -- No floating, just wrap up!
341 do { rhs' <- mkLam tvs' (wrapFloats body_env2 body2)
342 ; return (env, rhs') }
344 else if null tvs then -- Simple floating
345 do { tick LetFloatFromLet
346 ; return (addFloats env body_env2, body2) }
348 else -- Do type-abstraction first
349 do { tick LetFloatFromLet
350 ; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2
351 ; rhs' <- mkLam tvs' body3
352 ; let env' = foldl (addPolyBind top_lvl) env poly_binds
353 ; return (env', rhs') }
355 ; completeBind env' top_lvl bndr bndr1 rhs' }
358 A specialised variant of simplNonRec used when the RHS is already simplified,
359 notably in knownCon. It uses case-binding where necessary.
362 simplNonRecX :: SimplEnv
363 -> InId -- Old binder
364 -> OutExpr -- Simplified RHS
367 simplNonRecX env bndr new_rhs
368 = do { (env', bndr') <- simplBinder env bndr
369 ; completeNonRecX env' (isStrictId bndr) bndr bndr' new_rhs }
371 completeNonRecX :: SimplEnv
373 -> InId -- Old binder
374 -> OutId -- New binder
375 -> OutExpr -- Simplified RHS
378 completeNonRecX env is_strict old_bndr new_bndr new_rhs
379 = do { (env1, rhs1) <- prepareRhs (zapFloats env) new_rhs
381 if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1
382 then do { tick LetFloatFromLet
383 ; return (addFloats env env1, rhs1) } -- Add the floats to the main env
384 else return (env, wrapFloats env1 rhs1) -- Wrap the floats around the RHS
385 ; completeBind env2 NotTopLevel old_bndr new_bndr rhs2 }
388 {- No, no, no! Do not try preInlineUnconditionally in completeNonRecX
389 Doing so risks exponential behaviour, because new_rhs has been simplified once already
390 In the cases described by the folowing commment, postInlineUnconditionally will
391 catch many of the relevant cases.
392 -- This happens; for example, the case_bndr during case of
393 -- known constructor: case (a,b) of x { (p,q) -> ... }
394 -- Here x isn't mentioned in the RHS, so we don't want to
395 -- create the (dead) let-binding let x = (a,b) in ...
397 -- Similarly, single occurrences can be inlined vigourously
398 -- e.g. case (f x, g y) of (a,b) -> ....
399 -- If a,b occur once we can avoid constructing the let binding for them.
401 Furthermore in the case-binding case preInlineUnconditionally risks extra thunks
402 -- Consider case I# (quotInt# x y) of
403 -- I# v -> let w = J# v in ...
404 -- If we gaily inline (quotInt# x y) for v, we end up building an
406 -- let w = J# (quotInt# x y) in ...
407 -- because quotInt# can fail.
409 | preInlineUnconditionally env NotTopLevel bndr new_rhs
410 = thing_inside (extendIdSubst env bndr (DoneEx new_rhs))
413 ----------------------------------
414 prepareRhs takes a putative RHS, checks whether it's a PAP or
415 constructor application and, if so, converts it to ANF, so that the
416 resulting thing can be inlined more easily. Thus
423 We also want to deal well cases like this
424 v = (f e1 `cast` co) e2
425 Here we want to make e1,e2 trivial and get
426 x1 = e1; x2 = e2; v = (f x1 `cast` co) v2
427 That's what the 'go' loop in prepareRhs does
430 prepareRhs :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
431 -- Adds new floats to the env iff that allows us to return a good RHS
432 prepareRhs env (Cast rhs co) -- Note [Float coercions]
433 | (ty1, _ty2) <- coercionKind co -- Do *not* do this if rhs has an unlifted type
434 , not (isUnLiftedType ty1) -- see Note [Float coercions (unlifted)]
435 = do { (env', rhs') <- makeTrivial env rhs
436 ; return (env', Cast rhs' co) }
439 = do { (_is_val, env1, rhs1) <- go 0 env0 rhs0
440 ; return (env1, rhs1) }
442 go n_val_args env (Cast rhs co)
443 = do { (is_val, env', rhs') <- go n_val_args env rhs
444 ; return (is_val, env', Cast rhs' co) }
445 go n_val_args env (App fun (Type ty))
446 = do { (is_val, env', rhs') <- go n_val_args env fun
447 ; return (is_val, env', App rhs' (Type ty)) }
448 go n_val_args env (App fun arg)
449 = do { (is_val, env', fun') <- go (n_val_args+1) env fun
451 True -> do { (env'', arg') <- makeTrivial env' arg
452 ; return (True, env'', App fun' arg') }
453 False -> return (False, env, App fun arg) }
454 go n_val_args env (Var fun)
455 = return (is_val, env, Var fun)
457 is_val = n_val_args > 0 -- There is at least one arg
458 -- ...and the fun a constructor or PAP
459 && (isDataConWorkId fun || n_val_args < idArity fun)
461 = return (False, env, other)
465 Note [Float coercions]
466 ~~~~~~~~~~~~~~~~~~~~~~
467 When we find the binding
469 we'd like to transform it to
471 x = x `cast` co -- A trivial binding
472 There's a chance that e will be a constructor application or function, or something
473 like that, so moving the coerion to the usage site may well cancel the coersions
474 and lead to further optimisation. Example:
477 data instance T Int = T Int
479 foo :: Int -> Int -> Int
484 go n = case x of { T m -> go (n-m) }
485 -- This case should optimise
487 Note [Float coercions (unlifted)]
488 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
489 BUT don't do [Float coercions] if 'e' has an unlifted type.
492 foo :: Int = (error (# Int,Int #) "urk")
493 `cast` CoUnsafe (# Int,Int #) Int
495 If do the makeTrivial thing to the error call, we'll get
496 foo = case error (# Int,Int #) "urk" of v -> v `cast` ...
497 But 'v' isn't in scope!
499 These strange casts can happen as a result of case-of-case
500 bar = case (case x of { T -> (# 2,3 #); F -> error "urk" }) of
505 makeTrivial :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
506 -- Binds the expression to a variable, if it's not trivial, returning the variable
510 | otherwise -- See Note [Take care] below
511 = do { var <- newId (fsLit "a") (exprType expr)
512 ; env' <- completeNonRecX env False var var expr
513 ; return (env', substExpr env' (Var var)) }
514 -- The substitution is needed becase we're constructing a new binding
516 -- And if rhs is of form (rhs1 |> co), then we might get
519 -- and now a's RHS is trivial and can be substituted out, and that
520 -- is what completeNonRecX will do
524 %************************************************************************
526 \subsection{Completing a lazy binding}
528 %************************************************************************
531 * deals only with Ids, not TyVars
532 * takes an already-simplified binder and RHS
533 * is used for both recursive and non-recursive bindings
534 * is used for both top-level and non-top-level bindings
536 It does the following:
537 - tries discarding a dead binding
538 - tries PostInlineUnconditionally
539 - add unfolding [this is the only place we add an unfolding]
542 It does *not* attempt to do let-to-case. Why? Because it is used for
543 - top-level bindings (when let-to-case is impossible)
544 - many situations where the "rhs" is known to be a WHNF
545 (so let-to-case is inappropriate).
547 Nor does it do the atomic-argument thing
550 completeBind :: SimplEnv
551 -> TopLevelFlag -- Flag stuck into unfolding
552 -> InId -- Old binder
553 -> OutId -> OutExpr -- New binder and RHS
555 -- completeBind may choose to do its work
556 -- * by extending the substitution (e.g. let x = y in ...)
557 -- * or by adding to the floats in the envt
559 completeBind env top_lvl old_bndr new_bndr new_rhs
560 | postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs unfolding
561 -- Inline and discard the binding
562 = do { tick (PostInlineUnconditionally old_bndr)
563 ; -- pprTrace "postInlineUnconditionally" (ppr old_bndr <+> ppr new_bndr <+> ppr new_rhs) $
564 return (extendIdSubst env old_bndr (DoneEx new_rhs)) }
565 -- Use the substitution to make quite, quite sure that the
566 -- substitution will happen, since we are going to discard the binding
569 = return (addNonRecWithUnf env new_bndr new_rhs unfolding wkr)
571 unfolding | omit_unfolding = NoUnfolding
572 | otherwise = mkUnfolding (isTopLevel top_lvl) new_rhs
573 old_info = idInfo old_bndr
574 occ_info = occInfo old_info
575 wkr = substWorker env (workerInfo old_info)
576 omit_unfolding = isNonRuleLoopBreaker occ_info
577 -- or not (activeInline env old_bndr)
578 -- Do *not* trim the unfolding in SimplGently, else
579 -- the specialiser can't see it!
582 addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplEnv
583 -- Add a new binding to the environment, complete with its unfolding
584 -- but *do not* do postInlineUnconditionally, because we have already
585 -- processed some of the scope of the binding
586 -- We still want the unfolding though. Consider
588 -- x = /\a. let y = ... in Just y
590 -- Then we float the y-binding out (via abstractFloats and addPolyBind)
591 -- but 'x' may well then be inlined in 'body' in which case we'd like the
592 -- opportunity to inline 'y' too.
594 addPolyBind top_lvl env (NonRec poly_id rhs)
595 = addNonRecWithUnf env poly_id rhs unfolding NoWorker
597 unfolding | not (activeInline env poly_id) = NoUnfolding
598 | otherwise = mkUnfolding (isTopLevel top_lvl) rhs
599 -- addNonRecWithInfo adds the new binding in the
600 -- proper way (ie complete with unfolding etc),
601 -- and extends the in-scope set
603 addPolyBind _ env bind@(Rec _) = extendFloats env bind
604 -- Hack: letrecs are more awkward, so we extend "by steam"
605 -- without adding unfoldings etc. At worst this leads to
606 -- more simplifier iterations
609 addNonRecWithUnf :: SimplEnv
610 -> OutId -> OutExpr -- New binder and RHS
611 -> Unfolding -> WorkerInfo -- and unfolding
613 -- Add suitable IdInfo to the Id, add the binding to the floats, and extend the in-scope set
614 addNonRecWithUnf env new_bndr rhs unfolding wkr
615 = ASSERT( isId new_bndr )
616 WARN( new_arity < old_arity || new_arity < dmd_arity,
617 (ppr final_id <+> ppr old_arity <+> ppr new_arity <+> ppr dmd_arity) $$ ppr rhs )
618 final_id `seq` -- This seq forces the Id, and hence its IdInfo,
619 -- and hence any inner substitutions
620 addNonRec env final_id rhs
621 -- The addNonRec adds it to the in-scope set too
623 dmd_arity = length $ fst $ splitStrictSig $ idNewStrictness new_bndr
624 old_arity = idArity new_bndr
627 new_arity = exprArity rhs
628 new_bndr_info = idInfo new_bndr `setArityInfo` new_arity
631 -- Add the unfolding *only* for non-loop-breakers
632 -- Making loop breakers not have an unfolding at all
633 -- means that we can avoid tests in exprIsConApp, for example.
634 -- This is important: if exprIsConApp says 'yes' for a recursive
635 -- thing, then we can get into an infinite loop
638 -- If the unfolding is a value, the demand info may
639 -- go pear-shaped, so we nuke it. Example:
641 -- case x of (p,q) -> h p q x
642 -- Here x is certainly demanded. But after we've nuked
643 -- the case, we'll get just
644 -- let x = (a,b) in h a b x
645 -- and now x is not demanded (I'm assuming h is lazy)
646 -- This really happens. Similarly
647 -- let f = \x -> e in ...f..f...
648 -- After inlining f at some of its call sites the original binding may
649 -- (for example) be no longer strictly demanded.
650 -- The solution here is a bit ad hoc...
651 info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding
654 final_info | isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf
655 | otherwise = info_w_unf
657 final_id = new_bndr `setIdInfo` final_info
662 %************************************************************************
664 \subsection[Simplify-simplExpr]{The main function: simplExpr}
666 %************************************************************************
668 The reason for this OutExprStuff stuff is that we want to float *after*
669 simplifying a RHS, not before. If we do so naively we get quadratic
670 behaviour as things float out.
672 To see why it's important to do it after, consider this (real) example:
686 a -- Can't inline a this round, cos it appears twice
690 Each of the ==> steps is a round of simplification. We'd save a
691 whole round if we float first. This can cascade. Consider
696 let f = let d1 = ..d.. in \y -> e
700 in \x -> ...(\y ->e)...
702 Only in this second round can the \y be applied, and it
703 might do the same again.
707 simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
708 simplExpr env expr = simplExprC env expr mkBoringStop
710 simplExprC :: SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr
711 -- Simplify an expression, given a continuation
712 simplExprC env expr cont
713 = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seFloats env) ) $
714 do { (env', expr') <- simplExprF (zapFloats env) expr cont
715 ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $
716 -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $
717 -- pprTrace "simplExprC ret4" (ppr (seFloats env')) $
718 return (wrapFloats env' expr') }
720 --------------------------------------------------
721 simplExprF :: SimplEnv -> InExpr -> SimplCont
722 -> SimplM (SimplEnv, OutExpr)
724 simplExprF env e cont
725 = -- pprTrace "simplExprF" (ppr e $$ ppr cont $$ ppr (seTvSubst env) $$ ppr (seIdSubst env) {- $$ ppr (seFloats env) -} ) $
726 simplExprF' env e cont
728 simplExprF' :: SimplEnv -> InExpr -> SimplCont
729 -> SimplM (SimplEnv, OutExpr)
730 simplExprF' env (Var v) cont = simplVar env v cont
731 simplExprF' env (Lit lit) cont = rebuild env (Lit lit) cont
732 simplExprF' env (Note n expr) cont = simplNote env n expr cont
733 simplExprF' env (Cast body co) cont = simplCast env body co cont
734 simplExprF' env (App fun arg) cont = simplExprF env fun $
735 ApplyTo NoDup arg env cont
737 simplExprF' env expr@(Lam _ _) cont
738 = simplLam env (map zap bndrs) body cont
739 -- The main issue here is under-saturated lambdas
740 -- (\x1. \x2. e) arg1
741 -- Here x1 might have "occurs-once" occ-info, because occ-info
742 -- is computed assuming that a group of lambdas is applied
743 -- all at once. If there are too few args, we must zap the
746 n_args = countArgs cont
747 n_params = length bndrs
748 (bndrs, body) = collectBinders expr
749 zap | n_args >= n_params = \b -> b
750 | otherwise = \b -> if isTyVar b then b
752 -- NB: we count all the args incl type args
753 -- so we must count all the binders (incl type lambdas)
755 simplExprF' env (Type ty) cont
756 = ASSERT( contIsRhsOrArg cont )
757 do { ty' <- simplType env ty
758 ; rebuild env (Type ty') cont }
760 simplExprF' env (Case scrut bndr _ alts) cont
761 | not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
762 = -- Simplify the scrutinee with a Select continuation
763 simplExprF env scrut (Select NoDup bndr alts env cont)
766 = -- If case-of-case is off, simply simplify the case expression
767 -- in a vanilla Stop context, and rebuild the result around it
768 do { case_expr' <- simplExprC env scrut case_cont
769 ; rebuild env case_expr' cont }
771 case_cont = Select NoDup bndr alts env mkBoringStop
773 simplExprF' env (Let (Rec pairs) body) cont
774 = do { env' <- simplRecBndrs env (map fst pairs)
775 -- NB: bndrs' don't have unfoldings or rules
776 -- We add them as we go down
778 ; env'' <- simplRecBind env' NotTopLevel pairs
779 ; simplExprF env'' body cont }
781 simplExprF' env (Let (NonRec bndr rhs) body) cont
782 = simplNonRecE env bndr (rhs, env) ([], body) cont
784 ---------------------------------
785 simplType :: SimplEnv -> InType -> SimplM OutType
786 -- Kept monadic just so we can do the seqType
788 = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $
789 seqType new_ty `seq` return new_ty
791 new_ty = substTy env ty
795 %************************************************************************
797 \subsection{The main rebuilder}
799 %************************************************************************
802 rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr)
803 -- At this point the substitution in the SimplEnv should be irrelevant
804 -- only the in-scope set and floats should matter
805 rebuild env expr cont0
806 = -- pprTrace "rebuild" (ppr expr $$ ppr cont0 $$ ppr (seFloats env)) $
808 Stop {} -> return (env, expr)
809 CoerceIt co cont -> rebuild env (mkCoerce co expr) cont
810 Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont
811 StrictArg fun _ info cont -> rebuildCall env (fun `App` expr) info cont
812 StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr
813 ; simplLam env' bs body cont }
814 ApplyTo _ arg se cont -> do { arg' <- simplExpr (se `setInScope` env) arg
815 ; rebuild env (App expr arg') cont }
819 %************************************************************************
823 %************************************************************************
826 simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont
827 -> SimplM (SimplEnv, OutExpr)
828 simplCast env body co0 cont0
829 = do { co1 <- simplType env co0
830 ; simplExprF env body (addCoerce co1 cont0) }
832 addCoerce co cont = add_coerce co (coercionKind co) cont
834 add_coerce _co (s1, k1) cont -- co :: ty~ty
835 | s1 `coreEqType` k1 = cont -- is a no-op
837 add_coerce co1 (s1, _k2) (CoerceIt co2 cont)
838 | (_l1, t1) <- coercionKind co2
839 -- e |> (g1 :: S1~L) |> (g2 :: L~T1)
842 -- e |> (g1 . g2 :: T1~T2) otherwise
844 -- For example, in the initial form of a worker
845 -- we may find (coerce T (coerce S (\x.e))) y
846 -- and we'd like it to simplify to e[y/x] in one round
848 , s1 `coreEqType` t1 = cont -- The coerces cancel out
849 | otherwise = CoerceIt (mkTransCoercion co1 co2) cont
851 add_coerce co (s1s2, _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont)
852 -- (f |> g) ty ---> (f ty) |> (g @ ty)
853 -- This implements the PushT rule from the paper
854 | Just (tyvar,_) <- splitForAllTy_maybe s1s2
855 , not (isCoVar tyvar)
856 = ApplyTo dup (Type ty') (zapSubstEnv env) (addCoerce (mkInstCoercion co ty') cont)
858 ty' = substTy (arg_se `setInScope` env) arg_ty
860 -- ToDo: the PushC rule is not implemented at all
862 add_coerce co (s1s2, _t1t2) (ApplyTo dup arg arg_se cont)
863 | not (isTypeArg arg) -- This implements the Push rule from the paper
864 , isFunTy s1s2 -- t1t2 must be a function type, becuase it's applied
865 -- (e |> (g :: s1s2 ~ t1->t2)) f
867 -- (e (f |> (arg g :: t1~s1))
868 -- |> (res g :: s2->t2)
870 -- t1t2 must be a function type, t1->t2, because it's applied
871 -- to something but s1s2 might conceivably not be
873 -- When we build the ApplyTo we can't mix the out-types
874 -- with the InExpr in the argument, so we simply substitute
875 -- to make it all consistent. It's a bit messy.
876 -- But it isn't a common case.
878 -- Example of use: Trac #995
879 = ApplyTo dup new_arg (zapSubstEnv env) (addCoerce co2 cont)
881 -- we split coercion t1->t2 ~ s1->s2 into t1 ~ s1 and
882 -- t2 ~ s2 with left and right on the curried form:
883 -- (->) t1 t2 ~ (->) s1 s2
884 [co1, co2] = decomposeCo 2 co
885 new_arg = mkCoerce (mkSymCoercion co1) arg'
886 arg' = substExpr (arg_se `setInScope` env) arg
888 add_coerce co _ cont = CoerceIt co cont
892 %************************************************************************
896 %************************************************************************
899 simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont
900 -> SimplM (SimplEnv, OutExpr)
902 simplLam env [] body cont = simplExprF env body cont
905 simplLam env (bndr:bndrs) body (ApplyTo _ arg arg_se cont)
906 = do { tick (BetaReduction bndr)
907 ; simplNonRecE env bndr (arg, arg_se) (bndrs, body) cont }
909 -- Not enough args, so there are real lambdas left to put in the result
910 simplLam env bndrs body cont
911 = do { (env', bndrs') <- simplLamBndrs env bndrs
912 ; body' <- simplExpr env' body
913 ; new_lam <- mkLam bndrs' body'
914 ; rebuild env' new_lam cont }
917 simplNonRecE :: SimplEnv
918 -> InId -- The binder
919 -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda)
920 -> ([InBndr], InExpr) -- Body of the let/lambda
923 -> SimplM (SimplEnv, OutExpr)
925 -- simplNonRecE is used for
926 -- * non-top-level non-recursive lets in expressions
929 -- It deals with strict bindings, via the StrictBind continuation,
930 -- which may abort the whole process
932 -- The "body" of the binding comes as a pair of ([InId],InExpr)
933 -- representing a lambda; so we recurse back to simplLam
934 -- Why? Because of the binder-occ-info-zapping done before
935 -- the call to simplLam in simplExprF (Lam ...)
937 -- First deal with type applications and type lets
938 -- (/\a. e) (Type ty) and (let a = Type ty in e)
939 simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont
940 = ASSERT( isTyVar bndr )
941 do { ty_arg' <- simplType (rhs_se `setInScope` env) ty_arg
942 ; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont }
944 simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
945 | preInlineUnconditionally env NotTopLevel bndr rhs
946 = do { tick (PreInlineUnconditionally bndr)
947 ; simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont }
950 = do { simplExprF (rhs_se `setFloats` env) rhs
951 (StrictBind bndr bndrs body env cont) }
954 = ASSERT( not (isTyVar bndr) )
955 do { (env1, bndr1) <- simplNonRecBndr env bndr
956 ; let (env2, bndr2) = addBndrRules env1 bndr bndr1
957 ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
958 ; simplLam env3 bndrs body cont }
962 %************************************************************************
966 %************************************************************************
969 -- Hack alert: we only distinguish subsumed cost centre stacks for the
970 -- purposes of inlining. All other CCCSs are mapped to currentCCS.
971 simplNote :: SimplEnv -> Note -> CoreExpr -> SimplCont
972 -> SimplM (SimplEnv, OutExpr)
973 simplNote env (SCC cc) e cont
974 = do { e' <- simplExpr (setEnclosingCC env currentCCS) e
975 ; rebuild env (mkSCC cc e') cont }
977 -- See notes with SimplMonad.inlineMode
978 simplNote env InlineMe e cont
979 | Just (inside, outside) <- splitInlineCont cont -- Boring boring continuation; see notes above
980 = do { -- Don't inline inside an INLINE expression
981 e' <- simplExprC (setMode inlineMode env) e inside
982 ; rebuild env (mkInlineMe e') outside }
984 | otherwise -- Dissolve the InlineMe note if there's
985 -- an interesting context of any kind to combine with
986 -- (even a type application -- anything except Stop)
987 = simplExprF env e cont
989 simplNote env (CoreNote s) e cont = do
990 e' <- simplExpr env e
991 rebuild env (Note (CoreNote s) e') cont
995 %************************************************************************
997 \subsection{Dealing with calls}
999 %************************************************************************
1002 simplVar :: SimplEnv -> Id -> SimplCont -> SimplM (SimplEnv, OutExpr)
1003 simplVar env var cont
1004 = case substId env var of
1005 DoneEx e -> simplExprF (zapSubstEnv env) e cont
1006 ContEx tvs ids e -> simplExprF (setSubstEnv env tvs ids) e cont
1007 DoneId var1 -> completeCall (zapSubstEnv env) var1 cont
1008 -- Note [zapSubstEnv]
1009 -- The template is already simplified, so don't re-substitute.
1010 -- This is VITAL. Consider
1012 -- let y = \z -> ...x... in
1014 -- We'll clone the inner \x, adding x->x' in the id_subst
1015 -- Then when we inline y, we must *not* replace x by x' in
1016 -- the inlined copy!!
1018 ---------------------------------------------------------
1019 -- Dealing with a call site
1021 completeCall :: SimplEnv -> Id -> SimplCont -> SimplM (SimplEnv, OutExpr)
1022 completeCall env var cont
1023 = do { dflags <- getDOptsSmpl
1024 ; let (args,call_cont) = contArgs cont
1025 -- The args are OutExprs, obtained by *lazily* substituting
1026 -- in the args found in cont. These args are only examined
1027 -- to limited depth (unless a rule fires). But we must do
1028 -- the substitution; rule matching on un-simplified args would
1031 ------------- First try rules ----------------
1032 -- Do this before trying inlining. Some functions have
1033 -- rules *and* are strict; in this case, we don't want to
1034 -- inline the wrapper of the non-specialised thing; better
1035 -- to call the specialised thing instead.
1037 -- We used to use the black-listing mechanism to ensure that inlining of
1038 -- the wrapper didn't occur for things that have specialisations till a
1039 -- later phase, so but now we just try RULES first
1041 -- Note [Rules for recursive functions]
1042 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1043 -- You might think that we shouldn't apply rules for a loop breaker:
1044 -- doing so might give rise to an infinite loop, because a RULE is
1045 -- rather like an extra equation for the function:
1046 -- RULE: f (g x) y = x+y
1049 -- But it's too drastic to disable rules for loop breakers.
1050 -- Even the foldr/build rule would be disabled, because foldr
1051 -- is recursive, and hence a loop breaker:
1052 -- foldr k z (build g) = g k z
1053 -- So it's up to the programmer: rules can cause divergence
1054 ; rule_base <- getSimplRules
1055 ; let in_scope = getInScope env
1056 rules = getRules rule_base var
1057 maybe_rule = case activeRule dflags env of
1058 Nothing -> Nothing -- No rules apply
1059 Just act_fn -> lookupRule act_fn in_scope
1061 ; case maybe_rule of {
1062 Just (rule, rule_rhs) -> do
1063 tick (RuleFired (ru_name rule))
1064 (if dopt Opt_D_dump_rule_firings dflags then
1065 pprTrace "Rule fired" (vcat [
1066 text "Rule:" <+> ftext (ru_name rule),
1067 text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
1068 text "After: " <+> pprCoreExpr rule_rhs,
1069 text "Cont: " <+> ppr call_cont])
1072 simplExprF env rule_rhs (dropArgs (ruleArity rule) cont)
1073 -- The ruleArity says how many args the rule consumed
1075 ; Nothing -> do -- No rules
1077 ------------- Next try inlining ----------------
1078 { let arg_infos = [interestingArg arg | arg <- args, isValArg arg]
1079 n_val_args = length arg_infos
1080 interesting_cont = interestingCallContext call_cont
1081 active_inline = activeInline env var
1082 maybe_inline = callSiteInline dflags active_inline var
1083 (null args) arg_infos interesting_cont
1084 ; case maybe_inline of {
1085 Just unfolding -- There is an inlining!
1086 -> do { tick (UnfoldingDone var)
1087 ; (if dopt Opt_D_dump_inlinings dflags then
1088 pprTrace ("Inlining done" ++ showSDoc (ppr var)) (vcat [
1089 text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
1090 text "Inlined fn: " <+> nest 2 (ppr unfolding),
1091 text "Cont: " <+> ppr call_cont])
1094 simplExprF env unfolding cont }
1096 ; Nothing -> -- No inlining!
1098 ------------- No inlining! ----------------
1099 -- Next, look for rules or specialisations that match
1101 rebuildCall env (Var var)
1102 (mkArgInfo var n_val_args call_cont) cont
1105 rebuildCall :: SimplEnv
1106 -> OutExpr -- Function
1109 -> SimplM (SimplEnv, OutExpr)
1110 rebuildCall env fun (ArgInfo { ai_strs = [] }) cont
1111 -- When we run out of strictness args, it means
1112 -- that the call is definitely bottom; see SimplUtils.mkArgInfo
1113 -- Then we want to discard the entire strict continuation. E.g.
1114 -- * case (error "hello") of { ... }
1115 -- * (error "Hello") arg
1116 -- * f (error "Hello") where f is strict
1118 -- Then, especially in the first of these cases, we'd like to discard
1119 -- the continuation, leaving just the bottoming expression. But the
1120 -- type might not be right, so we may have to add a coerce.
1121 | not (contIsTrivial cont) -- Only do this if there is a non-trivial
1122 = return (env, mk_coerce fun) -- contination to discard, else we do it
1123 where -- again and again!
1124 fun_ty = exprType fun
1125 cont_ty = contResultType env fun_ty cont
1126 co = mkUnsafeCoercion fun_ty cont_ty
1127 mk_coerce expr | cont_ty `coreEqType` fun_ty = expr
1128 | otherwise = mkCoerce co expr
1130 rebuildCall env fun info (ApplyTo _ (Type arg_ty) se cont)
1131 = do { ty' <- simplType (se `setInScope` env) arg_ty
1132 ; rebuildCall env (fun `App` Type ty') info cont }
1135 (ArgInfo { ai_rules = has_rules, ai_strs = str:strs, ai_discs = disc:discs })
1136 (ApplyTo _ arg arg_se cont)
1137 | str -- Strict argument
1138 = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
1139 simplExprF (arg_se `setFloats` env) arg
1140 (StrictArg fun cci arg_info' cont)
1143 | otherwise -- Lazy argument
1144 -- DO NOT float anything outside, hence simplExprC
1145 -- There is no benefit (unlike in a let-binding), and we'd
1146 -- have to be very careful about bogus strictness through
1147 -- floating a demanded let.
1148 = do { arg' <- simplExprC (arg_se `setInScope` env) arg
1150 ; rebuildCall env (fun `App` arg') arg_info' cont }
1152 arg_info' = ArgInfo { ai_rules = has_rules, ai_strs = strs, ai_discs = discs }
1153 cci | has_rules || disc > 0 = ArgCtxt has_rules disc -- Be keener here
1154 | otherwise = BoringCtxt -- Nothing interesting
1156 rebuildCall env fun _ cont
1157 = rebuild env fun cont
1162 This part of the simplifier may break the no-shadowing invariant
1164 f (...(\a -> e)...) (case y of (a,b) -> e')
1165 where f is strict in its second arg
1166 If we simplify the innermost one first we get (...(\a -> e)...)
1167 Simplifying the second arg makes us float the case out, so we end up with
1168 case y of (a,b) -> f (...(\a -> e)...) e'
1169 So the output does not have the no-shadowing invariant. However, there is
1170 no danger of getting name-capture, because when the first arg was simplified
1171 we used an in-scope set that at least mentioned all the variables free in its
1172 static environment, and that is enough.
1174 We can't just do innermost first, or we'd end up with a dual problem:
1175 case x of (a,b) -> f e (...(\a -> e')...)
1177 I spent hours trying to recover the no-shadowing invariant, but I just could
1178 not think of an elegant way to do it. The simplifier is already knee-deep in
1179 continuations. We have to keep the right in-scope set around; AND we have
1180 to get the effect that finding (error "foo") in a strict arg position will
1181 discard the entire application and replace it with (error "foo"). Getting
1182 all this at once is TOO HARD!
1184 %************************************************************************
1186 Rebuilding a cse expression
1188 %************************************************************************
1190 Blob of helper functions for the "case-of-something-else" situation.
1193 ---------------------------------------------------------
1194 -- Eliminate the case if possible
1196 rebuildCase :: SimplEnv
1197 -> OutExpr -- Scrutinee
1198 -> InId -- Case binder
1199 -> [InAlt] -- Alternatives (inceasing order)
1201 -> SimplM (SimplEnv, OutExpr)
1203 --------------------------------------------------
1204 -- 1. Eliminate the case if there's a known constructor
1205 --------------------------------------------------
1207 rebuildCase env scrut case_bndr alts cont
1208 | Just (con,args) <- exprIsConApp_maybe scrut
1209 -- Works when the scrutinee is a variable with a known unfolding
1210 -- as well as when it's an explicit constructor application
1211 = knownCon env scrut (DataAlt con) args case_bndr alts cont
1213 | Lit lit <- scrut -- No need for same treatment as constructors
1214 -- because literals are inlined more vigorously
1215 = knownCon env scrut (LitAlt lit) [] case_bndr alts cont
1218 --------------------------------------------------
1219 -- 2. Eliminate the case if scrutinee is evaluated
1220 --------------------------------------------------
1222 rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont
1223 -- See if we can get rid of the case altogether
1224 -- See the extensive notes on case-elimination above
1225 -- mkCase made sure that if all the alternatives are equal,
1226 -- then there is now only one (DEFAULT) rhs
1227 | all isDeadBinder bndrs -- bndrs are [InId]
1229 -- Check that the scrutinee can be let-bound instead of case-bound
1230 , exprOkForSpeculation scrut
1231 -- OK not to evaluate it
1232 -- This includes things like (==# a# b#)::Bool
1233 -- so that we simplify
1234 -- case ==# a# b# of { True -> x; False -> x }
1237 -- This particular example shows up in default methods for
1238 -- comparision operations (e.g. in (>=) for Int.Int32)
1239 || exprIsHNF scrut -- It's already evaluated
1240 || var_demanded_later scrut -- It'll be demanded later
1242 -- || not opt_SimplPedanticBottoms) -- Or we don't care!
1243 -- We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on,
1244 -- but that breaks badly for the dataToTag# primop, which relies on a case to evaluate
1245 -- its argument: case x of { y -> dataToTag# y }
1246 -- Here we must *not* discard the case, because dataToTag# just fetches the tag from
1247 -- the info pointer. So we'll be pedantic all the time, and see if that gives any
1249 -- Also we don't want to discard 'seq's
1250 = do { tick (CaseElim case_bndr)
1251 ; env' <- simplNonRecX env case_bndr scrut
1252 ; simplExprF env' rhs cont }
1254 -- The case binder is going to be evaluated later,
1255 -- and the scrutinee is a simple variable
1256 var_demanded_later (Var v) = isStrictDmd (idNewDemandInfo case_bndr)
1257 && not (isTickBoxOp v)
1258 -- ugly hack; covering this case is what
1259 -- exprOkForSpeculation was intended for.
1260 var_demanded_later _ = False
1263 --------------------------------------------------
1264 -- 3. Catch-all case
1265 --------------------------------------------------
1267 rebuildCase env scrut case_bndr alts cont
1268 = do { -- Prepare the continuation;
1269 -- The new subst_env is in place
1270 (env', dup_cont, nodup_cont) <- prepareCaseCont env alts cont
1272 -- Simplify the alternatives
1273 ; (scrut', case_bndr', alts') <- simplAlts env' scrut case_bndr alts dup_cont
1275 -- Check for empty alternatives
1276 ; if null alts' then
1277 -- This isn't strictly an error, although it is unusual.
1278 -- It's possible that the simplifer might "see" that
1279 -- an inner case has no accessible alternatives before
1280 -- it "sees" that the entire branch of an outer case is
1281 -- inaccessible. So we simply put an error case here instead.
1282 pprTrace "mkCase: null alts" (ppr case_bndr <+> ppr scrut) $
1283 let res_ty' = contResultType env' (substTy env' (coreAltsType alts)) dup_cont
1284 lit = mkStringLit "Impossible alternative"
1285 in return (env', mkApps (Var rUNTIME_ERROR_ID) [Type res_ty', lit])
1288 { case_expr <- mkCase scrut' case_bndr' alts'
1290 -- Notice that rebuild gets the in-scope set from env, not alt_env
1291 -- The case binder *not* scope over the whole returned case-expression
1292 ; rebuild env' case_expr nodup_cont } }
1295 simplCaseBinder checks whether the scrutinee is a variable, v. If so,
1296 try to eliminate uses of v in the RHSs in favour of case_bndr; that
1297 way, there's a chance that v will now only be used once, and hence
1300 Note [no-case-of-case]
1301 ~~~~~~~~~~~~~~~~~~~~~~
1302 We *used* to suppress the binder-swap in case expressoins when
1303 -fno-case-of-case is on. Old remarks:
1304 "This happens in the first simplifier pass,
1305 and enhances full laziness. Here's the bad case:
1306 f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )
1307 If we eliminate the inner case, we trap it inside the I# v -> arm,
1308 which might prevent some full laziness happening. I've seen this
1309 in action in spectral/cichelli/Prog.hs:
1310 [(m,n) | m <- [1..max], n <- [1..max]]
1311 Hence the check for NoCaseOfCase."
1312 However, now the full-laziness pass itself reverses the binder-swap, so this
1313 check is no longer necessary.
1315 Note [Suppressing the case binder-swap]
1316 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1317 There is another situation when it might make sense to suppress the
1318 case-expression binde-swap. If we have
1320 case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }
1321 ...other cases .... }
1323 We'll perform the binder-swap for the outer case, giving
1325 case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }
1326 ...other cases .... }
1328 But there is no point in doing it for the inner case, because w1 can't
1329 be inlined anyway. Furthermore, doing the case-swapping involves
1330 zapping w2's occurrence info (see paragraphs that follow), and that
1331 forces us to bind w2 when doing case merging. So we get
1333 case x of w1 { A -> let w2 = w1 in e1
1334 B -> let w2 = w1 in e2
1335 ...other cases .... }
1337 This is plain silly in the common case where w2 is dead.
1339 Even so, I can't see a good way to implement this idea. I tried
1340 not doing the binder-swap if the scrutinee was already evaluated
1341 but that failed big-time:
1345 case v of w { MkT x ->
1346 case x of x1 { I# y1 ->
1347 case x of x2 { I# y2 -> ...
1349 Notice that because MkT is strict, x is marked "evaluated". But to
1350 eliminate the last case, we must either make sure that x (as well as
1351 x1) has unfolding MkT y1. THe straightforward thing to do is to do
1352 the binder-swap. So this whole note is a no-op.
1356 If we replace the scrutinee, v, by tbe case binder, then we have to nuke
1357 any occurrence info (eg IAmDead) in the case binder, because the
1358 case-binder now effectively occurs whenever v does. AND we have to do
1359 the same for the pattern-bound variables! Example:
1361 (case x of { (a,b) -> a }) (case x of { (p,q) -> q })
1363 Here, b and p are dead. But when we move the argment inside the first
1364 case RHS, and eliminate the second case, we get
1366 case x of { (a,b) -> a b }
1368 Urk! b is alive! Reason: the scrutinee was a variable, and case elimination
1371 Indeed, this can happen anytime the case binder isn't dead:
1372 case <any> of x { (a,b) ->
1373 case x of { (p,q) -> p } }
1374 Here (a,b) both look dead, but come alive after the inner case is eliminated.
1375 The point is that we bring into the envt a binding
1377 after the outer case, and that makes (a,b) alive. At least we do unless
1378 the case binder is guaranteed dead.
1382 Consider case (v `cast` co) of x { I# ->
1383 ... (case (v `cast` co) of {...}) ...
1384 We'd like to eliminate the inner case. We can get this neatly by
1385 arranging that inside the outer case we add the unfolding
1386 v |-> x `cast` (sym co)
1387 to v. Then we should inline v at the inner case, cancel the casts, and away we go
1389 Note [Improving seq]
1392 type family F :: * -> *
1393 type instance F Int = Int
1395 ... case e of x { DEFAULT -> rhs } ...
1397 where x::F Int. Then we'd like to rewrite (F Int) to Int, getting
1399 case e `cast` co of x'::Int
1400 I# x# -> let x = x' `cast` sym co
1403 so that 'rhs' can take advantage of the form of x'. Notice that Note
1404 [Case of cast] may then apply to the result.
1406 This showed up in Roman's experiments. Example:
1407 foo :: F Int -> Int -> Int
1408 foo t n = t `seq` bar n
1411 bar n = bar (n - case t of TI i -> i)
1412 Here we'd like to avoid repeated evaluating t inside the loop, by
1413 taking advantage of the `seq`.
1415 At one point I did transformation in LiberateCase, but it's more robust here.
1416 (Otherwise, there's a danger that we'll simply drop the 'seq' altogether, before
1417 LiberateCase gets to see it.)
1419 Note [Case elimination]
1420 ~~~~~~~~~~~~~~~~~~~~~~~
1421 The case-elimination transformation discards redundant case expressions.
1422 Start with a simple situation:
1424 case x# of ===> e[x#/y#]
1427 (when x#, y# are of primitive type, of course). We can't (in general)
1428 do this for algebraic cases, because we might turn bottom into
1431 The code in SimplUtils.prepareAlts has the effect of generalise this
1432 idea to look for a case where we're scrutinising a variable, and we
1433 know that only the default case can match. For example:
1437 DEFAULT -> ...(case x of
1441 Here the inner case is first trimmed to have only one alternative, the
1442 DEFAULT, after which it's an instance of the previous case. This
1443 really only shows up in eliminating error-checking code.
1445 We also make sure that we deal with this very common case:
1450 Here we are using the case as a strict let; if x is used only once
1451 then we want to inline it. We have to be careful that this doesn't
1452 make the program terminate when it would have diverged before, so we
1454 - e is already evaluated (it may so if e is a variable)
1455 - x is used strictly, or
1457 Lastly, the code in SimplUtils.mkCase combines identical RHSs. So
1459 case e of ===> case e of DEFAULT -> r
1463 Now again the case may be elminated by the CaseElim transformation.
1466 Further notes about case elimination
1467 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1468 Consider: test :: Integer -> IO ()
1471 Turns out that this compiles to:
1474 eta1 :: State# RealWorld ->
1475 case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->
1477 (PrelNum.jtos eta ($w[] @ Char))
1479 of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s }}
1481 Notice the strange '<' which has no effect at all. This is a funny one.
1482 It started like this:
1484 f x y = if x < 0 then jtos x
1485 else if y==0 then "" else jtos x
1487 At a particular call site we have (f v 1). So we inline to get
1489 if v < 0 then jtos x
1490 else if 1==0 then "" else jtos x
1492 Now simplify the 1==0 conditional:
1494 if v<0 then jtos v else jtos v
1496 Now common-up the two branches of the case:
1498 case (v<0) of DEFAULT -> jtos v
1500 Why don't we drop the case? Because it's strict in v. It's technically
1501 wrong to drop even unnecessary evaluations, and in practice they
1502 may be a result of 'seq' so we *definitely* don't want to drop those.
1503 I don't really know how to improve this situation.
1507 simplCaseBinder :: SimplEnv -> OutExpr -> OutId -> [InAlt]
1508 -> SimplM (SimplEnv, OutExpr, OutId)
1509 simplCaseBinder env0 scrut0 case_bndr0 alts
1510 = do { (env1, case_bndr1) <- simplBinder env0 case_bndr0
1512 ; fam_envs <- getFamEnvs
1513 ; (env2, scrut2, case_bndr2) <- improve_seq fam_envs env1 scrut0
1514 case_bndr0 case_bndr1 alts
1515 -- Note [Improving seq]
1517 ; let (env3, case_bndr3) = improve_case_bndr env2 scrut2 case_bndr2
1518 -- Note [Case of cast]
1520 ; return (env3, scrut2, case_bndr3) }
1523 improve_seq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)]
1524 | Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1)
1525 = do { case_bndr2 <- newId (fsLit "nt") ty2
1526 ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co)
1527 env2 = extendIdSubst env case_bndr rhs
1528 ; return (env2, scrut `Cast` co, case_bndr2) }
1530 improve_seq _ env scrut _ case_bndr1 _
1531 = return (env, scrut, case_bndr1)
1534 improve_case_bndr env scrut case_bndr
1535 -- See Note [no-case-of-case]
1536 -- | switchIsOn (getSwitchChecker env) NoCaseOfCase
1537 -- = (env, case_bndr)
1539 | otherwise -- Failed try; see Note [Suppressing the case binder-swap]
1540 -- not (isEvaldUnfolding (idUnfolding v))
1542 Var v -> (modifyInScope env1 v case_bndr', case_bndr')
1543 -- Note about using modifyInScope for v here
1544 -- We could extend the substitution instead, but it would be
1545 -- a hack because then the substitution wouldn't be idempotent
1546 -- any more (v is an OutId). And this does just as well.
1548 Cast (Var v) co -> (addBinderUnfolding env1 v rhs, case_bndr')
1550 rhs = Cast (Var case_bndr') (mkSymCoercion co)
1552 _ -> (env, case_bndr)
1554 case_bndr' = zapOccInfo case_bndr
1555 env1 = modifyInScope env case_bndr case_bndr'
1558 zapOccInfo :: InId -> InId -- See Note [zapOccInfo]
1559 zapOccInfo b = b `setIdOccInfo` NoOccInfo
1563 simplAlts does two things:
1565 1. Eliminate alternatives that cannot match, including the
1566 DEFAULT alternative.
1568 2. If the DEFAULT alternative can match only one possible constructor,
1569 then make that constructor explicit.
1571 case e of x { DEFAULT -> rhs }
1573 case e of x { (a,b) -> rhs }
1574 where the type is a single constructor type. This gives better code
1575 when rhs also scrutinises x or e.
1577 Here "cannot match" includes knowledge from GADTs
1579 It's a good idea do do this stuff before simplifying the alternatives, to
1580 avoid simplifying alternatives we know can't happen, and to come up with
1581 the list of constructors that are handled, to put into the IdInfo of the
1582 case binder, for use when simplifying the alternatives.
1584 Eliminating the default alternative in (1) isn't so obvious, but it can
1587 data Colour = Red | Green | Blue
1596 DEFAULT -> [ case y of ... ]
1598 If we inline h into f, the default case of the inlined h can't happen.
1599 If we don't notice this, we may end up filtering out *all* the cases
1600 of the inner case y, which give us nowhere to go!
1604 simplAlts :: SimplEnv
1606 -> InId -- Case binder
1607 -> [InAlt] -- Non-empty
1609 -> SimplM (OutExpr, OutId, [OutAlt]) -- Includes the continuation
1610 -- Like simplExpr, this just returns the simplified alternatives;
1611 -- it not return an environment
1613 simplAlts env scrut case_bndr alts cont'
1614 = -- pprTrace "simplAlts" (ppr alts $$ ppr (seIdSubst env)) $
1615 do { let alt_env = zapFloats env
1616 ; (alt_env', scrut', case_bndr') <- simplCaseBinder alt_env scrut case_bndr alts
1618 ; (imposs_deflt_cons, in_alts) <- prepareAlts alt_env' scrut case_bndr' alts
1620 ; alts' <- mapM (simplAlt alt_env' imposs_deflt_cons case_bndr' cont') in_alts
1621 ; return (scrut', case_bndr', alts') }
1623 ------------------------------------
1624 simplAlt :: SimplEnv
1625 -> [AltCon] -- These constructors can't be present when
1626 -- matching the DEFAULT alternative
1627 -> OutId -- The case binder
1632 simplAlt env imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs)
1633 = ASSERT( null bndrs )
1634 do { let env' = addBinderOtherCon env case_bndr' imposs_deflt_cons
1635 -- Record the constructors that the case-binder *can't* be.
1636 ; rhs' <- simplExprC env' rhs cont'
1637 ; return (DEFAULT, [], rhs') }
1639 simplAlt env _ case_bndr' cont' (LitAlt lit, bndrs, rhs)
1640 = ASSERT( null bndrs )
1641 do { let env' = addBinderUnfolding env case_bndr' (Lit lit)
1642 ; rhs' <- simplExprC env' rhs cont'
1643 ; return (LitAlt lit, [], rhs') }
1645 simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs)
1646 = do { -- Deal with the pattern-bound variables
1647 -- Mark the ones that are in ! positions in the
1648 -- data constructor as certainly-evaluated.
1649 -- NB: simplLamBinders preserves this eval info
1650 let vs_with_evals = add_evals (dataConRepStrictness con)
1651 ; (env', vs') <- simplLamBndrs env vs_with_evals
1653 -- Bind the case-binder to (con args)
1654 ; let inst_tys' = tyConAppArgs (idType case_bndr')
1655 con_args = map Type inst_tys' ++ varsToCoreExprs vs'
1656 env'' = addBinderUnfolding env' case_bndr'
1657 (mkConApp con con_args)
1659 ; rhs' <- simplExprC env'' rhs cont'
1660 ; return (DataAlt con, vs', rhs') }
1662 -- add_evals records the evaluated-ness of the bound variables of
1663 -- a case pattern. This is *important*. Consider
1664 -- data T = T !Int !Int
1666 -- case x of { T a b -> T (a+1) b }
1668 -- We really must record that b is already evaluated so that we don't
1669 -- go and re-evaluate it when constructing the result.
1670 -- See Note [Data-con worker strictness] in MkId.lhs
1675 go (v:vs') strs | isTyVar v = v : go vs' strs
1676 go (v:vs') (str:strs)
1677 | isMarkedStrict str = evald_v : go vs' strs
1678 | otherwise = zapped_v : go vs' strs
1680 zapped_v = zap_occ_info v
1681 evald_v = zapped_v `setIdUnfolding` evaldUnfolding
1682 go _ _ = pprPanic "cat_evals" (ppr con $$ ppr vs $$ ppr the_strs)
1684 -- zap_occ_info: if the case binder is alive, then we add the unfolding
1686 -- to the envt; so vs are now very much alive
1687 -- Note [Aug06] I can't see why this actually matters, but it's neater
1688 -- case e of t { (a,b) -> ...(case t of (p,q) -> p)... }
1689 -- ==> case e of t { (a,b) -> ...(a)... }
1690 -- Look, Ma, a is alive now.
1691 zap_occ_info | isDeadBinder case_bndr' = \ident -> ident
1692 | otherwise = zapOccInfo
1694 addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv
1695 addBinderUnfolding env bndr rhs
1696 = modifyInScope env bndr (bndr `setIdUnfolding` mkUnfolding False rhs)
1698 addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv
1699 addBinderOtherCon env bndr cons
1700 = modifyInScope env bndr (bndr `setIdUnfolding` mkOtherCon cons)
1704 %************************************************************************
1706 \subsection{Known constructor}
1708 %************************************************************************
1710 We are a bit careful with occurrence info. Here's an example
1712 (\x* -> case x of (a*, b) -> f a) (h v, e)
1714 where the * means "occurs once". This effectively becomes
1715 case (h v, e) of (a*, b) -> f a)
1717 let a* = h v; b = e in f a
1721 All this should happen in one sweep.
1724 knownCon :: SimplEnv -> OutExpr -> AltCon
1725 -> [OutExpr] -- Args *including* the universal args
1726 -> InId -> [InAlt] -> SimplCont
1727 -> SimplM (SimplEnv, OutExpr)
1729 knownCon env scrut con args bndr alts cont
1730 = do { tick (KnownBranch bndr)
1731 ; knownAlt env scrut args bndr (findAlt con alts) cont }
1733 knownAlt :: SimplEnv -> OutExpr -> [OutExpr]
1734 -> InId -> (AltCon, [CoreBndr], InExpr) -> SimplCont
1735 -> SimplM (SimplEnv, OutExpr)
1736 knownAlt env scrut _ bndr (DEFAULT, bs, rhs) cont
1738 do { env' <- simplNonRecX env bndr scrut
1739 -- This might give rise to a binding with non-atomic args
1740 -- like x = Node (f x) (g x)
1741 -- but simplNonRecX will atomic-ify it
1742 ; simplExprF env' rhs cont }
1744 knownAlt env scrut _ bndr (LitAlt _, bs, rhs) cont
1746 do { env' <- simplNonRecX env bndr scrut
1747 ; simplExprF env' rhs cont }
1749 knownAlt env scrut the_args bndr (DataAlt dc, bs, rhs) cont
1750 = do { let dead_bndr = isDeadBinder bndr -- bndr is an InId
1751 n_drop_tys = length (dataConUnivTyVars dc)
1752 ; env' <- bind_args env dead_bndr bs (drop n_drop_tys the_args)
1754 -- It's useful to bind bndr to scrut, rather than to a fresh
1755 -- binding x = Con arg1 .. argn
1756 -- because very often the scrut is a variable, so we avoid
1757 -- creating, and then subsequently eliminating, a let-binding
1758 -- BUT, if scrut is a not a variable, we must be careful
1759 -- about duplicating the arg redexes; in that case, make
1760 -- a new con-app from the args
1761 bndr_rhs = case scrut of
1764 con_app = mkConApp dc (take n_drop_tys the_args ++ con_args)
1765 con_args = [substExpr env' (varToCoreExpr b) | b <- bs]
1766 -- args are aready OutExprs, but bs are InIds
1768 ; env'' <- simplNonRecX env' bndr bndr_rhs
1769 ; -- pprTrace "knownCon2" (ppr bs $$ ppr rhs $$ ppr (seIdSubst env'')) $
1770 simplExprF env'' rhs cont }
1773 bind_args env' _ [] _ = return env'
1775 bind_args env' dead_bndr (b:bs') (Type ty : args)
1776 = ASSERT( isTyVar b )
1777 bind_args (extendTvSubst env' b ty) dead_bndr bs' args
1779 bind_args env' dead_bndr (b:bs') (arg : args)
1781 do { let b' = if dead_bndr then b else zapOccInfo b
1782 -- Note that the binder might be "dead", because it doesn't
1783 -- occur in the RHS; and simplNonRecX may therefore discard
1784 -- it via postInlineUnconditionally.
1785 -- Nevertheless we must keep it if the case-binder is alive,
1786 -- because it may be used in the con_app. See Note [zapOccInfo]
1787 ; env'' <- simplNonRecX env' b' arg
1788 ; bind_args env'' dead_bndr bs' args }
1791 pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr the_args $$
1792 text "scrut:" <+> ppr scrut
1796 %************************************************************************
1798 \subsection{Duplicating continuations}
1800 %************************************************************************
1803 prepareCaseCont :: SimplEnv
1804 -> [InAlt] -> SimplCont
1805 -> SimplM (SimplEnv, SimplCont,SimplCont)
1806 -- Return a duplicatable continuation, a non-duplicable part
1807 -- plus some extra bindings (that scope over the entire
1810 -- No need to make it duplicatable if there's only one alternative
1811 prepareCaseCont env [_] cont = return (env, cont, mkBoringStop)
1812 prepareCaseCont env _ cont = mkDupableCont env cont
1816 mkDupableCont :: SimplEnv -> SimplCont
1817 -> SimplM (SimplEnv, SimplCont, SimplCont)
1819 mkDupableCont env cont
1820 | contIsDupable cont
1821 = return (env, cont, mkBoringStop)
1823 mkDupableCont _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn
1825 mkDupableCont env (CoerceIt ty cont)
1826 = do { (env', dup, nodup) <- mkDupableCont env cont
1827 ; return (env', CoerceIt ty dup, nodup) }
1829 mkDupableCont env cont@(StrictBind {})
1830 = return (env, mkBoringStop, cont)
1831 -- See Note [Duplicating strict continuations]
1833 mkDupableCont env cont@(StrictArg {})
1834 = return (env, mkBoringStop, cont)
1835 -- See Note [Duplicating strict continuations]
1837 mkDupableCont env (ApplyTo _ arg se cont)
1838 = -- e.g. [...hole...] (...arg...)
1840 -- let a = ...arg...
1841 -- in [...hole...] a
1842 do { (env', dup_cont, nodup_cont) <- mkDupableCont env cont
1843 ; arg' <- simplExpr (se `setInScope` env') arg
1844 ; (env'', arg'') <- makeTrivial env' arg'
1845 ; let app_cont = ApplyTo OkToDup arg'' (zapSubstEnv env') dup_cont
1846 ; return (env'', app_cont, nodup_cont) }
1848 mkDupableCont env cont@(Select _ case_bndr [(_, bs, _rhs)] _ _)
1849 -- See Note [Single-alternative case]
1850 -- | not (exprIsDupable rhs && contIsDupable case_cont)
1851 -- | not (isDeadBinder case_bndr)
1852 | all isDeadBinder bs -- InIds
1853 && not (isUnLiftedType (idType case_bndr))
1854 -- Note [Single-alternative-unlifted]
1855 = return (env, mkBoringStop, cont)
1857 mkDupableCont env (Select _ case_bndr alts se cont)
1858 = -- e.g. (case [...hole...] of { pi -> ei })
1860 -- let ji = \xij -> ei
1861 -- in case [...hole...] of { pi -> ji xij }
1862 do { tick (CaseOfCase case_bndr)
1863 ; (env', dup_cont, nodup_cont) <- mkDupableCont env cont
1864 -- NB: call mkDupableCont here, *not* prepareCaseCont
1865 -- We must make a duplicable continuation, whereas prepareCaseCont
1866 -- doesn't when there is a single case branch
1868 ; let alt_env = se `setInScope` env'
1869 ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr
1870 ; alts' <- mapM (simplAlt alt_env' [] case_bndr' dup_cont) alts
1871 -- Safe to say that there are no handled-cons for the DEFAULT case
1872 -- NB: simplBinder does not zap deadness occ-info, so
1873 -- a dead case_bndr' will still advertise its deadness
1874 -- This is really important because in
1875 -- case e of b { (# p,q #) -> ... }
1876 -- b is always dead, and indeed we are not allowed to bind b to (# p,q #),
1877 -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.
1878 -- In the new alts we build, we have the new case binder, so it must retain
1880 -- NB: we don't use alt_env further; it has the substEnv for
1881 -- the alternatives, and we don't want that
1883 ; (env'', alts'') <- mkDupableAlts env' case_bndr' alts'
1884 ; return (env'', -- Note [Duplicated env]
1885 Select OkToDup case_bndr' alts'' (zapSubstEnv env'') mkBoringStop,
1889 mkDupableAlts :: SimplEnv -> OutId -> [InAlt]
1890 -> SimplM (SimplEnv, [InAlt])
1891 -- Absorbs the continuation into the new alternatives
1893 mkDupableAlts env case_bndr' the_alts
1896 go env0 [] = return (env0, [])
1898 = do { (env1, alt') <- mkDupableAlt env0 case_bndr' alt
1899 ; (env2, alts') <- go env1 alts
1900 ; return (env2, alt' : alts' ) }
1902 mkDupableAlt :: SimplEnv -> OutId -> (AltCon, [CoreBndr], CoreExpr)
1903 -> SimplM (SimplEnv, (AltCon, [CoreBndr], CoreExpr))
1904 mkDupableAlt env case_bndr' (con, bndrs', rhs')
1905 | exprIsDupable rhs' -- Note [Small alternative rhs]
1906 = return (env, (con, bndrs', rhs'))
1908 = do { let rhs_ty' = exprType rhs'
1909 used_bndrs' = filter abstract_over (case_bndr' : bndrs')
1911 | isTyVar bndr = True -- Abstract over all type variables just in case
1912 | otherwise = not (isDeadBinder bndr)
1913 -- The deadness info on the new Ids is preserved by simplBinders
1915 ; (final_bndrs', final_args) -- Note [Join point abstraction]
1916 <- if (any isId used_bndrs')
1917 then return (used_bndrs', varsToCoreExprs used_bndrs')
1918 else do { rw_id <- newId (fsLit "w") realWorldStatePrimTy
1919 ; return ([rw_id], [Var realWorldPrimId]) }
1921 ; join_bndr <- newId (fsLit "$j") (mkPiTypes final_bndrs' rhs_ty')
1922 -- Note [Funky mkPiTypes]
1924 ; let -- We make the lambdas into one-shot-lambdas. The
1925 -- join point is sure to be applied at most once, and doing so
1926 -- prevents the body of the join point being floated out by
1927 -- the full laziness pass
1928 really_final_bndrs = map one_shot final_bndrs'
1929 one_shot v | isId v = setOneShotLambda v
1931 join_rhs = mkLams really_final_bndrs rhs'
1932 join_call = mkApps (Var join_bndr) final_args
1934 ; return (addPolyBind NotTopLevel env (NonRec join_bndr join_rhs), (con, bndrs', join_call)) }
1935 -- See Note [Duplicated env]
1938 Note [Duplicated env]
1939 ~~~~~~~~~~~~~~~~~~~~~
1940 Some of the alternatives are simplified, but have not been turned into a join point
1941 So they *must* have an zapped subst-env. So we can't use completeNonRecX to
1942 bind the join point, because it might to do PostInlineUnconditionally, and
1943 we'd lose that when zapping the subst-env. We could have a per-alt subst-env,
1944 but zapping it (as we do in mkDupableCont, the Select case) is safe, and
1945 at worst delays the join-point inlining.
1947 Note [Small alterantive rhs]
1948 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1949 It is worth checking for a small RHS because otherwise we
1950 get extra let bindings that may cause an extra iteration of the simplifier to
1951 inline back in place. Quite often the rhs is just a variable or constructor.
1952 The Ord instance of Maybe in PrelMaybe.lhs, for example, took several extra
1953 iterations because the version with the let bindings looked big, and so wasn't
1954 inlined, but after the join points had been inlined it looked smaller, and so
1957 NB: we have to check the size of rhs', not rhs.
1958 Duplicating a small InAlt might invalidate occurrence information
1959 However, if it *is* dupable, we return the *un* simplified alternative,
1960 because otherwise we'd need to pair it up with an empty subst-env....
1961 but we only have one env shared between all the alts.
1962 (Remember we must zap the subst-env before re-simplifying something).
1963 Rather than do this we simply agree to re-simplify the original (small) thing later.
1965 Note [Funky mkPiTypes]
1966 ~~~~~~~~~~~~~~~~~~~~~~
1967 Notice the funky mkPiTypes. If the contructor has existentials
1968 it's possible that the join point will be abstracted over
1969 type varaibles as well as term variables.
1970 Example: Suppose we have
1971 data T = forall t. C [t]
1973 case (case e of ...) of
1975 We get the join point
1976 let j :: forall t. [t] -> ...
1977 j = /\t \xs::[t] -> rhs
1979 case (case e of ...) of
1980 C t xs::[t] -> j t xs
1982 Note [Join point abstaction]
1983 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1984 If we try to lift a primitive-typed something out
1985 for let-binding-purposes, we will *caseify* it (!),
1986 with potentially-disastrous strictness results. So
1987 instead we turn it into a function: \v -> e
1988 where v::State# RealWorld#. The value passed to this function
1989 is realworld#, which generates (almost) no code.
1991 There's a slight infelicity here: we pass the overall
1992 case_bndr to all the join points if it's used in *any* RHS,
1993 because we don't know its usage in each RHS separately
1995 We used to say "&& isUnLiftedType rhs_ty'" here, but now
1996 we make the join point into a function whenever used_bndrs'
1997 is empty. This makes the join-point more CPR friendly.
1998 Consider: let j = if .. then I# 3 else I# 4
1999 in case .. of { A -> j; B -> j; C -> ... }
2001 Now CPR doesn't w/w j because it's a thunk, so
2002 that means that the enclosing function can't w/w either,
2003 which is a lose. Here's the example that happened in practice:
2004 kgmod :: Int -> Int -> Int
2005 kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
2009 I have seen a case alternative like this:
2011 It's a bit silly to add the realWorld dummy arg in this case, making
2014 (the \v alone is enough to make CPR happy) but I think it's rare
2016 Note [Duplicating strict continuations]
2017 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2018 Do *not* duplicate StrictBind and StritArg continuations. We gain
2019 nothing by propagating them into the expressions, and we do lose a
2020 lot. Here's an example:
2021 && (case x of { T -> F; F -> T }) E
2022 Now, && is strict so we end up simplifying the case with
2023 an ArgOf continuation. If we let-bind it, we get
2025 let $j = \v -> && v E
2026 in simplExpr (case x of { T -> F; F -> T })
2028 And after simplifying more we get
2030 let $j = \v -> && v E
2031 in case x of { T -> $j F; F -> $j T }
2032 Which is a Very Bad Thing
2034 The desire not to duplicate is the entire reason that
2035 mkDupableCont returns a pair of continuations.
2037 The original plan had:
2038 e.g. (...strict-fn...) [...hole...]
2040 let $j = \a -> ...strict-fn...
2043 Note [Single-alternative cases]
2044 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2045 This case is just like the ArgOf case. Here's an example:
2049 case (case x of I# x' ->
2051 True -> I# (negate# x')
2052 False -> I# x') of y {
2054 Because the (case x) has only one alternative, we'll transform to
2056 case (case x' <# 0# of
2057 True -> I# (negate# x')
2058 False -> I# x') of y {
2060 But now we do *NOT* want to make a join point etc, giving
2062 let $j = \y -> MkT y
2064 True -> $j (I# (negate# x'))
2066 In this case the $j will inline again, but suppose there was a big
2067 strict computation enclosing the orginal call to MkT. Then, it won't
2068 "see" the MkT any more, because it's big and won't get duplicated.
2069 And, what is worse, nothing was gained by the case-of-case transform.
2071 When should use this case of mkDupableCont?
2072 However, matching on *any* single-alternative case is a *disaster*;
2073 e.g. case (case ....) of (a,b) -> (# a,b #)
2074 We must push the outer case into the inner one!
2077 * Match [(DEFAULT,_,_)], but in the common case of Int,
2078 the alternative-filling-in code turned the outer case into
2079 case (...) of y { I# _ -> MkT y }
2081 * Match on single alternative plus (not (isDeadBinder case_bndr))
2082 Rationale: pushing the case inwards won't eliminate the construction.
2083 But there's a risk of
2084 case (...) of y { (a,b) -> let z=(a,b) in ... }
2085 Now y looks dead, but it'll come alive again. Still, this
2086 seems like the best option at the moment.
2088 * Match on single alternative plus (all (isDeadBinder bndrs))
2089 Rationale: this is essentially seq.
2091 * Match when the rhs is *not* duplicable, and hence would lead to a
2092 join point. This catches the disaster-case above. We can test
2093 the *un-simplified* rhs, which is fine. It might get bigger or
2094 smaller after simplification; if it gets smaller, this case might
2095 fire next time round. NB also that we must test contIsDupable
2096 case_cont *btoo, because case_cont might be big!
2098 HOWEVER: I found that this version doesn't work well, because
2099 we can get let x = case (...) of { small } in ...case x...
2100 When x is inlined into its full context, we find that it was a bad
2101 idea to have pushed the outer case inside the (...) case.
2103 Note [Single-alternative-unlifted]
2104 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2105 Here's another single-alternative where we really want to do case-of-case:
2113 case y_s6X of tpl_s7m {
2114 M1.Mk1 ipv_s70 -> ipv_s70;
2115 M1.Mk2 ipv_s72 -> ipv_s72;
2121 case x_s74 of tpl_s7n {
2122 M1.Mk1 ipv_s77 -> ipv_s77;
2123 M1.Mk2 ipv_s79 -> ipv_s79;
2127 { __DEFAULT -> ==# [wild1_s7b wild_s7c];
2131 So the outer case is doing *nothing at all*, other than serving as a
2132 join-point. In this case we really want to do case-of-case and decide
2133 whether to use a real join point or just duplicate the continuation.
2135 Hence: check whether the case binder's type is unlifted, because then
2136 the outer case is *not* a seq.