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"
11 import CmdLineOpts ( dopt, DynFlag(Opt_D_dump_inlinings),
15 import SimplUtils ( mkCase, mkLam, newId, prepareAlts,
16 simplBinder, simplBinders, simplLamBndrs, simplRecBndrs, simplLetBndr,
17 SimplCont(..), DupFlag(..), LetRhsFlag(..),
18 mkStop, mkBoringStop, pushContArgs,
19 contResultType, countArgs, contIsDupable, contIsRhsOrArg,
20 getContArgs, interestingCallContext, interestingArg, isStrictType
22 import Var ( mustHaveLocalBinding )
24 import Id ( Id, idType, idInfo, idArity, isDataConId,
25 setIdUnfolding, isDeadBinder,
26 idNewDemandInfo, setIdInfo,
27 setIdOccInfo, zapLamIdInfo, setOneShotLambda,
29 import OccName ( encodeFS )
30 import IdInfo ( OccInfo(..), isLoopBreaker,
35 import NewDemand ( isStrictDmd )
36 import DataCon ( dataConNumInstArgs, dataConRepStrictness )
38 import PprCore ( pprParendExpr, pprCoreExpr )
39 import CoreUnfold ( mkOtherCon, mkUnfolding, callSiteInline )
40 import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding,
41 exprIsConApp_maybe, mkPiTypes, findAlt,
42 exprType, exprIsValue,
43 exprOkForSpeculation, exprArity,
44 mkCoerce, mkCoerce2, mkSCC, mkInlineMe, mkAltExpr, applyTypeToArg
46 import Rules ( lookupRule )
47 import BasicTypes ( isMarkedStrict )
48 import CostCentre ( currentCCS )
49 import Type ( isUnLiftedType, seqType, tyConAppArgs, funArgTy,
50 splitFunTy_maybe, splitFunTy, eqType
52 import Subst ( mkSubst, substTy, substExpr,
53 isInScope, lookupIdSubst, simplIdInfo
55 import TysPrim ( realWorldStatePrimTy )
56 import PrelInfo ( realWorldPrimId )
57 import BasicTypes ( TopLevelFlag(..), isTopLevel,
61 import Maybe ( Maybe )
63 import Util ( notNull )
67 The guts of the simplifier is in this module, but the driver loop for
68 the simplifier is in SimplCore.lhs.
71 -----------------------------------------
72 *** IMPORTANT NOTE ***
73 -----------------------------------------
74 The simplifier used to guarantee that the output had no shadowing, but
75 it does not do so any more. (Actually, it never did!) The reason is
76 documented with simplifyArgs.
79 -----------------------------------------
80 *** IMPORTANT NOTE ***
81 -----------------------------------------
82 Many parts of the simplifier return a bunch of "floats" as well as an
83 expression. This is wrapped as a datatype SimplUtils.FloatsWith.
85 All "floats" are let-binds, not case-binds, but some non-rec lets may
86 be unlifted (with RHS ok-for-speculation).
90 -----------------------------------------
91 ORGANISATION OF FUNCTIONS
92 -----------------------------------------
94 - simplify all top-level binders
95 - for NonRec, call simplRecOrTopPair
96 - for Rec, call simplRecBind
99 ------------------------------
100 simplExpr (applied lambda) ==> simplNonRecBind
101 simplExpr (Let (NonRec ...) ..) ==> simplNonRecBind
102 simplExpr (Let (Rec ...) ..) ==> simplify binders; simplRecBind
104 ------------------------------
105 simplRecBind [binders already simplfied]
106 - use simplRecOrTopPair on each pair in turn
108 simplRecOrTopPair [binder already simplified]
109 Used for: recursive bindings (top level and nested)
110 top-level non-recursive bindings
112 - check for PreInlineUnconditionally
116 Used for: non-top-level non-recursive bindings
117 beta reductions (which amount to the same thing)
118 Because it can deal with strict arts, it takes a
119 "thing-inside" and returns an expression
121 - check for PreInlineUnconditionally
122 - simplify binder, including its IdInfo
131 simplNonRecX: [given a *simplified* RHS, but an *unsimplified* binder]
132 Used for: binding case-binder and constr args in a known-constructor case
133 - check for PreInLineUnconditionally
137 ------------------------------
138 simplLazyBind: [binder already simplified, RHS not]
139 Used for: recursive bindings (top level and nested)
140 top-level non-recursive bindings
141 non-top-level, but *lazy* non-recursive bindings
142 [must not be strict or unboxed]
143 Returns floats + an augmented environment, not an expression
144 - substituteIdInfo and add result to in-scope
145 [so that rules are available in rec rhs]
148 - float if exposes constructor or PAP
152 completeNonRecX: [binder and rhs both simplified]
153 - if the the thing needs case binding (unlifted and not ok-for-spec)
159 completeLazyBind: [given a simplified RHS]
160 [used for both rec and non-rec bindings, top level and not]
161 - try PostInlineUnconditionally
162 - add unfolding [this is the only place we add an unfolding]
167 Right hand sides and arguments
168 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
169 In many ways we want to treat
170 (a) the right hand side of a let(rec), and
171 (b) a function argument
172 in the same way. But not always! In particular, we would
173 like to leave these arguments exactly as they are, so they
174 will match a RULE more easily.
179 It's harder to make the rule match if we ANF-ise the constructor,
180 or eta-expand the PAP:
182 f (let { a = g x; b = h x } in (a,b))
185 On the other hand if we see the let-defns
190 then we *do* want to ANF-ise and eta-expand, so that p and q
191 can be safely inlined.
193 Even floating lets out is a bit dubious. For let RHS's we float lets
194 out if that exposes a value, so that the value can be inlined more vigorously.
197 r = let x = e in (x,x)
199 Here, if we float the let out we'll expose a nice constructor. We did experiments
200 that showed this to be a generally good thing. But it was a bad thing to float
201 lets out unconditionally, because that meant they got allocated more often.
203 For function arguments, there's less reason to expose a constructor (it won't
204 get inlined). Just possibly it might make a rule match, but I'm pretty skeptical.
205 So for the moment we don't float lets out of function arguments either.
210 For eta expansion, we want to catch things like
212 case e of (a,b) -> \x -> case a of (p,q) -> \y -> r
214 If the \x was on the RHS of a let, we'd eta expand to bring the two
215 lambdas together. And in general that's a good thing to do. Perhaps
216 we should eta expand wherever we find a (value) lambda? Then the eta
217 expansion at a let RHS can concentrate solely on the PAP case.
220 %************************************************************************
222 \subsection{Bindings}
224 %************************************************************************
227 simplTopBinds :: SimplEnv -> [InBind] -> SimplM [OutBind]
229 simplTopBinds env binds
230 = -- Put all the top-level binders into scope at the start
231 -- so that if a transformation rule has unexpectedly brought
232 -- anything into scope, then we don't get a complaint about that.
233 -- It's rather as if the top-level binders were imported.
234 simplRecBndrs env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') ->
235 simpl_binds env binds bndrs' `thenSmpl` \ (floats, _) ->
236 freeTick SimplifierDone `thenSmpl_`
237 returnSmpl (floatBinds floats)
239 -- We need to track the zapped top-level binders, because
240 -- they should have their fragile IdInfo zapped (notably occurrence info)
241 -- That's why we run down binds and bndrs' simultaneously.
242 simpl_binds :: SimplEnv -> [InBind] -> [OutId] -> SimplM (FloatsWith ())
243 simpl_binds env [] bs = ASSERT( null bs ) returnSmpl (emptyFloats env, ())
244 simpl_binds env (bind:binds) bs = simpl_bind env bind bs `thenSmpl` \ (floats,env) ->
245 addFloats env floats $ \env ->
246 simpl_binds env binds (drop_bs bind bs)
248 drop_bs (NonRec _ _) (_ : bs) = bs
249 drop_bs (Rec prs) bs = drop (length prs) bs
251 simpl_bind env (NonRec b r) (b':_) = simplRecOrTopPair env TopLevel b b' r
252 simpl_bind env (Rec pairs) bs' = simplRecBind env TopLevel pairs bs'
256 %************************************************************************
258 \subsection{simplNonRec}
260 %************************************************************************
262 simplNonRecBind is used for
263 * non-top-level non-recursive lets in expressions
267 * An unsimplified (binder, rhs) pair
268 * The env for the RHS. It may not be the same as the
269 current env because the bind might occur via (\x.E) arg
271 It uses the CPS form because the binding might be strict, in which
272 case we might discard the continuation:
273 let x* = error "foo" in (...x...)
275 It needs to turn unlifted bindings into a @case@. They can arise
276 from, say: (\x -> e) (4# + 3#)
279 simplNonRecBind :: SimplEnv
281 -> InExpr -> SimplEnv -- Arg, with its subst-env
282 -> OutType -- Type of thing computed by the context
283 -> (SimplEnv -> SimplM FloatsWithExpr) -- The body
284 -> SimplM FloatsWithExpr
286 simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside
288 = pprPanic "simplNonRecBind" (ppr bndr <+> ppr rhs)
291 simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside
292 | preInlineUnconditionally env NotTopLevel bndr
293 = tick (PreInlineUnconditionally bndr) `thenSmpl_`
294 thing_inside (extendSubst env bndr (ContEx (getSubstEnv rhs_se) rhs))
297 | isStrictDmd (idNewDemandInfo bndr) || isStrictType (idType bndr) -- A strict let
298 = -- Don't use simplBinder because that doesn't keep
299 -- fragile occurrence info in the substitution
300 simplLetBndr env bndr `thenSmpl` \ (env, bndr') ->
302 -- simplLetBndr doesn't deal with the IdInfo, so we must
303 -- do so here (c.f. simplLazyBind)
304 bndr'' = bndr' `setIdInfo` simplIdInfo (getSubst env) (idInfo bndr)
305 env1 = modifyInScope env bndr'' bndr''
307 simplStrictArg AnRhs env1 rhs rhs_se (idType bndr') cont_ty $ \ env rhs1 ->
309 -- Now complete the binding and simplify the body
310 completeNonRecX env True {- strict -} bndr bndr'' rhs1 thing_inside
312 | otherwise -- Normal, lazy case
313 = -- Don't use simplBinder because that doesn't keep
314 -- fragile occurrence info in the substitution
315 simplLetBndr env bndr `thenSmpl` \ (env, bndr') ->
316 simplLazyBind env NotTopLevel NonRecursive
317 bndr bndr' rhs rhs_se `thenSmpl` \ (floats, env) ->
318 addFloats env floats thing_inside
321 A specialised variant of simplNonRec used when the RHS is already simplified, notably
322 in knownCon. It uses case-binding where necessary.
325 simplNonRecX :: SimplEnv
326 -> InId -- Old binder
327 -> OutExpr -- Simplified RHS
328 -> (SimplEnv -> SimplM FloatsWithExpr)
329 -> SimplM FloatsWithExpr
331 simplNonRecX env bndr new_rhs thing_inside
332 | needsCaseBinding (idType bndr) new_rhs
333 -- Make this test *before* the preInlineUnconditionally
334 -- Consider case I# (quotInt# x y) of
335 -- I# v -> let w = J# v in ...
336 -- If we gaily inline (quotInt# x y) for v, we end up building an
338 -- let w = J# (quotInt# x y) in ...
339 -- because quotInt# can fail.
340 = simplBinder env bndr `thenSmpl` \ (env, bndr') ->
341 thing_inside env `thenSmpl` \ (floats, body) ->
342 returnSmpl (emptyFloats env, Case new_rhs bndr' [(DEFAULT, [], wrapFloats floats body)])
344 | preInlineUnconditionally env NotTopLevel bndr
345 -- This happens; for example, the case_bndr during case of
346 -- known constructor: case (a,b) of x { (p,q) -> ... }
347 -- Here x isn't mentioned in the RHS, so we don't want to
348 -- create the (dead) let-binding let x = (a,b) in ...
350 -- Similarly, single occurrences can be inlined vigourously
351 -- e.g. case (f x, g y) of (a,b) -> ....
352 -- If a,b occur once we can avoid constructing the let binding for them.
353 = thing_inside (extendSubst env bndr (ContEx emptySubstEnv new_rhs))
356 = simplBinder env bndr `thenSmpl` \ (env, bndr') ->
357 completeNonRecX env False {- Non-strict; pessimistic -}
358 bndr bndr' new_rhs thing_inside
360 completeNonRecX env is_strict old_bndr new_bndr new_rhs thing_inside
361 = mkAtomicArgs is_strict
362 True {- OK to float unlifted -}
363 new_rhs `thenSmpl` \ (aux_binds, rhs2) ->
365 -- Make the arguments atomic if necessary,
366 -- adding suitable bindings
367 addAtomicBindsE env (fromOL aux_binds) $ \ env ->
368 completeLazyBind env NotTopLevel
369 old_bndr new_bndr rhs2 `thenSmpl` \ (floats, env) ->
370 addFloats env floats thing_inside
374 %************************************************************************
376 \subsection{Lazy bindings}
378 %************************************************************************
380 simplRecBind is used for
381 * recursive bindings only
384 simplRecBind :: SimplEnv -> TopLevelFlag
385 -> [(InId, InExpr)] -> [OutId]
386 -> SimplM (FloatsWith SimplEnv)
387 simplRecBind env top_lvl pairs bndrs'
388 = go env pairs bndrs' `thenSmpl` \ (floats, env) ->
389 returnSmpl (flattenFloats floats, env)
391 go env [] _ = returnSmpl (emptyFloats env, env)
393 go env ((bndr, rhs) : pairs) (bndr' : bndrs')
394 = simplRecOrTopPair env top_lvl bndr bndr' rhs `thenSmpl` \ (floats, env) ->
395 addFloats env floats (\env -> go env pairs bndrs')
399 simplRecOrTopPair is used for
400 * recursive bindings (whether top level or not)
401 * top-level non-recursive bindings
403 It assumes the binder has already been simplified, but not its IdInfo.
406 simplRecOrTopPair :: SimplEnv
408 -> InId -> OutId -- Binder, both pre-and post simpl
409 -> InExpr -- The RHS and its environment
410 -> SimplM (FloatsWith SimplEnv)
412 simplRecOrTopPair env top_lvl bndr bndr' rhs
413 | preInlineUnconditionally env top_lvl bndr -- Check for unconditional inline
414 = tick (PreInlineUnconditionally bndr) `thenSmpl_`
415 returnSmpl (emptyFloats env, extendSubst env bndr (ContEx (getSubstEnv env) rhs))
418 = simplLazyBind env top_lvl Recursive bndr bndr' rhs env
419 -- May not actually be recursive, but it doesn't matter
423 simplLazyBind is used for
424 * recursive bindings (whether top level or not)
425 * top-level non-recursive bindings
426 * non-top-level *lazy* non-recursive bindings
428 [Thus it deals with the lazy cases from simplNonRecBind, and all cases
429 from SimplRecOrTopBind]
432 1. It assumes that the binder is *already* simplified,
433 and is in scope, but not its IdInfo
435 2. It assumes that the binder type is lifted.
437 3. It does not check for pre-inline-unconditionallly;
438 that should have been done already.
441 simplLazyBind :: SimplEnv
442 -> TopLevelFlag -> RecFlag
443 -> InId -> OutId -- Binder, both pre-and post simpl
444 -> InExpr -> SimplEnv -- The RHS and its environment
445 -> SimplM (FloatsWith SimplEnv)
447 simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se
448 = -- Substitute IdInfo on binder, in the light of earlier
449 -- substitutions in this very letrec, and extend the
450 -- in-scope env, so that the IdInfo for this binder extends
451 -- over the RHS for the binder itself.
453 -- This is important. Manuel found cases where he really, really
454 -- wanted a RULE for a recursive function to apply in that function's
455 -- own right-hand side.
457 -- NB: does no harm for non-recursive bindings
459 bndr'' = bndr' `setIdInfo` simplIdInfo (getSubst env) (idInfo bndr)
460 env1 = modifyInScope env bndr'' bndr''
461 rhs_env = setInScope rhs_se env1
462 is_top_level = isTopLevel top_lvl
463 ok_float_unlifted = not is_top_level && isNonRec is_rec
464 rhs_cont = mkStop (idType bndr') AnRhs
466 -- Simplify the RHS; note the mkStop, which tells
467 -- the simplifier that this is the RHS of a let.
468 simplExprF rhs_env rhs rhs_cont `thenSmpl` \ (floats, rhs1) ->
470 -- If any of the floats can't be floated, give up now
471 -- (The allLifted predicate says True for empty floats.)
472 if (not ok_float_unlifted && not (allLifted floats)) then
473 completeLazyBind env1 top_lvl bndr bndr''
474 (wrapFloats floats rhs1)
477 -- ANF-ise a constructor or PAP rhs
478 mkAtomicArgs False {- Not strict -}
479 ok_float_unlifted rhs1 `thenSmpl` \ (aux_binds, rhs2) ->
481 -- If the result is a PAP, float the floats out, else wrap them
482 -- By this time it's already been ANF-ised (if necessary)
483 if isEmptyFloats floats && isNilOL aux_binds then -- Shortcut a common case
484 completeLazyBind env1 top_lvl bndr bndr'' rhs2
486 -- We use exprIsTrivial here because we want to reveal lone variables.
487 -- E.g. let { x = letrec { y = E } in y } in ...
488 -- Here we definitely want to float the y=E defn.
489 -- exprIsValue definitely isn't right for that.
491 -- BUT we can't use "exprIsCheap", because that causes a strictness bug.
492 -- x = let y* = E in case (scc y) of { T -> F; F -> T}
493 -- The case expression is 'cheap', but it's wrong to transform to
494 -- y* = E; x = case (scc y) of {...}
495 -- Either we must be careful not to float demanded non-values, or
496 -- we must use exprIsValue for the test, which ensures that the
497 -- thing is non-strict. I think. The WARN below tests for this.
498 else if is_top_level || exprIsTrivial rhs2 || exprIsValue rhs2 then
500 -- There's a subtlety here. There may be a binding (x* = e) in the
501 -- floats, where the '*' means 'will be demanded'. So is it safe
502 -- to float it out? Answer no, but it won't matter because
503 -- we only float if arg' is a WHNF,
504 -- and so there can't be any 'will be demanded' bindings in the floats.
506 WARN( any demanded_float (floatBinds floats),
507 ppr (filter demanded_float (floatBinds floats)) )
509 tick LetFloatFromLet `thenSmpl_` (
510 addFloats env1 floats $ \ env2 ->
511 addAtomicBinds env2 (fromOL aux_binds) $ \ env3 ->
512 completeLazyBind env3 top_lvl bndr bndr'' rhs2)
515 completeLazyBind env1 top_lvl bndr bndr'' (wrapFloats floats rhs1)
518 demanded_float (NonRec b r) = isStrictDmd (idNewDemandInfo b) && not (isUnLiftedType (idType b))
519 -- Unlifted-type (cheap-eagerness) lets may well have a demanded flag on them
520 demanded_float (Rec _) = False
525 %************************************************************************
527 \subsection{Completing a lazy binding}
529 %************************************************************************
532 * deals only with Ids, not TyVars
533 * takes an already-simplified binder and RHS
534 * is used for both recursive and non-recursive bindings
535 * is used for both top-level and non-top-level bindings
537 It does the following:
538 - tries discarding a dead binding
539 - tries PostInlineUnconditionally
540 - add unfolding [this is the only place we add an unfolding]
543 It does *not* attempt to do let-to-case. Why? Because it is used for
544 - top-level bindings (when let-to-case is impossible)
545 - many situations where the "rhs" is known to be a WHNF
546 (so let-to-case is inappropriate).
549 completeLazyBind :: SimplEnv
550 -> TopLevelFlag -- Flag stuck into unfolding
551 -> InId -- Old binder
552 -> OutId -- New binder
553 -> OutExpr -- Simplified RHS
554 -> SimplM (FloatsWith SimplEnv)
555 -- We return a new SimplEnv, because completeLazyBind may choose to do its work
556 -- by extending the substitution (e.g. let x = y in ...)
557 -- The new binding (if any) is returned as part of the floats.
558 -- NB: the returned SimplEnv has the right SubstEnv, but you should
559 -- (as usual) use the in-scope-env from the floats
561 completeLazyBind env top_lvl old_bndr new_bndr new_rhs
562 | postInlineUnconditionally env new_bndr occ_info new_rhs
563 = -- Drop the binding
564 tick (PostInlineUnconditionally old_bndr) `thenSmpl_`
565 returnSmpl (emptyFloats env, extendSubst env old_bndr (DoneEx new_rhs))
566 -- Use the substitution to make quite, quite sure that the substitution
567 -- will happen, since we are going to discard the binding
572 new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs
574 -- Add the unfolding *only* for non-loop-breakers
575 -- Making loop breakers not have an unfolding at all
576 -- means that we can avoid tests in exprIsConApp, for example.
577 -- This is important: if exprIsConApp says 'yes' for a recursive
578 -- thing, then we can get into an infinite loop
579 info_w_unf | loop_breaker = new_bndr_info
580 | otherwise = new_bndr_info `setUnfoldingInfo` unfolding
581 unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs
583 final_id = new_bndr `setIdInfo` info_w_unf
585 -- These seqs forces the Id, and hence its IdInfo,
586 -- and hence any inner substitutions
588 returnSmpl (unitFloat env final_id new_rhs, env)
591 loop_breaker = isLoopBreaker occ_info
592 old_info = idInfo old_bndr
593 occ_info = occInfo old_info
598 %************************************************************************
600 \subsection[Simplify-simplExpr]{The main function: simplExpr}
602 %************************************************************************
604 The reason for this OutExprStuff stuff is that we want to float *after*
605 simplifying a RHS, not before. If we do so naively we get quadratic
606 behaviour as things float out.
608 To see why it's important to do it after, consider this (real) example:
622 a -- Can't inline a this round, cos it appears twice
626 Each of the ==> steps is a round of simplification. We'd save a
627 whole round if we float first. This can cascade. Consider
632 let f = let d1 = ..d.. in \y -> e
636 in \x -> ...(\y ->e)...
638 Only in this second round can the \y be applied, and it
639 might do the same again.
643 simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
644 simplExpr env expr = simplExprC env expr (mkStop expr_ty' AnArg)
646 expr_ty' = substTy (getSubst env) (exprType expr)
647 -- The type in the Stop continuation, expr_ty', is usually not used
648 -- It's only needed when discarding continuations after finding
649 -- a function that returns bottom.
650 -- Hence the lazy substitution
653 simplExprC :: SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr
654 -- Simplify an expression, given a continuation
655 simplExprC env expr cont
656 = simplExprF env expr cont `thenSmpl` \ (floats, expr) ->
657 returnSmpl (wrapFloats floats expr)
659 simplExprF :: SimplEnv -> InExpr -> SimplCont -> SimplM FloatsWithExpr
660 -- Simplify an expression, returning floated binds
662 simplExprF env (Var v) cont = simplVar env v cont
663 simplExprF env (Lit lit) cont = rebuild env (Lit lit) cont
664 simplExprF env expr@(Lam _ _) cont = simplLam env expr cont
665 simplExprF env (Note note expr) cont = simplNote env note expr cont
666 simplExprF env (App fun arg) cont = simplExprF env fun (ApplyTo NoDup arg env cont)
668 simplExprF env (Type ty) cont
669 = ASSERT( contIsRhsOrArg cont )
670 simplType env ty `thenSmpl` \ ty' ->
671 rebuild env (Type ty') cont
673 simplExprF env (Case scrut bndr alts) cont
674 | not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
675 = -- Simplify the scrutinee with a Select continuation
676 simplExprF env scrut (Select NoDup bndr alts env cont)
679 = -- If case-of-case is off, simply simplify the case expression
680 -- in a vanilla Stop context, and rebuild the result around it
681 simplExprC env scrut case_cont `thenSmpl` \ case_expr' ->
682 rebuild env case_expr' cont
684 case_cont = Select NoDup bndr alts env (mkBoringStop (contResultType cont))
686 simplExprF env (Let (Rec pairs) body) cont
687 = simplRecBndrs env (map fst pairs) `thenSmpl` \ (env, bndrs') ->
688 -- NB: bndrs' don't have unfoldings or spec-envs
689 -- We add them as we go down, using simplPrags
691 simplRecBind env NotTopLevel pairs bndrs' `thenSmpl` \ (floats, env) ->
692 addFloats env floats $ \ env ->
693 simplExprF env body cont
695 -- A non-recursive let is dealt with by simplNonRecBind
696 simplExprF env (Let (NonRec bndr rhs) body) cont
697 = simplNonRecBind env bndr rhs env (contResultType cont) $ \ env ->
698 simplExprF env body cont
701 ---------------------------------
702 simplType :: SimplEnv -> InType -> SimplM OutType
703 -- Kept monadic just so we can do the seqType
705 = seqType new_ty `seq` returnSmpl new_ty
707 new_ty = substTy (getSubst env) ty
711 %************************************************************************
715 %************************************************************************
718 simplLam env fun cont
721 zap_it = mkLamBndrZapper fun (countArgs cont)
722 cont_ty = contResultType cont
724 -- Type-beta reduction
725 go env (Lam bndr body) (ApplyTo _ (Type ty_arg) arg_se body_cont)
726 = ASSERT( isTyVar bndr )
727 tick (BetaReduction bndr) `thenSmpl_`
728 simplType (setInScope arg_se env) ty_arg `thenSmpl` \ ty_arg' ->
729 go (extendSubst env bndr (DoneTy ty_arg')) body body_cont
731 -- Ordinary beta reduction
732 go env (Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont)
733 = tick (BetaReduction bndr) `thenSmpl_`
734 simplNonRecBind env (zap_it bndr) arg arg_se cont_ty $ \ env ->
735 go env body body_cont
737 -- Not enough args, so there are real lambdas left to put in the result
738 go env lam@(Lam _ _) cont
739 = simplLamBndrs env bndrs `thenSmpl` \ (env, bndrs') ->
740 simplExpr env body `thenSmpl` \ body' ->
741 mkLam env bndrs' body' cont `thenSmpl` \ (floats, new_lam) ->
742 addFloats env floats $ \ env ->
743 rebuild env new_lam cont
745 (bndrs,body) = collectBinders lam
747 -- Exactly enough args
748 go env expr cont = simplExprF env expr cont
750 mkLamBndrZapper :: CoreExpr -- Function
751 -> Int -- Number of args supplied, *including* type args
752 -> Id -> Id -- Use this to zap the binders
753 mkLamBndrZapper fun n_args
754 | n_args >= n_params fun = \b -> b -- Enough args
755 | otherwise = \b -> zapLamIdInfo b
757 -- NB: we count all the args incl type args
758 -- so we must count all the binders (incl type lambdas)
759 n_params (Note _ e) = n_params e
760 n_params (Lam b e) = 1 + n_params e
761 n_params other = 0::Int
765 %************************************************************************
769 %************************************************************************
772 simplNote env (Coerce to from) body cont
774 in_scope = getInScope env
776 addCoerce s1 k1 (CoerceIt t1 cont)
777 -- coerce T1 S1 (coerce S1 K1 e)
780 -- coerce T1 K1 e, otherwise
782 -- For example, in the initial form of a worker
783 -- we may find (coerce T (coerce S (\x.e))) y
784 -- and we'd like it to simplify to e[y/x] in one round
786 | t1 `eqType` k1 = cont -- The coerces cancel out
787 | otherwise = CoerceIt t1 cont -- They don't cancel, but
788 -- the inner one is redundant
790 addCoerce t1t2 s1s2 (ApplyTo dup arg arg_se cont)
791 | Just (s1, s2) <- splitFunTy_maybe s1s2
792 -- (coerce (T1->T2) (S1->S2) F) E
794 -- coerce T2 S2 (F (coerce S1 T1 E))
796 -- t1t2 must be a function type, T1->T2
797 -- but s1s2 might conceivably not be
799 -- When we build the ApplyTo we can't mix the out-types
800 -- with the InExpr in the argument, so we simply substitute
801 -- to make it all consistent. It's a bit messy.
802 -- But it isn't a common case.
804 (t1,t2) = splitFunTy t1t2
805 new_arg = mkCoerce2 s1 t1 (substExpr (mkSubst in_scope (getSubstEnv arg_se)) arg)
807 ApplyTo dup new_arg (zapSubstEnv env) (addCoerce t2 s2 cont)
809 addCoerce to' _ cont = CoerceIt to' cont
811 simplType env to `thenSmpl` \ to' ->
812 simplType env from `thenSmpl` \ from' ->
813 simplExprF env body (addCoerce to' from' cont)
816 -- Hack: we only distinguish subsumed cost centre stacks for the purposes of
817 -- inlining. All other CCCSs are mapped to currentCCS.
818 simplNote env (SCC cc) e cont
819 = simplExpr (setEnclosingCC env currentCCS) e `thenSmpl` \ e' ->
820 rebuild env (mkSCC cc e') cont
822 simplNote env InlineCall e cont
823 = simplExprF env e (InlinePlease cont)
825 -- See notes with SimplMonad.inlineMode
826 simplNote env InlineMe e cont
827 | contIsRhsOrArg cont -- Totally boring continuation; see notes above
828 = -- Don't inline inside an INLINE expression
829 simplExpr (setMode inlineMode env ) e `thenSmpl` \ e' ->
830 rebuild env (mkInlineMe e') cont
832 | otherwise -- Dissolve the InlineMe note if there's
833 -- an interesting context of any kind to combine with
834 -- (even a type application -- anything except Stop)
835 = simplExprF env e cont
839 %************************************************************************
841 \subsection{Dealing with calls}
843 %************************************************************************
846 simplVar env var cont
847 = case lookupIdSubst (getSubst env) var of
848 DoneEx e -> simplExprF (zapSubstEnv env) e cont
849 ContEx se e -> simplExprF (setSubstEnv env se) e cont
850 DoneId var1 occ -> WARN( not (isInScope var1 (getSubst env)) && mustHaveLocalBinding var1,
851 text "simplVar:" <+> ppr var )
852 completeCall (zapSubstEnv env) var1 occ cont
853 -- The template is already simplified, so don't re-substitute.
854 -- This is VITAL. Consider
856 -- let y = \z -> ...x... in
858 -- We'll clone the inner \x, adding x->x' in the id_subst
859 -- Then when we inline y, we must *not* replace x by x' in
860 -- the inlined copy!!
862 ---------------------------------------------------------
863 -- Dealing with a call site
865 completeCall env var occ_info cont
866 = -- Simplify the arguments
867 getDOptsSmpl `thenSmpl` \ dflags ->
869 chkr = getSwitchChecker env
870 (args, call_cont, inline_call) = getContArgs chkr var cont
873 simplifyArgs env fn_ty args (contResultType call_cont) $ \ env args ->
875 -- Next, look for rules or specialisations that match
877 -- It's important to simplify the args first, because the rule-matcher
878 -- doesn't do substitution as it goes. We don't want to use subst_args
879 -- (defined in the 'where') because that throws away useful occurrence info,
880 -- and perhaps-very-important specialisations.
882 -- Some functions have specialisations *and* are strict; in this case,
883 -- we don't want to inline the wrapper of the non-specialised thing; better
884 -- to call the specialised thing instead.
885 -- We used to use the black-listing mechanism to ensure that inlining of
886 -- the wrapper didn't occur for things that have specialisations till a
887 -- later phase, so but now we just try RULES first
889 -- You might think that we shouldn't apply rules for a loop breaker:
890 -- doing so might give rise to an infinite loop, because a RULE is
891 -- rather like an extra equation for the function:
892 -- RULE: f (g x) y = x+y
895 -- But it's too drastic to disable rules for loop breakers.
896 -- Even the foldr/build rule would be disabled, because foldr
897 -- is recursive, and hence a loop breaker:
898 -- foldr k z (build g) = g k z
899 -- So it's up to the programmer: rules can cause divergence
902 in_scope = getInScope env
903 maybe_rule = case activeRule env of
904 Nothing -> Nothing -- No rules apply
905 Just act_fn -> lookupRule act_fn in_scope var args
908 Just (rule_name, rule_rhs) ->
909 tick (RuleFired rule_name) `thenSmpl_`
910 (if dopt Opt_D_dump_inlinings dflags then
911 pprTrace "Rule fired" (vcat [
912 text "Rule:" <+> ptext rule_name,
913 text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
914 text "After: " <+> pprCoreExpr rule_rhs,
915 text "Cont: " <+> ppr call_cont])
918 simplExprF env rule_rhs call_cont ;
920 Nothing -> -- No rules
922 -- Next, look for an inlining
924 arg_infos = [ interestingArg arg | arg <- args, isValArg arg]
926 interesting_cont = interestingCallContext (notNull args)
930 active_inline = activeInline env var occ_info
931 maybe_inline = callSiteInline dflags active_inline inline_call occ_info
932 var arg_infos interesting_cont
934 case maybe_inline of {
935 Just unfolding -- There is an inlining!
936 -> tick (UnfoldingDone var) `thenSmpl_`
937 makeThatCall env var unfolding args call_cont
940 Nothing -> -- No inlining!
943 rebuild env (mkApps (Var var) args) call_cont
946 makeThatCall :: SimplEnv
948 -> InExpr -- Inlined function rhs
949 -> [OutExpr] -- Arguments, already simplified
950 -> SimplCont -- After the call
951 -> SimplM FloatsWithExpr
952 -- Similar to simplLam, but this time
953 -- the arguments are already simplified
954 makeThatCall orig_env var fun@(Lam _ _) args cont
955 = go orig_env fun args
957 zap_it = mkLamBndrZapper fun (length args)
959 -- Type-beta reduction
960 go env (Lam bndr body) (Type ty_arg : args)
961 = ASSERT( isTyVar bndr )
962 tick (BetaReduction bndr) `thenSmpl_`
963 go (extendSubst env bndr (DoneTy ty_arg)) body args
965 -- Ordinary beta reduction
966 go env (Lam bndr body) (arg : args)
967 = tick (BetaReduction bndr) `thenSmpl_`
968 simplNonRecX env (zap_it bndr) arg $ \ env ->
971 -- Not enough args, so there are real lambdas left to put in the result
973 = simplExprF env fun (pushContArgs orig_env args cont)
974 -- NB: orig_env; the correct environment to capture with
975 -- the arguments.... env has been augmented with substitutions
976 -- from the beta reductions.
978 makeThatCall env var fun args cont
979 = simplExprF env fun (pushContArgs env args cont)
983 %************************************************************************
985 \subsection{Arguments}
987 %************************************************************************
990 ---------------------------------------------------------
991 -- Simplifying the arguments of a call
993 simplifyArgs :: SimplEnv
994 -> OutType -- Type of the function
995 -> [(InExpr, SimplEnv, Bool)] -- Details of the arguments
996 -> OutType -- Type of the continuation
997 -> (SimplEnv -> [OutExpr] -> SimplM FloatsWithExpr)
998 -> SimplM FloatsWithExpr
1000 -- [CPS-like because of strict arguments]
1002 -- Simplify the arguments to a call.
1003 -- This part of the simplifier may break the no-shadowing invariant
1005 -- f (...(\a -> e)...) (case y of (a,b) -> e')
1006 -- where f is strict in its second arg
1007 -- If we simplify the innermost one first we get (...(\a -> e)...)
1008 -- Simplifying the second arg makes us float the case out, so we end up with
1009 -- case y of (a,b) -> f (...(\a -> e)...) e'
1010 -- So the output does not have the no-shadowing invariant. However, there is
1011 -- no danger of getting name-capture, because when the first arg was simplified
1012 -- we used an in-scope set that at least mentioned all the variables free in its
1013 -- static environment, and that is enough.
1015 -- We can't just do innermost first, or we'd end up with a dual problem:
1016 -- case x of (a,b) -> f e (...(\a -> e')...)
1018 -- I spent hours trying to recover the no-shadowing invariant, but I just could
1019 -- not think of an elegant way to do it. The simplifier is already knee-deep in
1020 -- continuations. We have to keep the right in-scope set around; AND we have
1021 -- to get the effect that finding (error "foo") in a strict arg position will
1022 -- discard the entire application and replace it with (error "foo"). Getting
1023 -- all this at once is TOO HARD!
1025 simplifyArgs env fn_ty args cont_ty thing_inside
1026 = go env fn_ty args thing_inside
1028 go env fn_ty [] thing_inside = thing_inside env []
1029 go env fn_ty (arg:args) thing_inside = simplifyArg env fn_ty arg cont_ty $ \ env arg' ->
1030 go env (applyTypeToArg fn_ty arg') args $ \ env args' ->
1031 thing_inside env (arg':args')
1033 simplifyArg env fn_ty (Type ty_arg, se, _) cont_ty thing_inside
1034 = simplType (setInScope se env) ty_arg `thenSmpl` \ new_ty_arg ->
1035 thing_inside env (Type new_ty_arg)
1037 simplifyArg env fn_ty (val_arg, arg_se, is_strict) cont_ty thing_inside
1039 = simplStrictArg AnArg env val_arg arg_se arg_ty cont_ty thing_inside
1042 = simplExprF (setInScope arg_se env) val_arg
1043 (mkStop arg_ty AnArg) `thenSmpl` \ (floats, arg1) ->
1044 addFloats env floats $ \ env ->
1045 thing_inside env arg1
1047 arg_ty = funArgTy fn_ty
1050 simplStrictArg :: LetRhsFlag
1051 -> SimplEnv -- The env of the call
1052 -> InExpr -> SimplEnv -- The arg plus its env
1053 -> OutType -- arg_ty: type of the argument
1054 -> OutType -- cont_ty: Type of thing computed by the context
1055 -> (SimplEnv -> OutExpr -> SimplM FloatsWithExpr)
1056 -- Takes an expression of type rhs_ty,
1057 -- returns an expression of type cont_ty
1058 -- The env passed to this continuation is the
1059 -- env of the call, plus any new in-scope variables
1060 -> SimplM FloatsWithExpr -- An expression of type cont_ty
1062 simplStrictArg is_rhs call_env arg arg_env arg_ty cont_ty thing_inside
1063 = simplExprF (setInScope arg_env call_env) arg
1064 (ArgOf is_rhs arg_ty cont_ty (\ new_env -> thing_inside (setInScope call_env new_env)))
1065 -- Notice the way we use arg_env (augmented with in-scope vars from call_env)
1066 -- to simplify the argument
1067 -- and call-env (augmented with in-scope vars from the arg) to pass to the continuation
1071 %************************************************************************
1073 \subsection{mkAtomicArgs}
1075 %************************************************************************
1077 mkAtomicArgs takes a putative RHS, checks whether it's a PAP or
1078 constructor application and, if so, converts it to ANF, so that the
1079 resulting thing can be inlined more easily. Thus
1086 There are three sorts of binding context, specified by the two
1092 N N Top-level or recursive Only bind args of lifted type
1094 N Y Non-top-level and non-recursive, Bind args of lifted type, or
1095 but lazy unlifted-and-ok-for-speculation
1097 Y Y Non-top-level, non-recursive, Bind all args
1098 and strict (demanded)
1105 there is no point in transforming to
1107 x = case (y div# z) of r -> MkC r
1109 because the (y div# z) can't float out of the let. But if it was
1110 a *strict* let, then it would be a good thing to do. Hence the
1111 context information.
1114 mkAtomicArgs :: Bool -- A strict binding
1115 -> Bool -- OK to float unlifted args
1117 -> SimplM (OrdList (OutId,OutExpr), -- The floats (unusually) may include
1118 OutExpr) -- things that need case-binding,
1119 -- if the strict-binding flag is on
1121 mkAtomicArgs is_strict ok_float_unlifted rhs
1122 | (Var fun, args) <- collectArgs rhs, -- It's an application
1123 isDataConId fun || valArgCount args < idArity fun -- And it's a constructor or PAP
1124 = go fun nilOL [] args -- Have a go
1126 | otherwise = bale_out -- Give up
1129 bale_out = returnSmpl (nilOL, rhs)
1131 go fun binds rev_args []
1132 = returnSmpl (binds, mkApps (Var fun) (reverse rev_args))
1134 go fun binds rev_args (arg : args)
1135 | exprIsTrivial arg -- Easy case
1136 = go fun binds (arg:rev_args) args
1138 | not can_float_arg -- Can't make this arg atomic
1139 = bale_out -- ... so give up
1141 | otherwise -- Don't forget to do it recursively
1142 -- E.g. x = a:b:c:[]
1143 = mkAtomicArgs is_strict ok_float_unlifted arg `thenSmpl` \ (arg_binds, arg') ->
1144 newId FSLIT("a") arg_ty `thenSmpl` \ arg_id ->
1145 go fun ((arg_binds `snocOL` (arg_id,arg')) `appOL` binds)
1146 (Var arg_id : rev_args) args
1148 arg_ty = exprType arg
1149 can_float_arg = is_strict
1150 || not (isUnLiftedType arg_ty)
1151 || (ok_float_unlifted && exprOkForSpeculation arg)
1154 addAtomicBinds :: SimplEnv -> [(OutId,OutExpr)]
1155 -> (SimplEnv -> SimplM (FloatsWith a))
1156 -> SimplM (FloatsWith a)
1157 addAtomicBinds env [] thing_inside = thing_inside env
1158 addAtomicBinds env ((v,r):bs) thing_inside = addAuxiliaryBind env (NonRec v r) $ \ env ->
1159 addAtomicBinds env bs thing_inside
1161 addAtomicBindsE :: SimplEnv -> [(OutId,OutExpr)]
1162 -> (SimplEnv -> SimplM FloatsWithExpr)
1163 -> SimplM FloatsWithExpr
1164 -- Same again, but this time we're in an expression context,
1165 -- and may need to do some case bindings
1167 addAtomicBindsE env [] thing_inside
1169 addAtomicBindsE env ((v,r):bs) thing_inside
1170 | needsCaseBinding (idType v) r
1171 = addAtomicBindsE (addNewInScopeIds env [v]) bs thing_inside `thenSmpl` \ (floats, expr) ->
1172 WARN( exprIsTrivial expr, ppr v <+> pprCoreExpr expr )
1173 returnSmpl (emptyFloats env, Case r v [(DEFAULT,[], wrapFloats floats expr)])
1176 = addAuxiliaryBind env (NonRec v r) $ \ env ->
1177 addAtomicBindsE env bs thing_inside
1181 %************************************************************************
1183 \subsection{The main rebuilder}
1185 %************************************************************************
1188 rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM FloatsWithExpr
1190 rebuild env expr (Stop _ _ _) = rebuildDone env expr
1191 rebuild env expr (ArgOf _ _ _ cont_fn) = cont_fn env expr
1192 rebuild env expr (CoerceIt to_ty cont) = rebuild env (mkCoerce to_ty expr) cont
1193 rebuild env expr (InlinePlease cont) = rebuild env (Note InlineCall expr) cont
1194 rebuild env expr (Select _ bndr alts se cont) = rebuildCase (setInScope se env) expr bndr alts cont
1195 rebuild env expr (ApplyTo _ arg se cont) = rebuildApp (setInScope se env) expr arg cont
1197 rebuildApp env fun arg cont
1198 = simplExpr env arg `thenSmpl` \ arg' ->
1199 rebuild env (App fun arg') cont
1201 rebuildDone env expr = returnSmpl (emptyFloats env, expr)
1205 %************************************************************************
1207 \subsection{Functions dealing with a case}
1209 %************************************************************************
1211 Blob of helper functions for the "case-of-something-else" situation.
1214 ---------------------------------------------------------
1215 -- Eliminate the case if possible
1217 rebuildCase :: SimplEnv
1218 -> OutExpr -- Scrutinee
1219 -> InId -- Case binder
1220 -> [InAlt] -- Alternatives
1222 -> SimplM FloatsWithExpr
1224 rebuildCase env scrut case_bndr alts cont
1225 | Just (con,args) <- exprIsConApp_maybe scrut
1226 -- Works when the scrutinee is a variable with a known unfolding
1227 -- as well as when it's an explicit constructor application
1228 = knownCon env (DataAlt con) args case_bndr alts cont
1230 | Lit lit <- scrut -- No need for same treatment as constructors
1231 -- because literals are inlined more vigorously
1232 = knownCon env (LitAlt lit) [] case_bndr alts cont
1235 = prepareAlts scrut case_bndr alts `thenSmpl` \ (better_alts, handled_cons) ->
1237 -- Deal with the case binder, and prepare the continuation;
1238 -- The new subst_env is in place
1239 prepareCaseCont env better_alts cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) ->
1240 addFloats env floats $ \ env ->
1242 -- Deal with variable scrutinee
1243 simplCaseBinder env scrut case_bndr `thenSmpl` \ (alt_env, case_bndr', zap_occ_info) ->
1245 -- Deal with the case alternatives
1246 simplAlts alt_env zap_occ_info handled_cons
1247 case_bndr' better_alts dup_cont `thenSmpl` \ alts' ->
1249 -- Put the case back together
1250 mkCase scrut case_bndr' alts' `thenSmpl` \ case_expr ->
1252 -- Notice that rebuildDone returns the in-scope set from env, not alt_env
1253 -- The case binder *not* scope over the whole returned case-expression
1254 rebuild env case_expr nondup_cont
1257 simplCaseBinder checks whether the scrutinee is a variable, v. If so,
1258 try to eliminate uses of v in the RHSs in favour of case_bndr; that
1259 way, there's a chance that v will now only be used once, and hence
1264 There is a time we *don't* want to do that, namely when
1265 -fno-case-of-case is on. This happens in the first simplifier pass,
1266 and enhances full laziness. Here's the bad case:
1267 f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )
1268 If we eliminate the inner case, we trap it inside the I# v -> arm,
1269 which might prevent some full laziness happening. I've seen this
1270 in action in spectral/cichelli/Prog.hs:
1271 [(m,n) | m <- [1..max], n <- [1..max]]
1272 Hence the check for NoCaseOfCase.
1276 There is another situation when we don't want to do it. If we have
1278 case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }
1279 ...other cases .... }
1281 We'll perform the binder-swap for the outer case, giving
1283 case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }
1284 ...other cases .... }
1286 But there is no point in doing it for the inner case, because w1 can't
1287 be inlined anyway. Furthermore, doing the case-swapping involves
1288 zapping w2's occurrence info (see paragraphs that follow), and that
1289 forces us to bind w2 when doing case merging. So we get
1291 case x of w1 { A -> let w2 = w1 in e1
1292 B -> let w2 = w1 in e2
1293 ...other cases .... }
1295 This is plain silly in the common case where w2 is dead.
1297 Even so, I can't see a good way to implement this idea. I tried
1298 not doing the binder-swap if the scrutinee was already evaluated
1299 but that failed big-time:
1303 case v of w { MkT x ->
1304 case x of x1 { I# y1 ->
1305 case x of x2 { I# y2 -> ...
1307 Notice that because MkT is strict, x is marked "evaluated". But to
1308 eliminate the last case, we must either make sure that x (as well as
1309 x1) has unfolding MkT y1. THe straightforward thing to do is to do
1310 the binder-swap. So this whole note is a no-op.
1314 If we replace the scrutinee, v, by tbe case binder, then we have to nuke
1315 any occurrence info (eg IAmDead) in the case binder, because the
1316 case-binder now effectively occurs whenever v does. AND we have to do
1317 the same for the pattern-bound variables! Example:
1319 (case x of { (a,b) -> a }) (case x of { (p,q) -> q })
1321 Here, b and p are dead. But when we move the argment inside the first
1322 case RHS, and eliminate the second case, we get
1324 case x or { (a,b) -> a b }
1326 Urk! b is alive! Reason: the scrutinee was a variable, and case elimination
1327 happened. Hence the zap_occ_info function returned by simplCaseBinder
1330 simplCaseBinder env (Var v) case_bndr
1331 | not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
1333 -- Failed try [see Note 2 above]
1334 -- not (isEvaldUnfolding (idUnfolding v))
1336 = simplBinder env (zap case_bndr) `thenSmpl` \ (env, case_bndr') ->
1337 returnSmpl (modifyInScope env v case_bndr', case_bndr', zap)
1338 -- We could extend the substitution instead, but it would be
1339 -- a hack because then the substitution wouldn't be idempotent
1340 -- any more (v is an OutId). And this just just as well.
1342 zap b = b `setIdOccInfo` NoOccInfo
1344 simplCaseBinder env other_scrut case_bndr
1345 = simplBinder env case_bndr `thenSmpl` \ (env, case_bndr') ->
1346 returnSmpl (env, case_bndr', \ bndr -> bndr) -- NoOp on bndr
1352 simplAlts :: SimplEnv
1353 -> (InId -> InId) -- Occ-info zapper
1354 -> [AltCon] -- Alternatives the scrutinee can't be
1355 -- in the default case
1356 -> OutId -- Case binder
1357 -> [InAlt] -> SimplCont
1358 -> SimplM [OutAlt] -- Includes the continuation
1360 simplAlts env zap_occ_info handled_cons case_bndr' alts cont'
1361 = mapSmpl simpl_alt alts
1363 inst_tys' = tyConAppArgs (idType case_bndr')
1365 simpl_alt (DEFAULT, _, rhs)
1367 -- In the default case we record the constructors that the
1368 -- case-binder *can't* be.
1369 -- We take advantage of any OtherCon info in the case scrutinee
1370 case_bndr_w_unf = case_bndr' `setIdUnfolding` mkOtherCon handled_cons
1371 env_with_unf = modifyInScope env case_bndr' case_bndr_w_unf
1373 simplExprC env_with_unf rhs cont' `thenSmpl` \ rhs' ->
1374 returnSmpl (DEFAULT, [], rhs')
1376 simpl_alt (con, vs, rhs)
1377 = -- Deal with the pattern-bound variables
1378 -- Mark the ones that are in ! positions in the data constructor
1379 -- as certainly-evaluated.
1380 -- NB: it happens that simplBinders does *not* erase the OtherCon
1381 -- form of unfolding, so it's ok to add this info before
1382 -- doing simplBinders
1383 simplBinders env (add_evals con vs) `thenSmpl` \ (env, vs') ->
1385 -- Bind the case-binder to (con args)
1387 unfolding = mkUnfolding False (mkAltExpr con vs' inst_tys')
1388 env_with_unf = modifyInScope env case_bndr' (case_bndr' `setIdUnfolding` unfolding)
1390 simplExprC env_with_unf rhs cont' `thenSmpl` \ rhs' ->
1391 returnSmpl (con, vs', rhs')
1394 -- add_evals records the evaluated-ness of the bound variables of
1395 -- a case pattern. This is *important*. Consider
1396 -- data T = T !Int !Int
1398 -- case x of { T a b -> T (a+1) b }
1400 -- We really must record that b is already evaluated so that we don't
1401 -- go and re-evaluate it when constructing the result.
1403 add_evals (DataAlt dc) vs = cat_evals vs (dataConRepStrictness dc)
1404 add_evals other_con vs = vs
1406 cat_evals [] [] = []
1407 cat_evals (v:vs) (str:strs)
1408 | isTyVar v = v : cat_evals vs (str:strs)
1409 | isMarkedStrict str = evald_v : cat_evals vs strs
1410 | otherwise = zapped_v : cat_evals vs strs
1412 zapped_v = zap_occ_info v
1413 evald_v = zapped_v `setIdUnfolding` mkOtherCon []
1417 %************************************************************************
1419 \subsection{Known constructor}
1421 %************************************************************************
1423 We are a bit careful with occurrence info. Here's an example
1425 (\x* -> case x of (a*, b) -> f a) (h v, e)
1427 where the * means "occurs once". This effectively becomes
1428 case (h v, e) of (a*, b) -> f a)
1430 let a* = h v; b = e in f a
1434 All this should happen in one sweep.
1437 knownCon :: SimplEnv -> AltCon -> [OutExpr]
1438 -> InId -> [InAlt] -> SimplCont
1439 -> SimplM FloatsWithExpr
1441 knownCon env con args bndr alts cont
1442 = tick (KnownBranch bndr) `thenSmpl_`
1443 case findAlt con alts of
1444 (DEFAULT, bs, rhs) -> ASSERT( null bs )
1445 simplNonRecX env bndr scrut $ \ env ->
1446 -- This might give rise to a binding with non-atomic args
1447 -- like x = Node (f x) (g x)
1448 -- but no harm will be done
1449 simplExprF env rhs cont
1452 LitAlt lit -> Lit lit
1453 DataAlt dc -> mkConApp dc args
1455 (LitAlt lit, bs, rhs) -> ASSERT( null bs )
1456 simplNonRecX env bndr (Lit lit) $ \ env ->
1457 simplExprF env rhs cont
1459 (DataAlt dc, bs, rhs) -> ASSERT( length bs + n_tys == length args )
1460 bind_args env bs (drop n_tys args) $ \ env ->
1462 con_app = mkConApp dc (take n_tys args ++ con_args)
1463 con_args = [substExpr (getSubst env) (varToCoreExpr b) | b <- bs]
1464 -- args are aready OutExprs, but bs are InIds
1466 simplNonRecX env bndr con_app $ \ env ->
1467 simplExprF env rhs cont
1469 n_tys = dataConNumInstArgs dc -- Non-existential type args
1471 bind_args env [] _ thing_inside = thing_inside env
1473 bind_args env (b:bs) (Type ty : args) thing_inside
1474 = bind_args (extendSubst env b (DoneTy ty)) bs args thing_inside
1476 bind_args env (b:bs) (arg : args) thing_inside
1477 = simplNonRecX env b arg $ \ env ->
1478 bind_args env bs args thing_inside
1482 %************************************************************************
1484 \subsection{Duplicating continuations}
1486 %************************************************************************
1489 prepareCaseCont :: SimplEnv
1490 -> [InAlt] -> SimplCont
1491 -> SimplM (FloatsWith (SimplCont,SimplCont))
1492 -- Return a duplicatable continuation, a non-duplicable part
1493 -- plus some extra bindings
1495 -- No need to make it duplicatable if there's only one alternative
1496 prepareCaseCont env [alt] cont = returnSmpl (emptyFloats env, (cont, mkBoringStop (contResultType cont)))
1497 prepareCaseCont env alts cont = mkDupableCont env cont
1501 mkDupableCont :: SimplEnv -> SimplCont
1502 -> SimplM (FloatsWith (SimplCont, SimplCont))
1504 mkDupableCont env cont
1505 | contIsDupable cont
1506 = returnSmpl (emptyFloats env, (cont, mkBoringStop (contResultType cont)))
1508 mkDupableCont env (CoerceIt ty cont)
1509 = mkDupableCont env cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) ->
1510 returnSmpl (floats, (CoerceIt ty dup_cont, nondup_cont))
1512 mkDupableCont env (InlinePlease cont)
1513 = mkDupableCont env cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) ->
1514 returnSmpl (floats, (InlinePlease dup_cont, nondup_cont))
1516 mkDupableCont env cont@(ArgOf _ arg_ty _ _)
1517 = returnSmpl (emptyFloats env, (mkBoringStop arg_ty, cont))
1518 -- Do *not* duplicate an ArgOf continuation
1519 -- Because ArgOf continuations are opaque, we gain nothing by
1520 -- propagating them into the expressions, and we do lose a lot.
1521 -- Here's an example:
1522 -- && (case x of { T -> F; F -> T }) E
1523 -- Now, && is strict so we end up simplifying the case with
1524 -- an ArgOf continuation. If we let-bind it, we get
1526 -- let $j = \v -> && v E
1527 -- in simplExpr (case x of { T -> F; F -> T })
1528 -- (ArgOf (\r -> $j r)
1529 -- And after simplifying more we get
1531 -- let $j = \v -> && v E
1532 -- in case of { T -> $j F; F -> $j T }
1533 -- Which is a Very Bad Thing
1535 -- The desire not to duplicate is the entire reason that
1536 -- mkDupableCont returns a pair of continuations.
1538 -- The original plan had:
1539 -- e.g. (...strict-fn...) [...hole...]
1541 -- let $j = \a -> ...strict-fn...
1542 -- in $j [...hole...]
1544 mkDupableCont env (ApplyTo _ arg se cont)
1545 = -- e.g. [...hole...] (...arg...)
1547 -- let a = ...arg...
1548 -- in [...hole...] a
1549 simplExpr (setInScope se env) arg `thenSmpl` \ arg' ->
1551 mkDupableCont env cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) ->
1552 addFloats env floats $ \ env ->
1554 if exprIsDupable arg' then
1555 returnSmpl (emptyFloats env, (ApplyTo OkToDup arg' (zapSubstEnv se) dup_cont, nondup_cont))
1557 newId FSLIT("a") (exprType arg') `thenSmpl` \ arg_id ->
1559 tick (CaseOfCase arg_id) `thenSmpl_`
1560 -- Want to tick here so that we go round again,
1561 -- and maybe copy or inline the code.
1562 -- Not strictly CaseOfCase, but never mind
1564 returnSmpl (unitFloat env arg_id arg',
1565 (ApplyTo OkToDup (Var arg_id) (zapSubstEnv se) dup_cont,
1567 -- But what if the arg should be case-bound?
1568 -- This has been this way for a long time, so I'll leave it,
1569 -- but I can't convince myself that it's right.
1572 mkDupableCont env (Select _ case_bndr alts se cont)
1573 = -- e.g. (case [...hole...] of { pi -> ei })
1575 -- let ji = \xij -> ei
1576 -- in case [...hole...] of { pi -> ji xij }
1577 tick (CaseOfCase case_bndr) `thenSmpl_`
1579 alt_env = setInScope se env
1581 prepareCaseCont alt_env alts cont `thenSmpl` \ (floats1, (dup_cont, nondup_cont)) ->
1582 addFloats alt_env floats1 $ \ alt_env ->
1584 simplBinder alt_env case_bndr `thenSmpl` \ (alt_env, case_bndr') ->
1585 -- NB: simplBinder does not zap deadness occ-info, so
1586 -- a dead case_bndr' will still advertise its deadness
1587 -- This is really important because in
1588 -- case e of b { (# a,b #) -> ... }
1589 -- b is always dead, and indeed we are not allowed to bind b to (# a,b #),
1590 -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.
1591 -- In the new alts we build, we have the new case binder, so it must retain
1594 mkDupableAlts alt_env case_bndr' alts dup_cont `thenSmpl` \ (floats2, alts') ->
1595 addFloats alt_env floats2 $ \ alt_env ->
1596 returnSmpl (emptyFloats alt_env,
1597 (Select OkToDup case_bndr' alts' (zapSubstEnv se)
1598 (mkBoringStop (contResultType dup_cont)),
1601 mkDupableAlts :: SimplEnv -> OutId -> [InAlt] -> SimplCont
1602 -> SimplM (FloatsWith [InAlt])
1603 -- Absorbs the continuation into the new alternatives
1605 mkDupableAlts env case_bndr' alts dupable_cont
1608 go env [] = returnSmpl (emptyFloats env, [])
1610 = mkDupableAlt env case_bndr' dupable_cont alt `thenSmpl` \ (floats1, alt') ->
1611 addFloats env floats1 $ \ env ->
1612 go env alts `thenSmpl` \ (floats2, alts') ->
1613 returnSmpl (floats2, alt' : alts')
1615 mkDupableAlt env case_bndr' cont alt@(con, bndrs, rhs)
1616 = simplBinders env bndrs `thenSmpl` \ (env, bndrs') ->
1617 simplExprC env rhs cont `thenSmpl` \ rhs' ->
1619 if exprIsDupable rhs' then
1620 returnSmpl (emptyFloats env, (con, bndrs', rhs'))
1621 -- It is worth checking for a small RHS because otherwise we
1622 -- get extra let bindings that may cause an extra iteration of the simplifier to
1623 -- inline back in place. Quite often the rhs is just a variable or constructor.
1624 -- The Ord instance of Maybe in PrelMaybe.lhs, for example, took several extra
1625 -- iterations because the version with the let bindings looked big, and so wasn't
1626 -- inlined, but after the join points had been inlined it looked smaller, and so
1629 -- NB: we have to check the size of rhs', not rhs.
1630 -- Duplicating a small InAlt might invalidate occurrence information
1631 -- However, if it *is* dupable, we return the *un* simplified alternative,
1632 -- because otherwise we'd need to pair it up with an empty subst-env....
1633 -- but we only have one env shared between all the alts.
1634 -- (Remember we must zap the subst-env before re-simplifying something).
1635 -- Rather than do this we simply agree to re-simplify the original (small) thing later.
1639 rhs_ty' = exprType rhs'
1640 used_bndrs' = filter (not . isDeadBinder) (case_bndr' : bndrs')
1641 -- The deadness info on the new binders is unscathed
1643 -- If we try to lift a primitive-typed something out
1644 -- for let-binding-purposes, we will *caseify* it (!),
1645 -- with potentially-disastrous strictness results. So
1646 -- instead we turn it into a function: \v -> e
1647 -- where v::State# RealWorld#. The value passed to this function
1648 -- is realworld#, which generates (almost) no code.
1650 -- There's a slight infelicity here: we pass the overall
1651 -- case_bndr to all the join points if it's used in *any* RHS,
1652 -- because we don't know its usage in each RHS separately
1654 -- We used to say "&& isUnLiftedType rhs_ty'" here, but now
1655 -- we make the join point into a function whenever used_bndrs'
1656 -- is empty. This makes the join-point more CPR friendly.
1657 -- Consider: let j = if .. then I# 3 else I# 4
1658 -- in case .. of { A -> j; B -> j; C -> ... }
1660 -- Now CPR doesn't w/w j because it's a thunk, so
1661 -- that means that the enclosing function can't w/w either,
1662 -- which is a lose. Here's the example that happened in practice:
1663 -- kgmod :: Int -> Int -> Int
1664 -- kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
1668 -- I have seen a case alternative like this:
1669 -- True -> \v -> ...
1670 -- It's a bit silly to add the realWorld dummy arg in this case, making
1673 -- (the \v alone is enough to make CPR happy) but I think it's rare
1675 ( if null used_bndrs'
1676 then newId FSLIT("w") realWorldStatePrimTy `thenSmpl` \ rw_id ->
1677 returnSmpl ([rw_id], [Var realWorldPrimId])
1679 returnSmpl (used_bndrs', map varToCoreExpr used_bndrs')
1680 ) `thenSmpl` \ (final_bndrs', final_args) ->
1682 -- See comment about "$j" name above
1683 newId (encodeFS SLIT("$j")) (mkPiTypes final_bndrs' rhs_ty') `thenSmpl` \ join_bndr ->
1684 -- Notice the funky mkPiTypes. If the contructor has existentials
1685 -- it's possible that the join point will be abstracted over
1686 -- type varaibles as well as term variables.
1687 -- Example: Suppose we have
1688 -- data T = forall t. C [t]
1690 -- case (case e of ...) of
1691 -- C t xs::[t] -> rhs
1692 -- We get the join point
1693 -- let j :: forall t. [t] -> ...
1694 -- j = /\t \xs::[t] -> rhs
1696 -- case (case e of ...) of
1697 -- C t xs::[t] -> j t xs
1699 -- We make the lambdas into one-shot-lambdas. The
1700 -- join point is sure to be applied at most once, and doing so
1701 -- prevents the body of the join point being floated out by
1702 -- the full laziness pass
1703 really_final_bndrs = map one_shot final_bndrs'
1704 one_shot v | isId v = setOneShotLambda v
1706 join_rhs = mkLams really_final_bndrs rhs'
1707 join_call = mkApps (Var join_bndr) final_args
1709 returnSmpl (unitFloat env join_bndr join_rhs, (con, bndrs', join_call))