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 FamInstEnv ( FamInstEnv )
18 import MkId ( mkImpossibleExpr, seqId )
22 import FamInstEnv ( topNormaliseType )
23 import DataCon ( dataConRepStrictness, dataConUnivTyVars )
25 import NewDemand ( isStrictDmd, splitStrictSig )
26 import PprCore ( pprParendExpr, pprCoreExpr )
27 import CoreUnfold ( mkUnfolding, callSiteInline, CallCtxt(..) )
29 import CoreArity ( exprArity )
30 import Rules ( lookupRule, getRules )
31 import BasicTypes ( isMarkedStrict, Arity )
32 import CostCentre ( currentCCS, pushCCisNop )
33 import TysPrim ( realWorldStatePrimTy )
34 import PrelInfo ( realWorldPrimId )
35 import BasicTypes ( TopLevelFlag(..), isTopLevel,
36 RecFlag(..), isNonRuleLoopBreaker )
37 import Maybes ( orElse )
38 import Data.List ( mapAccumL )
44 The guts of the simplifier is in this module, but the driver loop for
45 the simplifier is in SimplCore.lhs.
48 -----------------------------------------
49 *** IMPORTANT NOTE ***
50 -----------------------------------------
51 The simplifier used to guarantee that the output had no shadowing, but
52 it does not do so any more. (Actually, it never did!) The reason is
53 documented with simplifyArgs.
56 -----------------------------------------
57 *** IMPORTANT NOTE ***
58 -----------------------------------------
59 Many parts of the simplifier return a bunch of "floats" as well as an
60 expression. This is wrapped as a datatype SimplUtils.FloatsWith.
62 All "floats" are let-binds, not case-binds, but some non-rec lets may
63 be unlifted (with RHS ok-for-speculation).
67 -----------------------------------------
68 ORGANISATION OF FUNCTIONS
69 -----------------------------------------
71 - simplify all top-level binders
72 - for NonRec, call simplRecOrTopPair
73 - for Rec, call simplRecBind
76 ------------------------------
77 simplExpr (applied lambda) ==> simplNonRecBind
78 simplExpr (Let (NonRec ...) ..) ==> simplNonRecBind
79 simplExpr (Let (Rec ...) ..) ==> simplify binders; simplRecBind
81 ------------------------------
82 simplRecBind [binders already simplfied]
83 - use simplRecOrTopPair on each pair in turn
85 simplRecOrTopPair [binder already simplified]
86 Used for: recursive bindings (top level and nested)
87 top-level non-recursive bindings
89 - check for PreInlineUnconditionally
93 Used for: non-top-level non-recursive bindings
94 beta reductions (which amount to the same thing)
95 Because it can deal with strict arts, it takes a
96 "thing-inside" and returns an expression
98 - check for PreInlineUnconditionally
99 - simplify binder, including its IdInfo
108 simplNonRecX: [given a *simplified* RHS, but an *unsimplified* binder]
109 Used for: binding case-binder and constr args in a known-constructor case
110 - check for PreInLineUnconditionally
114 ------------------------------
115 simplLazyBind: [binder already simplified, RHS not]
116 Used for: recursive bindings (top level and nested)
117 top-level non-recursive bindings
118 non-top-level, but *lazy* non-recursive bindings
119 [must not be strict or unboxed]
120 Returns floats + an augmented environment, not an expression
121 - substituteIdInfo and add result to in-scope
122 [so that rules are available in rec rhs]
125 - float if exposes constructor or PAP
129 completeNonRecX: [binder and rhs both simplified]
130 - if the the thing needs case binding (unlifted and not ok-for-spec)
136 completeBind: [given a simplified RHS]
137 [used for both rec and non-rec bindings, top level and not]
138 - try PostInlineUnconditionally
139 - add unfolding [this is the only place we add an unfolding]
144 Right hand sides and arguments
145 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
146 In many ways we want to treat
147 (a) the right hand side of a let(rec), and
148 (b) a function argument
149 in the same way. But not always! In particular, we would
150 like to leave these arguments exactly as they are, so they
151 will match a RULE more easily.
156 It's harder to make the rule match if we ANF-ise the constructor,
157 or eta-expand the PAP:
159 f (let { a = g x; b = h x } in (a,b))
162 On the other hand if we see the let-defns
167 then we *do* want to ANF-ise and eta-expand, so that p and q
168 can be safely inlined.
170 Even floating lets out is a bit dubious. For let RHS's we float lets
171 out if that exposes a value, so that the value can be inlined more vigorously.
174 r = let x = e in (x,x)
176 Here, if we float the let out we'll expose a nice constructor. We did experiments
177 that showed this to be a generally good thing. But it was a bad thing to float
178 lets out unconditionally, because that meant they got allocated more often.
180 For function arguments, there's less reason to expose a constructor (it won't
181 get inlined). Just possibly it might make a rule match, but I'm pretty skeptical.
182 So for the moment we don't float lets out of function arguments either.
187 For eta expansion, we want to catch things like
189 case e of (a,b) -> \x -> case a of (p,q) -> \y -> r
191 If the \x was on the RHS of a let, we'd eta expand to bring the two
192 lambdas together. And in general that's a good thing to do. Perhaps
193 we should eta expand wherever we find a (value) lambda? Then the eta
194 expansion at a let RHS can concentrate solely on the PAP case.
197 %************************************************************************
199 \subsection{Bindings}
201 %************************************************************************
204 simplTopBinds :: SimplEnv -> [InBind] -> SimplM [OutBind]
206 simplTopBinds env0 binds0
207 = do { -- Put all the top-level binders into scope at the start
208 -- so that if a transformation rule has unexpectedly brought
209 -- anything into scope, then we don't get a complaint about that.
210 -- It's rather as if the top-level binders were imported.
211 ; env1 <- simplRecBndrs env0 (bindersOfBinds binds0)
212 ; dflags <- getDOptsSmpl
213 ; let dump_flag = dopt Opt_D_dump_inlinings dflags ||
214 dopt Opt_D_dump_rule_firings dflags
215 ; env2 <- simpl_binds dump_flag env1 binds0
216 ; freeTick SimplifierDone
217 ; return (getFloats env2) }
219 -- We need to track the zapped top-level binders, because
220 -- they should have their fragile IdInfo zapped (notably occurrence info)
221 -- That's why we run down binds and bndrs' simultaneously.
223 -- The dump-flag emits a trace for each top-level binding, which
224 -- helps to locate the tracing for inlining and rule firing
225 simpl_binds :: Bool -> SimplEnv -> [InBind] -> SimplM SimplEnv
226 simpl_binds _ env [] = return env
227 simpl_binds dump env (bind:binds) = do { env' <- trace_bind dump bind $
229 ; simpl_binds dump env' binds }
231 trace_bind True bind = pprTrace "SimplBind" (ppr (bindersOf bind))
232 trace_bind False _ = \x -> x
234 simpl_bind env (Rec pairs) = simplRecBind env TopLevel pairs
235 simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel b b' r
237 (env', b') = addBndrRules env b (lookupRecBndr env b)
241 %************************************************************************
243 \subsection{Lazy bindings}
245 %************************************************************************
247 simplRecBind is used for
248 * recursive bindings only
251 simplRecBind :: SimplEnv -> TopLevelFlag
254 simplRecBind env0 top_lvl pairs0
255 = do { let (env_with_info, triples) = mapAccumL add_rules env0 pairs0
256 ; env1 <- go (zapFloats env_with_info) triples
257 ; return (env0 `addRecFloats` env1) }
258 -- addFloats adds the floats from env1,
259 -- _and_ updates env0 with the in-scope set from env1
261 add_rules :: SimplEnv -> (InBndr,InExpr) -> (SimplEnv, (InBndr, OutBndr, InExpr))
262 -- Add the (substituted) rules to the binder
263 add_rules env (bndr, rhs) = (env', (bndr, bndr', rhs))
265 (env', bndr') = addBndrRules env bndr (lookupRecBndr env bndr)
267 go env [] = return env
269 go env ((old_bndr, new_bndr, rhs) : pairs)
270 = do { env' <- simplRecOrTopPair env top_lvl old_bndr new_bndr rhs
274 simplOrTopPair is used for
275 * recursive bindings (whether top level or not)
276 * top-level non-recursive bindings
278 It assumes the binder has already been simplified, but not its IdInfo.
281 simplRecOrTopPair :: SimplEnv
283 -> InId -> OutBndr -> InExpr -- Binder and rhs
284 -> SimplM SimplEnv -- Returns an env that includes the binding
286 simplRecOrTopPair env top_lvl old_bndr new_bndr rhs
287 | preInlineUnconditionally env top_lvl old_bndr rhs -- Check for unconditional inline
288 = do { tick (PreInlineUnconditionally old_bndr)
289 ; return (extendIdSubst env old_bndr (mkContEx env rhs)) }
292 = simplLazyBind env top_lvl Recursive old_bndr new_bndr rhs env
293 -- May not actually be recursive, but it doesn't matter
297 simplLazyBind is used for
298 * [simplRecOrTopPair] recursive bindings (whether top level or not)
299 * [simplRecOrTopPair] top-level non-recursive bindings
300 * [simplNonRecE] non-top-level *lazy* non-recursive bindings
303 1. It assumes that the binder is *already* simplified,
304 and is in scope, and its IdInfo too, except unfolding
306 2. It assumes that the binder type is lifted.
308 3. It does not check for pre-inline-unconditionallly;
309 that should have been done already.
312 simplLazyBind :: SimplEnv
313 -> TopLevelFlag -> RecFlag
314 -> InId -> OutId -- Binder, both pre-and post simpl
315 -- The OutId has IdInfo, except arity, unfolding
316 -> InExpr -> SimplEnv -- The RHS and its environment
319 simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
320 = do { let rhs_env = rhs_se `setInScope` env
321 (tvs, body) = case collectTyBinders rhs of
322 (tvs, body) | not_lam body -> (tvs,body)
323 | otherwise -> ([], rhs)
324 not_lam (Lam _ _) = False
326 -- Do not do the "abstract tyyvar" thing if there's
327 -- a lambda inside, becuase it defeats eta-reduction
328 -- f = /\a. \x. g a x
331 ; (body_env, tvs') <- simplBinders rhs_env tvs
332 -- See Note [Floating and type abstraction] in SimplUtils
335 ; (body_env1, body1) <- simplExprF body_env body mkBoringStop
337 -- ANF-ise a constructor or PAP rhs
338 ; (body_env2, body2) <- prepareRhs body_env1 body1
341 <- if not (doFloatFromRhs top_lvl is_rec False body2 body_env2)
342 then -- No floating, just wrap up!
343 do { rhs' <- mkLam env tvs' (wrapFloats body_env2 body2)
344 ; return (env, rhs') }
346 else if null tvs then -- Simple floating
347 do { tick LetFloatFromLet
348 ; return (addFloats env body_env2, body2) }
350 else -- Do type-abstraction first
351 do { tick LetFloatFromLet
352 ; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2
353 ; rhs' <- mkLam env tvs' body3
354 ; let env' = foldl (addPolyBind top_lvl) env poly_binds
355 ; return (env', rhs') }
357 ; completeBind env' top_lvl bndr bndr1 rhs' }
360 A specialised variant of simplNonRec used when the RHS is already simplified,
361 notably in knownCon. It uses case-binding where necessary.
364 simplNonRecX :: SimplEnv
365 -> InId -- Old binder
366 -> OutExpr -- Simplified RHS
369 simplNonRecX env bndr new_rhs
370 | isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of b { (p,q) -> p }
371 = return env -- Here b is dead, and we avoid creating
372 | otherwise -- the binding b = (a,b)
373 = do { (env', bndr') <- simplBinder env bndr
374 ; completeNonRecX env' (isStrictId bndr) bndr bndr' new_rhs }
376 completeNonRecX :: SimplEnv
378 -> InId -- Old binder
379 -> OutId -- New binder
380 -> OutExpr -- Simplified RHS
383 completeNonRecX env is_strict old_bndr new_bndr new_rhs
384 = do { (env1, rhs1) <- prepareRhs (zapFloats env) new_rhs
386 if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1
387 then do { tick LetFloatFromLet
388 ; return (addFloats env env1, rhs1) } -- Add the floats to the main env
389 else return (env, wrapFloats env1 rhs1) -- Wrap the floats around the RHS
390 ; completeBind env2 NotTopLevel old_bndr new_bndr rhs2 }
393 {- No, no, no! Do not try preInlineUnconditionally in completeNonRecX
394 Doing so risks exponential behaviour, because new_rhs has been simplified once already
395 In the cases described by the folowing commment, postInlineUnconditionally will
396 catch many of the relevant cases.
397 -- This happens; for example, the case_bndr during case of
398 -- known constructor: case (a,b) of x { (p,q) -> ... }
399 -- Here x isn't mentioned in the RHS, so we don't want to
400 -- create the (dead) let-binding let x = (a,b) in ...
402 -- Similarly, single occurrences can be inlined vigourously
403 -- e.g. case (f x, g y) of (a,b) -> ....
404 -- If a,b occur once we can avoid constructing the let binding for them.
406 Furthermore in the case-binding case preInlineUnconditionally risks extra thunks
407 -- Consider case I# (quotInt# x y) of
408 -- I# v -> let w = J# v in ...
409 -- If we gaily inline (quotInt# x y) for v, we end up building an
411 -- let w = J# (quotInt# x y) in ...
412 -- because quotInt# can fail.
414 | preInlineUnconditionally env NotTopLevel bndr new_rhs
415 = thing_inside (extendIdSubst env bndr (DoneEx new_rhs))
418 ----------------------------------
419 prepareRhs takes a putative RHS, checks whether it's a PAP or
420 constructor application and, if so, converts it to ANF, so that the
421 resulting thing can be inlined more easily. Thus
428 We also want to deal well cases like this
429 v = (f e1 `cast` co) e2
430 Here we want to make e1,e2 trivial and get
431 x1 = e1; x2 = e2; v = (f x1 `cast` co) v2
432 That's what the 'go' loop in prepareRhs does
435 prepareRhs :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
436 -- Adds new floats to the env iff that allows us to return a good RHS
437 prepareRhs env (Cast rhs co) -- Note [Float coercions]
438 | (ty1, _ty2) <- coercionKind co -- Do *not* do this if rhs has an unlifted type
439 , not (isUnLiftedType ty1) -- see Note [Float coercions (unlifted)]
440 = do { (env', rhs') <- makeTrivial env rhs
441 ; return (env', Cast rhs' co) }
444 = do { (_is_val, env1, rhs1) <- go 0 env0 rhs0
445 ; return (env1, rhs1) }
447 go n_val_args env (Cast rhs co)
448 = do { (is_val, env', rhs') <- go n_val_args env rhs
449 ; return (is_val, env', Cast rhs' co) }
450 go n_val_args env (App fun (Type ty))
451 = do { (is_val, env', rhs') <- go n_val_args env fun
452 ; return (is_val, env', App rhs' (Type ty)) }
453 go n_val_args env (App fun arg)
454 = do { (is_val, env', fun') <- go (n_val_args+1) env fun
456 True -> do { (env'', arg') <- makeTrivial env' arg
457 ; return (True, env'', App fun' arg') }
458 False -> return (False, env, App fun arg) }
459 go n_val_args env (Var fun)
460 = return (is_val, env, Var fun)
462 is_val = n_val_args > 0 -- There is at least one arg
463 -- ...and the fun a constructor or PAP
464 && (isConLikeId fun || n_val_args < idArity fun)
466 = return (False, env, other)
470 Note [Float coercions]
471 ~~~~~~~~~~~~~~~~~~~~~~
472 When we find the binding
474 we'd like to transform it to
476 x = x `cast` co -- A trivial binding
477 There's a chance that e will be a constructor application or function, or something
478 like that, so moving the coerion to the usage site may well cancel the coersions
479 and lead to further optimisation. Example:
482 data instance T Int = T Int
484 foo :: Int -> Int -> Int
489 go n = case x of { T m -> go (n-m) }
490 -- This case should optimise
492 Note [Float coercions (unlifted)]
493 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
494 BUT don't do [Float coercions] if 'e' has an unlifted type.
497 foo :: Int = (error (# Int,Int #) "urk")
498 `cast` CoUnsafe (# Int,Int #) Int
500 If do the makeTrivial thing to the error call, we'll get
501 foo = case error (# Int,Int #) "urk" of v -> v `cast` ...
502 But 'v' isn't in scope!
504 These strange casts can happen as a result of case-of-case
505 bar = case (case x of { T -> (# 2,3 #); F -> error "urk" }) of
510 makeTrivial :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
511 -- Binds the expression to a variable, if it's not trivial, returning the variable
515 | otherwise -- See Note [Take care] below
516 = do { var <- newId (fsLit "a") (exprType expr)
517 ; env' <- completeNonRecX env False var var expr
518 -- pprTrace "makeTrivial" (vcat [ppr var <+> ppr (exprArity (substExpr env' (Var var)))
520 -- , ppr (substExpr env' (Var var))
521 -- , ppr (idArity (fromJust (lookupInScope (seInScope env') var))) ]) $
522 ; return (env', substExpr env' (Var var)) }
523 -- The substitution is needed becase we're constructing a new binding
525 -- And if rhs is of form (rhs1 |> co), then we might get
528 -- and now a's RHS is trivial and can be substituted out, and that
529 -- is what completeNonRecX will do
533 %************************************************************************
535 \subsection{Completing a lazy binding}
537 %************************************************************************
540 * deals only with Ids, not TyVars
541 * takes an already-simplified binder and RHS
542 * is used for both recursive and non-recursive bindings
543 * is used for both top-level and non-top-level bindings
545 It does the following:
546 - tries discarding a dead binding
547 - tries PostInlineUnconditionally
548 - add unfolding [this is the only place we add an unfolding]
551 It does *not* attempt to do let-to-case. Why? Because it is used for
552 - top-level bindings (when let-to-case is impossible)
553 - many situations where the "rhs" is known to be a WHNF
554 (so let-to-case is inappropriate).
556 Nor does it do the atomic-argument thing
559 completeBind :: SimplEnv
560 -> TopLevelFlag -- Flag stuck into unfolding
561 -> InId -- Old binder
562 -> OutId -> OutExpr -- New binder and RHS
564 -- completeBind may choose to do its work
565 -- * by extending the substitution (e.g. let x = y in ...)
566 -- * or by adding to the floats in the envt
568 completeBind env top_lvl old_bndr new_bndr new_rhs
569 | postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs unfolding
570 -- Inline and discard the binding
571 = do { tick (PostInlineUnconditionally old_bndr)
572 ; -- pprTrace "postInlineUnconditionally" (ppr old_bndr <+> ppr new_bndr <+> ppr new_rhs) $
573 return (extendIdSubst env old_bndr (DoneEx new_rhs)) }
574 -- Use the substitution to make quite, quite sure that the
575 -- substitution will happen, since we are going to discard the binding
578 = return (addNonRecWithUnf env new_bndr new_rhs unfolding wkr)
580 unfolding | omit_unfolding = NoUnfolding
581 | otherwise = mkUnfolding (isTopLevel top_lvl) new_rhs
582 old_info = idInfo old_bndr
583 occ_info = occInfo old_info
584 wkr = substWorker env (workerInfo old_info)
585 omit_unfolding = isNonRuleLoopBreaker occ_info
586 -- or not (activeInline env old_bndr)
587 -- Do *not* trim the unfolding in SimplGently, else
588 -- the specialiser can't see it!
591 addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplEnv
592 -- Add a new binding to the environment, complete with its unfolding
593 -- but *do not* do postInlineUnconditionally, because we have already
594 -- processed some of the scope of the binding
595 -- We still want the unfolding though. Consider
597 -- x = /\a. let y = ... in Just y
599 -- Then we float the y-binding out (via abstractFloats and addPolyBind)
600 -- but 'x' may well then be inlined in 'body' in which case we'd like the
601 -- opportunity to inline 'y' too.
603 addPolyBind top_lvl env (NonRec poly_id rhs)
604 = addNonRecWithUnf env poly_id rhs unfolding NoWorker
606 unfolding | not (activeInline env poly_id) = NoUnfolding
607 | otherwise = mkUnfolding (isTopLevel top_lvl) rhs
608 -- addNonRecWithInfo adds the new binding in the
609 -- proper way (ie complete with unfolding etc),
610 -- and extends the in-scope set
612 addPolyBind _ env bind@(Rec _) = extendFloats env bind
613 -- Hack: letrecs are more awkward, so we extend "by steam"
614 -- without adding unfoldings etc. At worst this leads to
615 -- more simplifier iterations
618 addNonRecWithUnf :: SimplEnv
619 -> OutId -> OutExpr -- New binder and RHS
620 -> Unfolding -> WorkerInfo -- and unfolding
622 -- Add suitable IdInfo to the Id, add the binding to the floats, and extend the in-scope set
623 addNonRecWithUnf env new_bndr rhs unfolding wkr
624 = ASSERT( isId new_bndr )
625 WARN( new_arity < old_arity || new_arity < dmd_arity,
626 (ptext (sLit "Arity decrease:") <+> ppr final_id <+> ppr old_arity
627 <+> ppr new_arity <+> ppr dmd_arity) $$ ppr rhs )
628 -- Note [Arity decrease]
629 final_id `seq` -- This seq forces the Id, and hence its IdInfo,
630 -- and hence any inner substitutions
631 addNonRec env final_id rhs
632 -- The addNonRec adds it to the in-scope set too
634 dmd_arity = length $ fst $ splitStrictSig $ idNewStrictness new_bndr
635 old_arity = idArity new_bndr
638 new_arity = exprArity rhs
639 new_bndr_info = idInfo new_bndr `setArityInfo` new_arity
642 -- Add the unfolding *only* for non-loop-breakers
643 -- Making loop breakers not have an unfolding at all
644 -- means that we can avoid tests in exprIsConApp, for example.
645 -- This is important: if exprIsConApp says 'yes' for a recursive
646 -- thing, then we can get into an infinite loop
649 -- If the unfolding is a value, the demand info may
650 -- go pear-shaped, so we nuke it. Example:
652 -- case x of (p,q) -> h p q x
653 -- Here x is certainly demanded. But after we've nuked
654 -- the case, we'll get just
655 -- let x = (a,b) in h a b x
656 -- and now x is not demanded (I'm assuming h is lazy)
657 -- This really happens. Similarly
658 -- let f = \x -> e in ...f..f...
659 -- After inlining f at some of its call sites the original binding may
660 -- (for example) be no longer strictly demanded.
661 -- The solution here is a bit ad hoc...
662 info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding
665 final_info | isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf
666 | otherwise = info_w_unf
668 final_id = new_bndr `setIdInfo` final_info
671 Note [Arity decrease]
672 ~~~~~~~~~~~~~~~~~~~~~
673 Generally speaking the arity of a binding should not decrease. But it *can*
674 legitimately happen becuase of RULES. Eg
676 where g has arity 2, will have arity 2. But if there's a rewrite rule
678 where h has arity 1, then f's arity will decrease. Here's a real-life example,
679 which is in the output of Specialise:
682 $dm {Arity 2} = \d.\x. op d
683 {-# RULES forall d. $dm Int d = $s$dm #-}
685 dInt = MkD .... opInt ...
686 opInt {Arity 1} = $dm dInt
688 $s$dm {Arity 0} = \x. op dInt }
690 Here opInt has arity 1; but when we apply the rule its arity drops to 0.
691 That's why Specialise goes to a little trouble to pin the right arity
692 on specialised functions too.
695 %************************************************************************
697 \subsection[Simplify-simplExpr]{The main function: simplExpr}
699 %************************************************************************
701 The reason for this OutExprStuff stuff is that we want to float *after*
702 simplifying a RHS, not before. If we do so naively we get quadratic
703 behaviour as things float out.
705 To see why it's important to do it after, consider this (real) example:
719 a -- Can't inline a this round, cos it appears twice
723 Each of the ==> steps is a round of simplification. We'd save a
724 whole round if we float first. This can cascade. Consider
729 let f = let d1 = ..d.. in \y -> e
733 in \x -> ...(\y ->e)...
735 Only in this second round can the \y be applied, and it
736 might do the same again.
740 simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
741 simplExpr env expr = simplExprC env expr mkBoringStop
743 simplExprC :: SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr
744 -- Simplify an expression, given a continuation
745 simplExprC env expr cont
746 = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seFloats env) ) $
747 do { (env', expr') <- simplExprF (zapFloats env) expr cont
748 ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $
749 -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $
750 -- pprTrace "simplExprC ret4" (ppr (seFloats env')) $
751 return (wrapFloats env' expr') }
753 --------------------------------------------------
754 simplExprF :: SimplEnv -> InExpr -> SimplCont
755 -> SimplM (SimplEnv, OutExpr)
757 simplExprF env e cont
758 = -- pprTrace "simplExprF" (ppr e $$ ppr cont $$ ppr (seTvSubst env) $$ ppr (seIdSubst env) {- $$ ppr (seFloats env) -} ) $
759 simplExprF' env e cont
761 simplExprF' :: SimplEnv -> InExpr -> SimplCont
762 -> SimplM (SimplEnv, OutExpr)
763 simplExprF' env (Var v) cont = simplVar env v cont
764 simplExprF' env (Lit lit) cont = rebuild env (Lit lit) cont
765 simplExprF' env (Note n expr) cont = simplNote env n expr cont
766 simplExprF' env (Cast body co) cont = simplCast env body co cont
767 simplExprF' env (App fun arg) cont = simplExprF env fun $
768 ApplyTo NoDup arg env cont
770 simplExprF' env expr@(Lam _ _) cont
771 = simplLam env (map zap bndrs) body cont
772 -- The main issue here is under-saturated lambdas
773 -- (\x1. \x2. e) arg1
774 -- Here x1 might have "occurs-once" occ-info, because occ-info
775 -- is computed assuming that a group of lambdas is applied
776 -- all at once. If there are too few args, we must zap the
779 n_args = countArgs cont
780 n_params = length bndrs
781 (bndrs, body) = collectBinders expr
782 zap | n_args >= n_params = \b -> b
783 | otherwise = \b -> if isTyVar b then b
785 -- NB: we count all the args incl type args
786 -- so we must count all the binders (incl type lambdas)
788 simplExprF' env (Type ty) cont
789 = ASSERT( contIsRhsOrArg cont )
790 do { ty' <- simplType env ty
791 ; rebuild env (Type ty') cont }
793 simplExprF' env (Case scrut bndr _ alts) cont
794 | not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
795 = -- Simplify the scrutinee with a Select continuation
796 simplExprF env scrut (Select NoDup bndr alts env cont)
799 = -- If case-of-case is off, simply simplify the case expression
800 -- in a vanilla Stop context, and rebuild the result around it
801 do { case_expr' <- simplExprC env scrut case_cont
802 ; rebuild env case_expr' cont }
804 case_cont = Select NoDup bndr alts env mkBoringStop
806 simplExprF' env (Let (Rec pairs) body) cont
807 = do { env' <- simplRecBndrs env (map fst pairs)
808 -- NB: bndrs' don't have unfoldings or rules
809 -- We add them as we go down
811 ; env'' <- simplRecBind env' NotTopLevel pairs
812 ; simplExprF env'' body cont }
814 simplExprF' env (Let (NonRec bndr rhs) body) cont
815 = simplNonRecE env bndr (rhs, env) ([], body) cont
817 ---------------------------------
818 simplType :: SimplEnv -> InType -> SimplM OutType
819 -- Kept monadic just so we can do the seqType
821 = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $
822 seqType new_ty `seq` return new_ty
824 new_ty = substTy env ty
826 ---------------------------------
827 simplCoercion :: SimplEnv -> InType -> SimplM OutType
829 = do { co' <- simplType env co
830 ; return (optCoercion co') }
834 %************************************************************************
836 \subsection{The main rebuilder}
838 %************************************************************************
841 rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr)
842 -- At this point the substitution in the SimplEnv should be irrelevant
843 -- only the in-scope set and floats should matter
844 rebuild env expr cont0
845 = -- pprTrace "rebuild" (ppr expr $$ ppr cont0 $$ ppr (seFloats env)) $
847 Stop {} -> return (env, expr)
848 CoerceIt co cont -> rebuild env (mkCoerce co expr) cont
849 Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont
850 StrictArg fun _ info cont -> rebuildCall env (fun `App` expr) info cont
851 StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr
852 ; simplLam env' bs body cont }
853 ApplyTo _ arg se cont -> do { arg' <- simplExpr (se `setInScope` env) arg
854 ; rebuild env (App expr arg') cont }
858 %************************************************************************
862 %************************************************************************
865 simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont
866 -> SimplM (SimplEnv, OutExpr)
867 simplCast env body co0 cont0
868 = do { co1 <- simplCoercion env co0
869 ; simplExprF env body (addCoerce co1 cont0) }
871 addCoerce co cont = add_coerce co (coercionKind co) cont
873 add_coerce _co (s1, k1) cont -- co :: ty~ty
874 | s1 `coreEqType` k1 = cont -- is a no-op
876 add_coerce co1 (s1, _k2) (CoerceIt co2 cont)
877 | (_l1, t1) <- coercionKind co2
878 -- e |> (g1 :: S1~L) |> (g2 :: L~T1)
881 -- e |> (g1 . g2 :: S1~T1) otherwise
883 -- For example, in the initial form of a worker
884 -- we may find (coerce T (coerce S (\x.e))) y
885 -- and we'd like it to simplify to e[y/x] in one round
887 , s1 `coreEqType` t1 = cont -- The coerces cancel out
888 | otherwise = CoerceIt (mkTransCoercion co1 co2) cont
890 add_coerce co (s1s2, _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont)
891 -- (f |> g) ty ---> (f ty) |> (g @ ty)
892 -- This implements the PushT rule from the paper
893 | Just (tyvar,_) <- splitForAllTy_maybe s1s2
894 , not (isCoVar tyvar)
895 = ApplyTo dup (Type ty') (zapSubstEnv env) (addCoerce (mkInstCoercion co ty') cont)
897 ty' = substTy (arg_se `setInScope` env) arg_ty
899 -- ToDo: the PushC rule is not implemented at all
901 add_coerce co (s1s2, _t1t2) (ApplyTo dup arg arg_se cont)
902 | not (isTypeArg arg) -- This implements the Push rule from the paper
903 , isFunTy s1s2 -- t1t2 must be a function type, becuase it's applied
904 -- (e |> (g :: s1s2 ~ t1->t2)) f
906 -- (e (f |> (arg g :: t1~s1))
907 -- |> (res g :: s2->t2)
909 -- t1t2 must be a function type, t1->t2, because it's applied
910 -- to something but s1s2 might conceivably not be
912 -- When we build the ApplyTo we can't mix the out-types
913 -- with the InExpr in the argument, so we simply substitute
914 -- to make it all consistent. It's a bit messy.
915 -- But it isn't a common case.
917 -- Example of use: Trac #995
918 = ApplyTo dup new_arg (zapSubstEnv env) (addCoerce co2 cont)
920 -- we split coercion t1->t2 ~ s1->s2 into t1 ~ s1 and
921 -- t2 ~ s2 with left and right on the curried form:
922 -- (->) t1 t2 ~ (->) s1 s2
923 [co1, co2] = decomposeCo 2 co
924 new_arg = mkCoerce (mkSymCoercion co1) arg'
925 arg' = substExpr (arg_se `setInScope` env) arg
927 add_coerce co _ cont = CoerceIt co cont
931 %************************************************************************
935 %************************************************************************
938 simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont
939 -> SimplM (SimplEnv, OutExpr)
941 simplLam env [] body cont = simplExprF env body cont
944 simplLam env (bndr:bndrs) body (ApplyTo _ arg arg_se cont)
945 = do { tick (BetaReduction bndr)
946 ; simplNonRecE env bndr (arg, arg_se) (bndrs, body) cont }
948 -- Not enough args, so there are real lambdas left to put in the result
949 simplLam env bndrs body cont
950 = do { (env', bndrs') <- simplLamBndrs env bndrs
951 ; body' <- simplExpr env' body
952 ; new_lam <- mkLam env' bndrs' body'
953 ; rebuild env' new_lam cont }
956 simplNonRecE :: SimplEnv
957 -> InId -- The binder
958 -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda)
959 -> ([InBndr], InExpr) -- Body of the let/lambda
962 -> SimplM (SimplEnv, OutExpr)
964 -- simplNonRecE is used for
965 -- * non-top-level non-recursive lets in expressions
968 -- It deals with strict bindings, via the StrictBind continuation,
969 -- which may abort the whole process
971 -- The "body" of the binding comes as a pair of ([InId],InExpr)
972 -- representing a lambda; so we recurse back to simplLam
973 -- Why? Because of the binder-occ-info-zapping done before
974 -- the call to simplLam in simplExprF (Lam ...)
976 -- First deal with type applications and type lets
977 -- (/\a. e) (Type ty) and (let a = Type ty in e)
978 simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont
979 = ASSERT( isTyVar bndr )
980 do { ty_arg' <- simplType (rhs_se `setInScope` env) ty_arg
981 ; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont }
983 simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
984 | preInlineUnconditionally env NotTopLevel bndr rhs
985 = do { tick (PreInlineUnconditionally bndr)
986 ; simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont }
989 = do { simplExprF (rhs_se `setFloats` env) rhs
990 (StrictBind bndr bndrs body env cont) }
993 = ASSERT( not (isTyVar bndr) )
994 do { (env1, bndr1) <- simplNonRecBndr env bndr
995 ; let (env2, bndr2) = addBndrRules env1 bndr bndr1
996 ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
997 ; simplLam env3 bndrs body cont }
1001 %************************************************************************
1005 %************************************************************************
1008 -- Hack alert: we only distinguish subsumed cost centre stacks for the
1009 -- purposes of inlining. All other CCCSs are mapped to currentCCS.
1010 simplNote :: SimplEnv -> Note -> CoreExpr -> SimplCont
1011 -> SimplM (SimplEnv, OutExpr)
1012 simplNote env (SCC cc) e cont
1013 | pushCCisNop cc (getEnclosingCC env) -- scc "f" (...(scc "f" e)...)
1014 = simplExprF env e cont -- ==> scc "f" (...e...)
1016 = do { e' <- simplExpr (setEnclosingCC env currentCCS) e
1017 ; rebuild env (mkSCC cc e') cont }
1019 -- See notes with SimplMonad.inlineMode
1020 simplNote env InlineMe e cont
1021 | Just (inside, outside) <- splitInlineCont cont -- Boring boring continuation; see notes above
1022 = do { -- Don't inline inside an INLINE expression
1023 e' <- simplExprC (setMode inlineMode env) e inside
1024 ; rebuild env (mkInlineMe e') outside }
1026 | otherwise -- Dissolve the InlineMe note if there's
1027 -- an interesting context of any kind to combine with
1028 -- (even a type application -- anything except Stop)
1029 = simplExprF env e cont
1031 simplNote env (CoreNote s) e cont = do
1032 e' <- simplExpr env e
1033 rebuild env (Note (CoreNote s) e') cont
1037 %************************************************************************
1039 \subsection{Dealing with calls}
1041 %************************************************************************
1044 simplVar :: SimplEnv -> Id -> SimplCont -> SimplM (SimplEnv, OutExpr)
1045 simplVar env var cont
1046 = case substId env var of
1047 DoneEx e -> simplExprF (zapSubstEnv env) e cont
1048 ContEx tvs ids e -> simplExprF (setSubstEnv env tvs ids) e cont
1049 DoneId var1 -> completeCall (zapSubstEnv env) var1 cont
1050 -- Note [zapSubstEnv]
1051 -- The template is already simplified, so don't re-substitute.
1052 -- This is VITAL. Consider
1054 -- let y = \z -> ...x... in
1056 -- We'll clone the inner \x, adding x->x' in the id_subst
1057 -- Then when we inline y, we must *not* replace x by x' in
1058 -- the inlined copy!!
1060 ---------------------------------------------------------
1061 -- Dealing with a call site
1063 completeCall :: SimplEnv -> Id -> SimplCont -> SimplM (SimplEnv, OutExpr)
1064 completeCall env var cont
1065 = do { let (args,call_cont) = contArgs cont
1066 -- The args are OutExprs, obtained by *lazily* substituting
1067 -- in the args found in cont. These args are only examined
1068 -- to limited depth (unless a rule fires). But we must do
1069 -- the substitution; rule matching on un-simplified args would
1072 ------------- First try rules ----------------
1073 -- Do this before trying inlining. Some functions have
1074 -- rules *and* are strict; in this case, we don't want to
1075 -- inline the wrapper of the non-specialised thing; better
1076 -- to call the specialised thing instead.
1078 -- We used to use the black-listing mechanism to ensure that inlining of
1079 -- the wrapper didn't occur for things that have specialisations till a
1080 -- later phase, so but now we just try RULES first
1082 -- See also Note [Rules for recursive functions]
1083 ; mb_rule <- tryRules env var args call_cont
1085 Just (n_args, rule_rhs) -> simplExprF env rule_rhs (dropArgs n_args cont) ;
1086 -- The ruleArity says how many args the rule consumed
1087 ; Nothing -> do -- No rules
1090 ------------- Next try inlining ----------------
1091 { dflags <- getDOptsSmpl
1092 ; let arg_infos = [interestingArg arg | arg <- args, isValArg arg]
1093 n_val_args = length arg_infos
1094 interesting_cont = interestingCallContext call_cont
1095 active_inline = activeInline env var
1096 maybe_inline = callSiteInline dflags active_inline var
1097 (null args) arg_infos interesting_cont
1098 ; case maybe_inline of {
1099 Just unfolding -- There is an inlining!
1100 -> do { tick (UnfoldingDone var)
1101 ; (if dopt Opt_D_dump_inlinings dflags then
1102 pprTrace ("Inlining done: " ++ showSDoc (ppr var)) (vcat [
1103 text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
1104 text "Inlined fn: " <+> nest 2 (ppr unfolding),
1105 text "Cont: " <+> ppr call_cont])
1108 simplExprF env unfolding cont }
1110 ; Nothing -> -- No inlining!
1112 ------------- No inlining! ----------------
1113 -- Next, look for rules or specialisations that match
1115 rebuildCall env (Var var)
1116 (mkArgInfo var n_val_args call_cont) cont
1119 rebuildCall :: SimplEnv
1120 -> OutExpr -- Function
1123 -> SimplM (SimplEnv, OutExpr)
1124 rebuildCall env fun (ArgInfo { ai_strs = [] }) cont
1125 -- When we run out of strictness args, it means
1126 -- that the call is definitely bottom; see SimplUtils.mkArgInfo
1127 -- Then we want to discard the entire strict continuation. E.g.
1128 -- * case (error "hello") of { ... }
1129 -- * (error "Hello") arg
1130 -- * f (error "Hello") where f is strict
1132 -- Then, especially in the first of these cases, we'd like to discard
1133 -- the continuation, leaving just the bottoming expression. But the
1134 -- type might not be right, so we may have to add a coerce.
1135 | not (contIsTrivial cont) -- Only do this if there is a non-trivial
1136 = return (env, mk_coerce fun) -- contination to discard, else we do it
1137 where -- again and again!
1138 fun_ty = exprType fun
1139 cont_ty = contResultType env fun_ty cont
1140 co = mkUnsafeCoercion fun_ty cont_ty
1141 mk_coerce expr | cont_ty `coreEqType` fun_ty = expr
1142 | otherwise = mkCoerce co expr
1144 rebuildCall env fun info (ApplyTo _ (Type arg_ty) se cont)
1145 = do { ty' <- simplType (se `setInScope` env) arg_ty
1146 ; rebuildCall env (fun `App` Type ty') info cont }
1149 (ArgInfo { ai_rules = has_rules, ai_strs = str:strs, ai_discs = disc:discs })
1150 (ApplyTo _ arg arg_se cont)
1151 | str -- Strict argument
1152 = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
1153 simplExprF (arg_se `setFloats` env) arg
1154 (StrictArg fun cci arg_info' cont)
1157 | otherwise -- Lazy argument
1158 -- DO NOT float anything outside, hence simplExprC
1159 -- There is no benefit (unlike in a let-binding), and we'd
1160 -- have to be very careful about bogus strictness through
1161 -- floating a demanded let.
1162 = do { arg' <- simplExprC (arg_se `setInScope` env) arg
1164 ; rebuildCall env (fun `App` arg') arg_info' cont }
1166 arg_info' = ArgInfo { ai_rules = has_rules, ai_strs = strs, ai_discs = discs }
1167 cci | has_rules || disc > 0 = ArgCtxt has_rules disc -- Be keener here
1168 | otherwise = BoringCtxt -- Nothing interesting
1170 rebuildCall env fun _ cont
1171 = rebuild env fun cont
1176 This part of the simplifier may break the no-shadowing invariant
1178 f (...(\a -> e)...) (case y of (a,b) -> e')
1179 where f is strict in its second arg
1180 If we simplify the innermost one first we get (...(\a -> e)...)
1181 Simplifying the second arg makes us float the case out, so we end up with
1182 case y of (a,b) -> f (...(\a -> e)...) e'
1183 So the output does not have the no-shadowing invariant. However, there is
1184 no danger of getting name-capture, because when the first arg was simplified
1185 we used an in-scope set that at least mentioned all the variables free in its
1186 static environment, and that is enough.
1188 We can't just do innermost first, or we'd end up with a dual problem:
1189 case x of (a,b) -> f e (...(\a -> e')...)
1191 I spent hours trying to recover the no-shadowing invariant, but I just could
1192 not think of an elegant way to do it. The simplifier is already knee-deep in
1193 continuations. We have to keep the right in-scope set around; AND we have
1194 to get the effect that finding (error "foo") in a strict arg position will
1195 discard the entire application and replace it with (error "foo"). Getting
1196 all this at once is TOO HARD!
1199 %************************************************************************
1203 %************************************************************************
1206 tryRules :: SimplEnv -> Id -> [OutExpr] -> SimplCont
1207 -> SimplM (Maybe (Arity, CoreExpr)) -- The arity is the number of
1208 -- args consumed by the rule
1209 tryRules env fn args call_cont
1210 = do { dflags <- getDOptsSmpl
1211 ; rule_base <- getSimplRules
1212 ; let in_scope = getInScope env
1213 rules = getRules rule_base fn
1214 maybe_rule = case activeRule dflags env of
1215 Nothing -> Nothing -- No rules apply
1216 Just act_fn -> lookupRule act_fn in_scope
1218 ; case (rules, maybe_rule) of {
1219 ([], _) -> return Nothing ;
1220 (_, Nothing) -> return Nothing ;
1221 (_, Just (rule, rule_rhs)) -> do
1223 { tick (RuleFired (ru_name rule))
1224 ; (if dopt Opt_D_dump_rule_firings dflags then
1225 pprTrace "Rule fired" (vcat [
1226 text "Rule:" <+> ftext (ru_name rule),
1227 text "Before:" <+> ppr fn <+> sep (map pprParendExpr args),
1228 text "After: " <+> pprCoreExpr rule_rhs,
1229 text "Cont: " <+> ppr call_cont])
1232 return (Just (ruleArity rule, rule_rhs)) }}}
1235 Note [Rules for recursive functions]
1236 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1237 You might think that we shouldn't apply rules for a loop breaker:
1238 doing so might give rise to an infinite loop, because a RULE is
1239 rather like an extra equation for the function:
1240 RULE: f (g x) y = x+y
1243 But it's too drastic to disable rules for loop breakers.
1244 Even the foldr/build rule would be disabled, because foldr
1245 is recursive, and hence a loop breaker:
1246 foldr k z (build g) = g k z
1247 So it's up to the programmer: rules can cause divergence
1250 %************************************************************************
1252 Rebuilding a cse expression
1254 %************************************************************************
1256 Note [Case elimination]
1257 ~~~~~~~~~~~~~~~~~~~~~~~
1258 The case-elimination transformation discards redundant case expressions.
1259 Start with a simple situation:
1261 case x# of ===> e[x#/y#]
1264 (when x#, y# are of primitive type, of course). We can't (in general)
1265 do this for algebraic cases, because we might turn bottom into
1268 The code in SimplUtils.prepareAlts has the effect of generalise this
1269 idea to look for a case where we're scrutinising a variable, and we
1270 know that only the default case can match. For example:
1274 DEFAULT -> ...(case x of
1278 Here the inner case is first trimmed to have only one alternative, the
1279 DEFAULT, after which it's an instance of the previous case. This
1280 really only shows up in eliminating error-checking code.
1282 We also make sure that we deal with this very common case:
1287 Here we are using the case as a strict let; if x is used only once
1288 then we want to inline it. We have to be careful that this doesn't
1289 make the program terminate when it would have diverged before, so we
1291 - e is already evaluated (it may so if e is a variable)
1292 - x is used strictly, or
1294 Lastly, the code in SimplUtils.mkCase combines identical RHSs. So
1296 case e of ===> case e of DEFAULT -> r
1300 Now again the case may be elminated by the CaseElim transformation.
1303 Further notes about case elimination
1304 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1305 Consider: test :: Integer -> IO ()
1308 Turns out that this compiles to:
1311 eta1 :: State# RealWorld ->
1312 case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->
1314 (PrelNum.jtos eta ($w[] @ Char))
1316 of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s }}
1318 Notice the strange '<' which has no effect at all. This is a funny one.
1319 It started like this:
1321 f x y = if x < 0 then jtos x
1322 else if y==0 then "" else jtos x
1324 At a particular call site we have (f v 1). So we inline to get
1326 if v < 0 then jtos x
1327 else if 1==0 then "" else jtos x
1329 Now simplify the 1==0 conditional:
1331 if v<0 then jtos v else jtos v
1333 Now common-up the two branches of the case:
1335 case (v<0) of DEFAULT -> jtos v
1337 Why don't we drop the case? Because it's strict in v. It's technically
1338 wrong to drop even unnecessary evaluations, and in practice they
1339 may be a result of 'seq' so we *definitely* don't want to drop those.
1340 I don't really know how to improve this situation.
1343 ---------------------------------------------------------
1344 -- Eliminate the case if possible
1346 rebuildCase, reallyRebuildCase
1348 -> OutExpr -- Scrutinee
1349 -> InId -- Case binder
1350 -> [InAlt] -- Alternatives (inceasing order)
1352 -> SimplM (SimplEnv, OutExpr)
1354 --------------------------------------------------
1355 -- 1. Eliminate the case if there's a known constructor
1356 --------------------------------------------------
1358 rebuildCase env scrut case_bndr alts cont
1359 | Just (con,args) <- exprIsConApp_maybe scrut
1360 -- Works when the scrutinee is a variable with a known unfolding
1361 -- as well as when it's an explicit constructor application
1362 = knownCon env scrut (DataAlt con) args case_bndr alts cont
1364 | Lit lit <- scrut -- No need for same treatment as constructors
1365 -- because literals are inlined more vigorously
1366 = knownCon env scrut (LitAlt lit) [] case_bndr alts cont
1369 --------------------------------------------------
1370 -- 2. Eliminate the case if scrutinee is evaluated
1371 --------------------------------------------------
1373 rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont
1374 -- See if we can get rid of the case altogether
1375 -- See Note [Case eliminiation]
1376 -- mkCase made sure that if all the alternatives are equal,
1377 -- then there is now only one (DEFAULT) rhs
1378 | all isDeadBinder bndrs -- bndrs are [InId]
1380 -- Check that the scrutinee can be let-bound instead of case-bound
1381 , exprOkForSpeculation scrut
1382 -- OK not to evaluate it
1383 -- This includes things like (==# a# b#)::Bool
1384 -- so that we simplify
1385 -- case ==# a# b# of { True -> x; False -> x }
1388 -- This particular example shows up in default methods for
1389 -- comparision operations (e.g. in (>=) for Int.Int32)
1390 || exprIsHNF scrut -- It's already evaluated
1391 || var_demanded_later scrut -- It'll be demanded later
1393 -- || not opt_SimplPedanticBottoms) -- Or we don't care!
1394 -- We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on,
1395 -- but that breaks badly for the dataToTag# primop, which relies on a case to evaluate
1396 -- its argument: case x of { y -> dataToTag# y }
1397 -- Here we must *not* discard the case, because dataToTag# just fetches the tag from
1398 -- the info pointer. So we'll be pedantic all the time, and see if that gives any
1400 -- Also we don't want to discard 'seq's
1401 = do { tick (CaseElim case_bndr)
1402 ; env' <- simplNonRecX env case_bndr scrut
1403 ; simplExprF env' rhs cont }
1405 -- The case binder is going to be evaluated later,
1406 -- and the scrutinee is a simple variable
1407 var_demanded_later (Var v) = isStrictDmd (idNewDemandInfo case_bndr)
1408 && not (isTickBoxOp v)
1409 -- ugly hack; covering this case is what
1410 -- exprOkForSpeculation was intended for.
1411 var_demanded_later _ = False
1413 rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont
1414 | all isDeadBinder (case_bndr : bndrs) -- So this is just 'seq'
1415 = -- For this case, see Note [Rules for seq] in MkId
1416 do { let rhs' = substExpr env rhs
1417 out_args = [Type (substTy env (idType case_bndr)),
1418 Type (exprType rhs'), scrut, rhs']
1419 -- Lazily evaluated, so we don't do most of this
1420 ; mb_rule <- tryRules env seqId out_args cont
1422 Just (n_args, res) -> simplExprF (zapSubstEnv env)
1423 (mkApps res (drop n_args out_args))
1425 Nothing -> reallyRebuildCase env scrut case_bndr alts cont }
1427 rebuildCase env scrut case_bndr alts cont
1428 = reallyRebuildCase env scrut case_bndr alts cont
1430 --------------------------------------------------
1431 -- 3. Catch-all case
1432 --------------------------------------------------
1434 reallyRebuildCase env scrut case_bndr alts cont
1435 = do { -- Prepare the continuation;
1436 -- The new subst_env is in place
1437 (env', dup_cont, nodup_cont) <- prepareCaseCont env alts cont
1439 -- Simplify the alternatives
1440 ; (scrut', case_bndr', alts') <- simplAlts env' scrut case_bndr alts dup_cont
1442 -- Check for empty alternatives
1443 ; if null alts' then missingAlt env case_bndr alts cont
1445 { case_expr <- mkCase scrut' case_bndr' alts'
1447 -- Notice that rebuild gets the in-scope set from env, not alt_env
1448 -- The case binder *not* scope over the whole returned case-expression
1449 ; rebuild env' case_expr nodup_cont } }
1452 simplCaseBinder checks whether the scrutinee is a variable, v. If so,
1453 try to eliminate uses of v in the RHSs in favour of case_bndr; that
1454 way, there's a chance that v will now only be used once, and hence
1457 Historical note: we use to do the "case binder swap" in the Simplifier
1458 so there were additional complications if the scrutinee was a variable.
1459 Now the binder-swap stuff is done in the occurrence analyer; see
1460 OccurAnal Note [Binder swap].
1464 If the case binder is not dead, then neither are the pattern bound
1466 case <any> of x { (a,b) ->
1467 case x of { (p,q) -> p } }
1468 Here (a,b) both look dead, but come alive after the inner case is eliminated.
1469 The point is that we bring into the envt a binding
1471 after the outer case, and that makes (a,b) alive. At least we do unless
1472 the case binder is guaranteed dead.
1474 Note [Improving seq]
1477 type family F :: * -> *
1478 type instance F Int = Int
1480 ... case e of x { DEFAULT -> rhs } ...
1482 where x::F Int. Then we'd like to rewrite (F Int) to Int, getting
1484 case e `cast` co of x'::Int
1485 I# x# -> let x = x' `cast` sym co
1488 so that 'rhs' can take advantage of the form of x'. Notice that Note
1489 [Case of cast] may then apply to the result.
1491 This showed up in Roman's experiments. Example:
1492 foo :: F Int -> Int -> Int
1493 foo t n = t `seq` bar n
1496 bar n = bar (n - case t of TI i -> i)
1497 Here we'd like to avoid repeated evaluating t inside the loop, by
1498 taking advantage of the `seq`.
1500 At one point I did transformation in LiberateCase, but it's more robust here.
1501 (Otherwise, there's a danger that we'll simply drop the 'seq' altogether, before
1502 LiberateCase gets to see it.)
1508 improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv
1509 -> OutExpr -> InId -> OutId -> [InAlt]
1510 -> SimplM (SimplEnv, OutExpr, OutId)
1511 -- Note [Improving seq]
1512 improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)]
1513 | Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1)
1514 = do { case_bndr2 <- newId (fsLit "nt") ty2
1515 ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co)
1516 env2 = extendIdSubst env case_bndr rhs
1517 ; return (env2, scrut `Cast` co, case_bndr2) }
1519 improveSeq _ env scrut _ case_bndr1 _
1520 = return (env, scrut, case_bndr1)
1523 improve_case_bndr env scrut case_bndr
1524 -- See Note [no-case-of-case]
1525 -- | switchIsOn (getSwitchChecker env) NoCaseOfCase
1526 -- = (env, case_bndr)
1528 | otherwise -- Failed try; see Note [Suppressing the case binder-swap]
1529 -- not (isEvaldUnfolding (idUnfolding v))
1531 Var v -> (modifyInScope env1 v case_bndr', case_bndr')
1532 -- Note about using modifyInScope for v here
1533 -- We could extend the substitution instead, but it would be
1534 -- a hack because then the substitution wouldn't be idempotent
1535 -- any more (v is an OutId). And this does just as well.
1537 Cast (Var v) co -> (addBinderUnfolding env1 v rhs, case_bndr')
1539 rhs = Cast (Var case_bndr') (mkSymCoercion co)
1541 _ -> (env, case_bndr)
1543 case_bndr' = zapIdOccInfo case_bndr
1544 env1 = modifyInScope env case_bndr case_bndr'
1549 simplAlts does two things:
1551 1. Eliminate alternatives that cannot match, including the
1552 DEFAULT alternative.
1554 2. If the DEFAULT alternative can match only one possible constructor,
1555 then make that constructor explicit.
1557 case e of x { DEFAULT -> rhs }
1559 case e of x { (a,b) -> rhs }
1560 where the type is a single constructor type. This gives better code
1561 when rhs also scrutinises x or e.
1563 Here "cannot match" includes knowledge from GADTs
1565 It's a good idea do do this stuff before simplifying the alternatives, to
1566 avoid simplifying alternatives we know can't happen, and to come up with
1567 the list of constructors that are handled, to put into the IdInfo of the
1568 case binder, for use when simplifying the alternatives.
1570 Eliminating the default alternative in (1) isn't so obvious, but it can
1573 data Colour = Red | Green | Blue
1582 DEFAULT -> [ case y of ... ]
1584 If we inline h into f, the default case of the inlined h can't happen.
1585 If we don't notice this, we may end up filtering out *all* the cases
1586 of the inner case y, which give us nowhere to go!
1590 simplAlts :: SimplEnv
1592 -> InId -- Case binder
1593 -> [InAlt] -- Non-empty
1595 -> SimplM (OutExpr, OutId, [OutAlt]) -- Includes the continuation
1596 -- Like simplExpr, this just returns the simplified alternatives;
1597 -- it not return an environment
1599 simplAlts env scrut case_bndr alts cont'
1600 = -- pprTrace "simplAlts" (ppr alts $$ ppr (seIdSubst env)) $
1601 do { let env0 = zapFloats env
1603 ; (env1, case_bndr1) <- simplBinder env0 case_bndr
1605 ; fam_envs <- getFamEnvs
1606 ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env1 scrut
1607 case_bndr case_bndr1 alts
1609 ; (imposs_deflt_cons, in_alts) <- prepareAlts alt_env' scrut' case_bndr' alts
1611 ; alts' <- mapM (simplAlt alt_env' imposs_deflt_cons case_bndr' cont') in_alts
1612 ; return (scrut', case_bndr', alts') }
1614 ------------------------------------
1615 simplAlt :: SimplEnv
1616 -> [AltCon] -- These constructors can't be present when
1617 -- matching the DEFAULT alternative
1618 -> OutId -- The case binder
1623 simplAlt env imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs)
1624 = ASSERT( null bndrs )
1625 do { let env' = addBinderOtherCon env case_bndr' imposs_deflt_cons
1626 -- Record the constructors that the case-binder *can't* be.
1627 ; rhs' <- simplExprC env' rhs cont'
1628 ; return (DEFAULT, [], rhs') }
1630 simplAlt env _ case_bndr' cont' (LitAlt lit, bndrs, rhs)
1631 = ASSERT( null bndrs )
1632 do { let env' = addBinderUnfolding env case_bndr' (Lit lit)
1633 ; rhs' <- simplExprC env' rhs cont'
1634 ; return (LitAlt lit, [], rhs') }
1636 simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs)
1637 = do { -- Deal with the pattern-bound variables
1638 -- Mark the ones that are in ! positions in the
1639 -- data constructor as certainly-evaluated.
1640 -- NB: simplLamBinders preserves this eval info
1641 let vs_with_evals = add_evals (dataConRepStrictness con)
1642 ; (env', vs') <- simplLamBndrs env vs_with_evals
1644 -- Bind the case-binder to (con args)
1645 ; let inst_tys' = tyConAppArgs (idType case_bndr')
1646 con_args = map Type inst_tys' ++ varsToCoreExprs vs'
1647 env'' = addBinderUnfolding env' case_bndr'
1648 (mkConApp con con_args)
1650 ; rhs' <- simplExprC env'' rhs cont'
1651 ; return (DataAlt con, vs', rhs') }
1653 -- add_evals records the evaluated-ness of the bound variables of
1654 -- a case pattern. This is *important*. Consider
1655 -- data T = T !Int !Int
1657 -- case x of { T a b -> T (a+1) b }
1659 -- We really must record that b is already evaluated so that we don't
1660 -- go and re-evaluate it when constructing the result.
1661 -- See Note [Data-con worker strictness] in MkId.lhs
1666 go (v:vs') strs | isTyVar v = v : go vs' strs
1667 go (v:vs') (str:strs)
1668 | isMarkedStrict str = evald_v : go vs' strs
1669 | otherwise = zapped_v : go vs' strs
1671 zapped_v = zap_occ_info v
1672 evald_v = zapped_v `setIdUnfolding` evaldUnfolding
1673 go _ _ = pprPanic "cat_evals" (ppr con $$ ppr vs $$ ppr the_strs)
1675 -- See Note [zapOccInfo]
1676 -- zap_occ_info: if the case binder is alive, then we add the unfolding
1678 -- to the envt; so vs are now very much alive
1679 -- Note [Aug06] I can't see why this actually matters, but it's neater
1680 -- case e of t { (a,b) -> ...(case t of (p,q) -> p)... }
1681 -- ==> case e of t { (a,b) -> ...(a)... }
1682 -- Look, Ma, a is alive now.
1683 zap_occ_info = zapCasePatIdOcc case_bndr'
1685 addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv
1686 addBinderUnfolding env bndr rhs
1687 = modifyInScope env (bndr `setIdUnfolding` mkUnfolding False rhs)
1689 addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv
1690 addBinderOtherCon env bndr cons
1691 = modifyInScope env (bndr `setIdUnfolding` mkOtherCon cons)
1693 zapCasePatIdOcc :: Id -> Id -> Id
1694 -- Consider case e of b { (a,b) -> ... }
1695 -- Then if we bind b to (a,b) in "...", and b is not dead,
1696 -- then we must zap the deadness info on a,b
1697 zapCasePatIdOcc case_bndr
1698 | isDeadBinder case_bndr = \ pat_id -> pat_id
1699 | otherwise = \ pat_id -> zapIdOccInfo pat_id
1703 %************************************************************************
1705 \subsection{Known constructor}
1707 %************************************************************************
1709 We are a bit careful with occurrence info. Here's an example
1711 (\x* -> case x of (a*, b) -> f a) (h v, e)
1713 where the * means "occurs once". This effectively becomes
1714 case (h v, e) of (a*, b) -> f a)
1716 let a* = h v; b = e in f a
1720 All this should happen in one sweep.
1723 knownCon :: SimplEnv -> OutExpr -> AltCon
1724 -> [OutExpr] -- Args *including* the universal args
1725 -> InId -> [InAlt] -> SimplCont
1726 -> SimplM (SimplEnv, OutExpr)
1728 knownCon env scrut con args bndr alts cont
1729 = do { tick (KnownBranch bndr)
1730 ; case findAlt con alts of
1731 Nothing -> missingAlt env bndr alts cont
1732 Just alt -> knownAlt env scrut args bndr alt cont
1736 knownAlt :: SimplEnv -> OutExpr -> [OutExpr]
1737 -> InId -> InAlt -> SimplCont
1738 -> SimplM (SimplEnv, OutExpr)
1740 knownAlt env scrut the_args bndr (DataAlt dc, bs, rhs) cont
1741 = do { let n_drop_tys = length (dataConUnivTyVars dc)
1742 ; env' <- bind_args env bs (drop n_drop_tys the_args)
1744 -- It's useful to bind bndr to scrut, rather than to a fresh
1745 -- binding x = Con arg1 .. argn
1746 -- because very often the scrut is a variable, so we avoid
1747 -- creating, and then subsequently eliminating, a let-binding
1748 -- BUT, if scrut is a not a variable, we must be careful
1749 -- about duplicating the arg redexes; in that case, make
1750 -- a new con-app from the args
1751 bndr_rhs = case scrut of
1754 con_app = mkConApp dc (take n_drop_tys the_args ++ con_args)
1755 con_args = [substExpr env' (varToCoreExpr b) | b <- bs]
1756 -- args are aready OutExprs, but bs are InIds
1758 ; env'' <- simplNonRecX env' bndr bndr_rhs
1759 ; simplExprF env'' rhs cont }
1761 zap_occ = zapCasePatIdOcc bndr -- bndr is an InId
1764 bind_args env' [] _ = return env'
1766 bind_args env' (b:bs') (Type ty : args)
1767 = ASSERT( isTyVar b )
1768 bind_args (extendTvSubst env' b ty) bs' args
1770 bind_args env' (b:bs') (arg : args)
1772 do { let b' = zap_occ b
1773 -- Note that the binder might be "dead", because it doesn't
1774 -- occur in the RHS; and simplNonRecX may therefore discard
1775 -- it via postInlineUnconditionally.
1776 -- Nevertheless we must keep it if the case-binder is alive,
1777 -- because it may be used in the con_app. See Note [zapOccInfo]
1778 ; env'' <- simplNonRecX env' b' arg
1779 ; bind_args env'' bs' args }
1782 pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr the_args $$
1783 text "scrut:" <+> ppr scrut
1785 knownAlt env scrut _ bndr (_, bs, rhs) cont
1786 = ASSERT( null bs ) -- Works for LitAlt and DEFAULT
1787 do { env' <- simplNonRecX env bndr scrut
1788 ; simplExprF env' rhs cont }
1792 missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont -> SimplM (SimplEnv, OutExpr)
1793 -- This isn't strictly an error, although it is unusual.
1794 -- It's possible that the simplifer might "see" that
1795 -- an inner case has no accessible alternatives before
1796 -- it "sees" that the entire branch of an outer case is
1797 -- inaccessible. So we simply put an error case here instead.
1798 missingAlt env case_bndr alts cont
1799 = WARN( True, ptext (sLit "missingAlt") <+> ppr case_bndr )
1800 return (env, mkImpossibleExpr res_ty)
1802 res_ty = contResultType env (substTy env (coreAltsType alts)) cont
1806 %************************************************************************
1808 \subsection{Duplicating continuations}
1810 %************************************************************************
1813 prepareCaseCont :: SimplEnv
1814 -> [InAlt] -> SimplCont
1815 -> SimplM (SimplEnv, SimplCont,SimplCont)
1816 -- Return a duplicatable continuation, a non-duplicable part
1817 -- plus some extra bindings (that scope over the entire
1820 -- No need to make it duplicatable if there's only one alternative
1821 prepareCaseCont env [_] cont = return (env, cont, mkBoringStop)
1822 prepareCaseCont env _ cont = mkDupableCont env cont
1826 mkDupableCont :: SimplEnv -> SimplCont
1827 -> SimplM (SimplEnv, SimplCont, SimplCont)
1829 mkDupableCont env cont
1830 | contIsDupable cont
1831 = return (env, cont, mkBoringStop)
1833 mkDupableCont _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn
1835 mkDupableCont env (CoerceIt ty cont)
1836 = do { (env', dup, nodup) <- mkDupableCont env cont
1837 ; return (env', CoerceIt ty dup, nodup) }
1839 mkDupableCont env cont@(StrictBind {})
1840 = return (env, mkBoringStop, cont)
1841 -- See Note [Duplicating StrictBind]
1843 mkDupableCont env (StrictArg fun cci ai cont)
1844 -- See Note [Duplicating StrictArg]
1845 = do { (env', dup, nodup) <- mkDupableCont env cont
1846 ; (env'', fun') <- mk_dupable_call env' fun
1847 ; return (env'', StrictArg fun' cci ai dup, nodup) }
1849 mk_dupable_call env (Var v) = return (env, Var v)
1850 mk_dupable_call env (App fun arg) = do { (env', fun') <- mk_dupable_call env fun
1851 ; (env'', arg') <- makeTrivial env' arg
1852 ; return (env'', fun' `App` arg') }
1853 mk_dupable_call _ other = pprPanic "mk_dupable_call" (ppr other)
1854 -- The invariant of StrictArg is that the first arg is always an App chain
1856 mkDupableCont env (ApplyTo _ arg se cont)
1857 = -- e.g. [...hole...] (...arg...)
1859 -- let a = ...arg...
1860 -- in [...hole...] a
1861 do { (env', dup_cont, nodup_cont) <- mkDupableCont env cont
1862 ; arg' <- simplExpr (se `setInScope` env') arg
1863 ; (env'', arg'') <- makeTrivial env' arg'
1864 ; let app_cont = ApplyTo OkToDup arg'' (zapSubstEnv env'') dup_cont
1865 ; return (env'', app_cont, nodup_cont) }
1867 mkDupableCont env cont@(Select _ case_bndr [(_, bs, _rhs)] _ _)
1868 -- See Note [Single-alternative case]
1869 -- | not (exprIsDupable rhs && contIsDupable case_cont)
1870 -- | not (isDeadBinder case_bndr)
1871 | all isDeadBinder bs -- InIds
1872 && not (isUnLiftedType (idType case_bndr))
1873 -- Note [Single-alternative-unlifted]
1874 = return (env, mkBoringStop, cont)
1876 mkDupableCont env (Select _ case_bndr alts se cont)
1877 = -- e.g. (case [...hole...] of { pi -> ei })
1879 -- let ji = \xij -> ei
1880 -- in case [...hole...] of { pi -> ji xij }
1881 do { tick (CaseOfCase case_bndr)
1882 ; (env', dup_cont, nodup_cont) <- mkDupableCont env cont
1883 -- NB: call mkDupableCont here, *not* prepareCaseCont
1884 -- We must make a duplicable continuation, whereas prepareCaseCont
1885 -- doesn't when there is a single case branch
1887 ; let alt_env = se `setInScope` env'
1888 ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr
1889 ; alts' <- mapM (simplAlt alt_env' [] case_bndr' dup_cont) alts
1890 -- Safe to say that there are no handled-cons for the DEFAULT case
1891 -- NB: simplBinder does not zap deadness occ-info, so
1892 -- a dead case_bndr' will still advertise its deadness
1893 -- This is really important because in
1894 -- case e of b { (# p,q #) -> ... }
1895 -- b is always dead, and indeed we are not allowed to bind b to (# p,q #),
1896 -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.
1897 -- In the new alts we build, we have the new case binder, so it must retain
1899 -- NB: we don't use alt_env further; it has the substEnv for
1900 -- the alternatives, and we don't want that
1902 ; (env'', alts'') <- mkDupableAlts env' case_bndr' alts'
1903 ; return (env'', -- Note [Duplicated env]
1904 Select OkToDup case_bndr' alts'' (zapSubstEnv env'') mkBoringStop,
1908 mkDupableAlts :: SimplEnv -> OutId -> [InAlt]
1909 -> SimplM (SimplEnv, [InAlt])
1910 -- Absorbs the continuation into the new alternatives
1912 mkDupableAlts env case_bndr' the_alts
1915 go env0 [] = return (env0, [])
1917 = do { (env1, alt') <- mkDupableAlt env0 case_bndr' alt
1918 ; (env2, alts') <- go env1 alts
1919 ; return (env2, alt' : alts' ) }
1921 mkDupableAlt :: SimplEnv -> OutId -> (AltCon, [CoreBndr], CoreExpr)
1922 -> SimplM (SimplEnv, (AltCon, [CoreBndr], CoreExpr))
1923 mkDupableAlt env case_bndr' (con, bndrs', rhs')
1924 | exprIsDupable rhs' -- Note [Small alternative rhs]
1925 = return (env, (con, bndrs', rhs'))
1927 = do { let rhs_ty' = exprType rhs'
1928 used_bndrs' = filter abstract_over (case_bndr' : bndrs')
1930 | isTyVar bndr = True -- Abstract over all type variables just in case
1931 | otherwise = not (isDeadBinder bndr)
1932 -- The deadness info on the new Ids is preserved by simplBinders
1934 ; (final_bndrs', final_args) -- Note [Join point abstraction]
1935 <- if (any isId used_bndrs')
1936 then return (used_bndrs', varsToCoreExprs used_bndrs')
1937 else do { rw_id <- newId (fsLit "w") realWorldStatePrimTy
1938 ; return ([rw_id], [Var realWorldPrimId]) }
1940 ; join_bndr <- newId (fsLit "$j") (mkPiTypes final_bndrs' rhs_ty')
1941 -- Note [Funky mkPiTypes]
1943 ; let -- We make the lambdas into one-shot-lambdas. The
1944 -- join point is sure to be applied at most once, and doing so
1945 -- prevents the body of the join point being floated out by
1946 -- the full laziness pass
1947 really_final_bndrs = map one_shot final_bndrs'
1948 one_shot v | isId v = setOneShotLambda v
1950 join_rhs = mkLams really_final_bndrs rhs'
1951 join_call = mkApps (Var join_bndr) final_args
1953 ; return (addPolyBind NotTopLevel env (NonRec join_bndr join_rhs), (con, bndrs', join_call)) }
1954 -- See Note [Duplicated env]
1957 Note [Duplicated env]
1958 ~~~~~~~~~~~~~~~~~~~~~
1959 Some of the alternatives are simplified, but have not been turned into a join point
1960 So they *must* have an zapped subst-env. So we can't use completeNonRecX to
1961 bind the join point, because it might to do PostInlineUnconditionally, and
1962 we'd lose that when zapping the subst-env. We could have a per-alt subst-env,
1963 but zapping it (as we do in mkDupableCont, the Select case) is safe, and
1964 at worst delays the join-point inlining.
1966 Note [Small alternative rhs]
1967 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1968 It is worth checking for a small RHS because otherwise we
1969 get extra let bindings that may cause an extra iteration of the simplifier to
1970 inline back in place. Quite often the rhs is just a variable or constructor.
1971 The Ord instance of Maybe in PrelMaybe.lhs, for example, took several extra
1972 iterations because the version with the let bindings looked big, and so wasn't
1973 inlined, but after the join points had been inlined it looked smaller, and so
1976 NB: we have to check the size of rhs', not rhs.
1977 Duplicating a small InAlt might invalidate occurrence information
1978 However, if it *is* dupable, we return the *un* simplified alternative,
1979 because otherwise we'd need to pair it up with an empty subst-env....
1980 but we only have one env shared between all the alts.
1981 (Remember we must zap the subst-env before re-simplifying something).
1982 Rather than do this we simply agree to re-simplify the original (small) thing later.
1984 Note [Funky mkPiTypes]
1985 ~~~~~~~~~~~~~~~~~~~~~~
1986 Notice the funky mkPiTypes. If the contructor has existentials
1987 it's possible that the join point will be abstracted over
1988 type varaibles as well as term variables.
1989 Example: Suppose we have
1990 data T = forall t. C [t]
1992 case (case e of ...) of
1994 We get the join point
1995 let j :: forall t. [t] -> ...
1996 j = /\t \xs::[t] -> rhs
1998 case (case e of ...) of
1999 C t xs::[t] -> j t xs
2001 Note [Join point abstaction]
2002 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2003 If we try to lift a primitive-typed something out
2004 for let-binding-purposes, we will *caseify* it (!),
2005 with potentially-disastrous strictness results. So
2006 instead we turn it into a function: \v -> e
2007 where v::State# RealWorld#. The value passed to this function
2008 is realworld#, which generates (almost) no code.
2010 There's a slight infelicity here: we pass the overall
2011 case_bndr to all the join points if it's used in *any* RHS,
2012 because we don't know its usage in each RHS separately
2014 We used to say "&& isUnLiftedType rhs_ty'" here, but now
2015 we make the join point into a function whenever used_bndrs'
2016 is empty. This makes the join-point more CPR friendly.
2017 Consider: let j = if .. then I# 3 else I# 4
2018 in case .. of { A -> j; B -> j; C -> ... }
2020 Now CPR doesn't w/w j because it's a thunk, so
2021 that means that the enclosing function can't w/w either,
2022 which is a lose. Here's the example that happened in practice:
2023 kgmod :: Int -> Int -> Int
2024 kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
2028 I have seen a case alternative like this:
2030 It's a bit silly to add the realWorld dummy arg in this case, making
2033 (the \v alone is enough to make CPR happy) but I think it's rare
2035 Note [Duplicating StrictArg]
2036 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2037 The original plan had (where E is a big argument)
2039 ==> let $j = \a -> f E a
2042 But this is terrible! Here's an example:
2043 && E (case x of { T -> F; F -> T })
2044 Now, && is strict so we end up simplifying the case with
2045 an ArgOf continuation. If we let-bind it, we get
2046 let $j = \v -> && E v
2047 in simplExpr (case x of { T -> F; F -> T })
2049 And after simplifying more we get
2050 let $j = \v -> && E v
2051 in case x of { T -> $j F; F -> $j T }
2052 Which is a Very Bad Thing
2054 What we do now is this
2058 Now if the thing in the hole is a case expression (which is when
2059 we'll call mkDupableCont), we'll push the function call into the
2060 branches, which is what we want. Now RULES for f may fire, and
2061 call-pattern specialisation. Here's an example from Trac #3116
2064 _ -> Chunk p fpc (o+1) (l-1) bs')
2065 If we can push the call for 'go' inside the case, we get
2066 call-pattern specialisation for 'go', which is *crucial* for
2069 Here is the (&&) example:
2070 && E (case x of { T -> F; F -> T })
2072 case x of { T -> && a F; F -> && a T }
2076 * Arguments to f *after* the strict one are handled by
2077 the ApplyTo case of mkDupableCont. Eg
2080 * We can only do the let-binding of E because the function
2081 part of a StrictArg continuation is an explicit syntax
2082 tree. In earlier versions we represented it as a function
2083 (CoreExpr -> CoreEpxr) which we couldn't take apart.
2085 Do *not* duplicate StrictBind and StritArg continuations. We gain
2086 nothing by propagating them into the expressions, and we do lose a
2089 The desire not to duplicate is the entire reason that
2090 mkDupableCont returns a pair of continuations.
2092 Note [Duplicating StrictBind]
2093 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2094 Unlike StrictArg, there doesn't seem anything to gain from
2095 duplicating a StrictBind continuation, so we don't.
2097 The desire not to duplicate is the entire reason that
2098 mkDupableCont returns a pair of continuations.
2101 Note [Single-alternative cases]
2102 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2103 This case is just like the ArgOf case. Here's an example:
2107 case (case x of I# x' ->
2109 True -> I# (negate# x')
2110 False -> I# x') of y {
2112 Because the (case x) has only one alternative, we'll transform to
2114 case (case x' <# 0# of
2115 True -> I# (negate# x')
2116 False -> I# x') of y {
2118 But now we do *NOT* want to make a join point etc, giving
2120 let $j = \y -> MkT y
2122 True -> $j (I# (negate# x'))
2124 In this case the $j will inline again, but suppose there was a big
2125 strict computation enclosing the orginal call to MkT. Then, it won't
2126 "see" the MkT any more, because it's big and won't get duplicated.
2127 And, what is worse, nothing was gained by the case-of-case transform.
2129 When should use this case of mkDupableCont?
2130 However, matching on *any* single-alternative case is a *disaster*;
2131 e.g. case (case ....) of (a,b) -> (# a,b #)
2132 We must push the outer case into the inner one!
2135 * Match [(DEFAULT,_,_)], but in the common case of Int,
2136 the alternative-filling-in code turned the outer case into
2137 case (...) of y { I# _ -> MkT y }
2139 * Match on single alternative plus (not (isDeadBinder case_bndr))
2140 Rationale: pushing the case inwards won't eliminate the construction.
2141 But there's a risk of
2142 case (...) of y { (a,b) -> let z=(a,b) in ... }
2143 Now y looks dead, but it'll come alive again. Still, this
2144 seems like the best option at the moment.
2146 * Match on single alternative plus (all (isDeadBinder bndrs))
2147 Rationale: this is essentially seq.
2149 * Match when the rhs is *not* duplicable, and hence would lead to a
2150 join point. This catches the disaster-case above. We can test
2151 the *un-simplified* rhs, which is fine. It might get bigger or
2152 smaller after simplification; if it gets smaller, this case might
2153 fire next time round. NB also that we must test contIsDupable
2154 case_cont *btoo, because case_cont might be big!
2156 HOWEVER: I found that this version doesn't work well, because
2157 we can get let x = case (...) of { small } in ...case x...
2158 When x is inlined into its full context, we find that it was a bad
2159 idea to have pushed the outer case inside the (...) case.
2161 Note [Single-alternative-unlifted]
2162 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2163 Here's another single-alternative where we really want to do case-of-case:
2171 case y_s6X of tpl_s7m {
2172 M1.Mk1 ipv_s70 -> ipv_s70;
2173 M1.Mk2 ipv_s72 -> ipv_s72;
2179 case x_s74 of tpl_s7n {
2180 M1.Mk1 ipv_s77 -> ipv_s77;
2181 M1.Mk2 ipv_s79 -> ipv_s79;
2185 { __DEFAULT -> ==# [wild1_s7b wild_s7c];
2189 So the outer case is doing *nothing at all*, other than serving as a
2190 join-point. In this case we really want to do case-of-case and decide
2191 whether to use a real join point or just duplicate the continuation.
2193 Hence: check whether the case binder's type is unlifted, because then
2194 the outer case is *not* a seq.