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,
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 idUnfolding, setIdUnfolding, isDeadBinder,
26 idNewDemandInfo, setIdInfo,
27 setIdOccInfo, zapLamIdInfo, setOneShotLambda,
29 import IdInfo ( OccInfo(..), isLoopBreaker,
34 import NewDemand ( isStrictDmd )
35 import DataCon ( dataConNumInstArgs, dataConRepStrictness )
37 import PprCore ( pprParendExpr, pprCoreExpr )
38 import CoreUnfold ( mkOtherCon, mkUnfolding, otherCons, callSiteInline )
39 import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding,
40 exprIsConApp_maybe, mkPiType, findAlt,
41 exprType, coreAltsType, exprIsValue,
42 exprOkForSpeculation, exprArity, findDefault,
43 mkCoerce, mkSCC, mkInlineMe, mkAltExpr
45 import Rules ( lookupRule )
46 import BasicTypes ( isMarkedStrict )
47 import CostCentre ( currentCCS )
48 import Type ( isUnLiftedType, seqType, mkFunTy, tyConAppArgs,
49 funResultTy, splitFunTy_maybe, splitFunTy, eqType
51 import Subst ( mkSubst, substTy, substExpr,
52 isInScope, lookupIdSubst, simplIdInfo
54 import TysPrim ( realWorldStatePrimTy )
55 import PrelInfo ( realWorldPrimId )
56 import BasicTypes ( TopLevelFlag(..), isTopLevel,
60 import Maybe ( Maybe )
65 The guts of the simplifier is in this module, but the driver loop for
66 the simplifier is in SimplCore.lhs.
69 -----------------------------------------
70 *** IMPORTANT NOTE ***
71 -----------------------------------------
72 The simplifier used to guarantee that the output had no shadowing, but
73 it does not do so any more. (Actually, it never did!) The reason is
74 documented with simplifyArgs.
77 -----------------------------------------
78 *** IMPORTANT NOTE ***
79 -----------------------------------------
80 Many parts of the simplifier return a bunch of "floats" as well as an
81 expression. This is wrapped as a datatype SimplUtils.FloatsWith.
83 All "floats" are let-binds, not case-binds, but some non-rec lets may
84 be unlifted (with RHS ok-for-speculation).
88 -----------------------------------------
89 ORGANISATION OF FUNCTIONS
90 -----------------------------------------
92 - simplify all top-level binders
93 - for NonRec, call simplRecOrTopPair
94 - for Rec, call simplRecBind
97 ------------------------------
98 simplExpr (applied lambda) ==> simplNonRecBind
99 simplExpr (Let (NonRec ...) ..) ==> simplNonRecBind
100 simplExpr (Let (Rec ...) ..) ==> simplify binders; simplRecBind
102 ------------------------------
103 simplRecBind [binders already simplfied]
104 - use simplRecOrTopPair on each pair in turn
106 simplRecOrTopPair [binder already simplified]
107 Used for: recursive bindings (top level and nested)
108 top-level non-recursive bindings
110 - check for PreInlineUnconditionally
114 Used for: non-top-level non-recursive bindings
115 beta reductions (which amount to the same thing)
116 Because it can deal with strict arts, it takes a
117 "thing-inside" and returns an expression
119 - check for PreInlineUnconditionally
120 - simplify binder, including its IdInfo
129 simplNonRecX: [given a *simplified* RHS, but an *unsimplified* binder]
130 Used for: binding case-binder and constr args in a known-constructor case
131 - check for PreInLineUnconditionally
135 ------------------------------
136 simplLazyBind: [binder already simplified, RHS not]
137 Used for: recursive bindings (top level and nested)
138 top-level non-recursive bindings
139 non-top-level, but *lazy* non-recursive bindings
140 [must not be strict or unboxed]
141 Returns floats + an augmented environment, not an expression
142 - substituteIdInfo and add result to in-scope
143 [so that rules are available in rec rhs]
146 - float if exposes constructor or PAP
150 completeNonRecX: [binder and rhs both simplified]
151 - if the the thing needs case binding (unlifted and not ok-for-spec)
157 completeLazyBind: [given a simplified RHS]
158 [used for both rec and non-rec bindings, top level and not]
159 - try PostInlineUnconditionally
160 - add unfolding [this is the only place we add an unfolding]
165 Right hand sides and arguments
166 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
167 In many ways we want to treat
168 (a) the right hand side of a let(rec), and
169 (b) a function argument
170 in the same way. But not always! In particular, we would
171 like to leave these arguments exactly as they are, so they
172 will match a RULE more easily.
177 It's harder to make the rule match if we ANF-ise the constructor,
178 or eta-expand the PAP:
180 f (let { a = g x; b = h x } in (a,b))
183 On the other hand if we see the let-defns
188 then we *do* want to ANF-ise and eta-expand, so that p and q
189 can be safely inlined.
191 Even floating lets out is a bit dubious. For let RHS's we float lets
192 out if that exposes a value, so that the value can be inlined more vigorously.
195 r = let x = e in (x,x)
197 Here, if we float the let out we'll expose a nice constructor. We did experiments
198 that showed this to be a generally good thing. But it was a bad thing to float
199 lets out unconditionally, because that meant they got allocated more often.
201 For function arguments, there's less reason to expose a constructor (it won't
202 get inlined). Just possibly it might make a rule match, but I'm pretty skeptical.
203 So for the moment we don't float lets out of function arguments either.
208 For eta expansion, we want to catch things like
210 case e of (a,b) -> \x -> case a of (p,q) -> \y -> r
212 If the \x was on the RHS of a let, we'd eta expand to bring the two
213 lambdas together. And in general that's a good thing to do. Perhaps
214 we should eta expand wherever we find a (value) lambda? Then the eta
215 expansion at a let RHS can concentrate solely on the PAP case.
218 %************************************************************************
220 \subsection{Bindings}
222 %************************************************************************
225 simplTopBinds :: SimplEnv -> [InBind] -> SimplM [OutBind]
227 simplTopBinds env binds
228 = -- Put all the top-level binders into scope at the start
229 -- so that if a transformation rule has unexpectedly brought
230 -- anything into scope, then we don't get a complaint about that.
231 -- It's rather as if the top-level binders were imported.
232 simplRecBndrs env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') ->
233 simpl_binds env binds bndrs' `thenSmpl` \ (floats, _) ->
234 freeTick SimplifierDone `thenSmpl_`
235 returnSmpl (floatBinds floats)
237 -- We need to track the zapped top-level binders, because
238 -- they should have their fragile IdInfo zapped (notably occurrence info)
239 -- That's why we run down binds and bndrs' simultaneously.
240 simpl_binds :: SimplEnv -> [InBind] -> [OutId] -> SimplM (FloatsWith ())
241 simpl_binds env [] bs = ASSERT( null bs ) returnSmpl (emptyFloats env, ())
242 simpl_binds env (bind:binds) bs = simpl_bind env bind bs `thenSmpl` \ (floats,env) ->
243 addFloats env floats $ \env ->
244 simpl_binds env binds (drop_bs bind bs)
246 drop_bs (NonRec _ _) (_ : bs) = bs
247 drop_bs (Rec prs) bs = drop (length prs) bs
249 simpl_bind env (NonRec b r) (b':_) = simplRecOrTopPair env TopLevel b b' r
250 simpl_bind env (Rec pairs) bs' = simplRecBind env TopLevel pairs bs'
254 %************************************************************************
256 \subsection{simplNonRec}
258 %************************************************************************
260 simplNonRecBind is used for
261 * non-top-level non-recursive lets in expressions
265 * An unsimplified (binder, rhs) pair
266 * The env for the RHS. It may not be the same as the
267 current env because the bind might occur via (\x.E) arg
269 It uses the CPS form because the binding might be strict, in which
270 case we might discard the continuation:
271 let x* = error "foo" in (...x...)
273 It needs to turn unlifted bindings into a @case@. They can arise
274 from, say: (\x -> e) (4# + 3#)
277 simplNonRecBind :: SimplEnv
279 -> InExpr -> SimplEnv -- Arg, with its subst-env
280 -> OutType -- Type of thing computed by the context
281 -> (SimplEnv -> SimplM FloatsWithExpr) -- The body
282 -> SimplM FloatsWithExpr
284 simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside
286 = pprPanic "simplNonRecBind" (ppr bndr <+> ppr rhs)
289 simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside
290 | preInlineUnconditionally env NotTopLevel bndr
291 = tick (PreInlineUnconditionally bndr) `thenSmpl_`
292 thing_inside (extendSubst env bndr (ContEx (getSubstEnv rhs_se) rhs))
295 | isStrictDmd (idNewDemandInfo bndr) || isStrictType (idType bndr) -- A strict let
296 = -- Don't use simplBinder because that doesn't keep
297 -- fragile occurrence in the substitution
298 simplLetBndr env bndr `thenSmpl` \ (env, bndr') ->
299 simplStrictArg env AnRhs rhs rhs_se cont_ty $ \ env rhs1 ->
301 -- Now complete the binding and simplify the body
302 completeNonRecX env True {- strict -} bndr bndr' rhs1 thing_inside
304 | otherwise -- Normal, lazy case
305 = -- Don't use simplBinder because that doesn't keep
306 -- fragile occurrence in the substitution
307 simplLetBndr env bndr `thenSmpl` \ (env, bndr') ->
308 simplLazyBind env NotTopLevel NonRecursive
309 bndr bndr' rhs rhs_se `thenSmpl` \ (floats, env) ->
310 addFloats env floats thing_inside
313 A specialised variant of simplNonRec used when the RHS is already simplified, notably
314 in knownCon. It uses case-binding where necessary.
317 simplNonRecX :: SimplEnv
318 -> InId -- Old binder
319 -> OutExpr -- Simplified RHS
320 -> (SimplEnv -> SimplM FloatsWithExpr)
321 -> SimplM FloatsWithExpr
323 simplNonRecX env bndr new_rhs thing_inside
324 | preInlineUnconditionally env NotTopLevel bndr
325 -- This happens; for example, the case_bndr during case of
326 -- known constructor: case (a,b) of x { (p,q) -> ... }
327 -- Here x isn't mentioned in the RHS, so we don't want to
328 -- create the (dead) let-binding let x = (a,b) in ...
330 -- Similarly, single occurrences can be inlined vigourously
331 -- e.g. case (f x, g y) of (a,b) -> ....
332 -- If a,b occur once we can avoid constructing the let binding for them.
333 = thing_inside (extendSubst env bndr (ContEx emptySubstEnv new_rhs))
336 = simplBinder env bndr `thenSmpl` \ (env, bndr') ->
337 completeNonRecX env False {- Non-strict; pessimistic -}
338 bndr bndr' new_rhs thing_inside
340 completeNonRecX env is_strict old_bndr new_bndr new_rhs thing_inside
341 | needsCaseBinding (idType new_bndr) new_rhs
342 = thing_inside env `thenSmpl` \ (floats, body) ->
343 returnSmpl (emptyFloats env, Case new_rhs new_bndr [(DEFAULT, [], wrapFloats floats body)])
346 = mkAtomicArgs is_strict
347 True {- OK to float unlifted -}
348 new_rhs `thenSmpl` \ (aux_binds, rhs2) ->
350 -- Make the arguments atomic if necessary,
351 -- adding suitable bindings
352 addAtomicBindsE env aux_binds $ \ env ->
353 completeLazyBind env NotTopLevel
354 old_bndr new_bndr rhs2 `thenSmpl` \ (floats, env) ->
355 addFloats env floats thing_inside
359 %************************************************************************
361 \subsection{Lazy bindings}
363 %************************************************************************
365 simplRecBind is used for
366 * recursive bindings only
369 simplRecBind :: SimplEnv -> TopLevelFlag
370 -> [(InId, InExpr)] -> [OutId]
371 -> SimplM (FloatsWith SimplEnv)
372 simplRecBind env top_lvl pairs bndrs'
373 = go env pairs bndrs' `thenSmpl` \ (floats, env) ->
374 returnSmpl (flattenFloats floats, env)
376 go env [] _ = returnSmpl (emptyFloats env, env)
378 go env ((bndr, rhs) : pairs) (bndr' : bndrs')
379 = simplRecOrTopPair env top_lvl bndr bndr' rhs `thenSmpl` \ (floats, env) ->
380 addFloats env floats (\env -> go env pairs bndrs')
384 simplRecOrTopPair is used for
385 * recursive bindings (whether top level or not)
386 * top-level non-recursive bindings
388 It assumes the binder has already been simplified, but not its IdInfo.
391 simplRecOrTopPair :: SimplEnv
393 -> InId -> OutId -- Binder, both pre-and post simpl
394 -> InExpr -- The RHS and its environment
395 -> SimplM (FloatsWith SimplEnv)
397 simplRecOrTopPair env top_lvl bndr bndr' rhs
398 | preInlineUnconditionally env top_lvl bndr -- Check for unconditional inline
399 = tick (PreInlineUnconditionally bndr) `thenSmpl_`
400 returnSmpl (emptyFloats env, extendSubst env bndr (ContEx (getSubstEnv env) rhs))
403 = simplLazyBind env top_lvl Recursive bndr bndr' rhs env
404 -- May not actually be recursive, but it doesn't matter
408 simplLazyBind is used for
409 * recursive bindings (whether top level or not)
410 * top-level non-recursive bindings
411 * non-top-level *lazy* non-recursive bindings
413 [Thus it deals with the lazy cases from simplNonRecBind, and all cases
414 from SimplRecOrTopBind]
417 1. It assumes that the binder is *already* simplified,
418 and is in scope, but not its IdInfo
420 2. It assumes that the binder type is lifted.
422 3. It does not check for pre-inline-unconditionallly;
423 that should have been done already.
426 simplLazyBind :: SimplEnv
427 -> TopLevelFlag -> RecFlag
428 -> InId -> OutId -- Binder, both pre-and post simpl
429 -> InExpr -> SimplEnv -- The RHS and its environment
430 -> SimplM (FloatsWith SimplEnv)
432 simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se
433 = -- Substitute IdInfo on binder, in the light of earlier
434 -- substitutions in this very letrec, and extend the
435 -- in-scope env, so that the IdInfo for this binder extends
436 -- over the RHS for the binder itself.
438 -- This is important. Manuel found cases where he really, really
439 -- wanted a RULE for a recursive function to apply in that function's
440 -- own right-hand side.
442 -- NB: does no harm for non-recursive bindings
444 is_top_level = isTopLevel top_lvl
445 bndr_ty' = idType bndr'
446 bndr'' = simplIdInfo (getSubst rhs_se) (idInfo bndr) bndr'
447 env1 = modifyInScope env bndr'' bndr''
448 rhs_env = setInScope rhs_se env1
449 ok_float_unlifted = not is_top_level && isNonRec is_rec
450 rhs_cont = mkStop bndr_ty' AnRhs
452 -- Simplify the RHS; note the mkStop, which tells
453 -- the simplifier that this is the RHS of a let.
454 simplExprF rhs_env rhs rhs_cont `thenSmpl` \ (floats, rhs1) ->
456 -- If any of the floats can't be floated, give up now
457 -- (The allLifted predicate says True for empty floats.)
458 if (not ok_float_unlifted && not (allLifted floats)) then
459 completeLazyBind env1 top_lvl bndr bndr''
460 (wrapFloats floats rhs1)
463 -- ANF-ise a constructor or PAP rhs
464 mkAtomicArgs False {- Not strict -}
465 ok_float_unlifted rhs1 `thenSmpl` \ (aux_binds, rhs2) ->
467 -- If the result is a PAP, float the floats out, else wrap them
468 -- By this time it's already been ANF-ised (if necessary)
469 if isEmptyFloats floats && null aux_binds then -- Shortcut a common case
470 completeLazyBind env1 top_lvl bndr bndr'' rhs2
472 -- We use exprIsTrivial here because we want to reveal lone variables.
473 -- E.g. let { x = letrec { y = E } in y } in ...
474 -- Here we definitely want to float the y=E defn.
475 -- exprIsValue definitely isn't right for that.
477 -- BUT we can't use "exprIsCheap", because that causes a strictness bug.
478 -- x = let y* = E in case (scc y) of { T -> F; F -> T}
479 -- The case expression is 'cheap', but it's wrong to transform to
480 -- y* = E; x = case (scc y) of {...}
481 -- Either we must be careful not to float demanded non-values, or
482 -- we must use exprIsValue for the test, which ensures that the
483 -- thing is non-strict. I think. The WARN below tests for this.
484 else if is_top_level || exprIsTrivial rhs2 || exprIsValue rhs2 then
486 -- There's a subtlety here. There may be a binding (x* = e) in the
487 -- floats, where the '*' means 'will be demanded'. So is it safe
488 -- to float it out? Answer no, but it won't matter because
489 -- we only float if arg' is a WHNF,
490 -- and so there can't be any 'will be demanded' bindings in the floats.
492 WARN( any demanded_float (floatBinds floats),
493 ppr (filter demanded_float (floatBinds floats)) )
495 tick LetFloatFromLet `thenSmpl_` (
496 addFloats env1 floats $ \ env2 ->
497 addAtomicBinds env2 aux_binds $ \ env3 ->
498 completeLazyBind env3 top_lvl bndr bndr'' rhs2)
501 completeLazyBind env1 top_lvl bndr bndr'' (wrapFloats floats rhs1)
504 demanded_float (NonRec b r) = isStrictDmd (idNewDemandInfo b) && not (isUnLiftedType (idType b))
505 -- Unlifted-type (cheap-eagerness) lets may well have a demanded flag on them
506 demanded_float (Rec _) = False
511 %************************************************************************
513 \subsection{Completing a lazy binding}
515 %************************************************************************
518 * deals only with Ids, not TyVars
519 * takes an already-simplified binder and RHS
520 * is used for both recursive and non-recursive bindings
521 * is used for both top-level and non-top-level bindings
523 It does the following:
524 - tries discarding a dead binding
525 - tries PostInlineUnconditionally
526 - add unfolding [this is the only place we add an unfolding]
529 It does *not* attempt to do let-to-case. Why? Because it is used for
530 - top-level bindings (when let-to-case is impossible)
531 - many situations where the "rhs" is known to be a WHNF
532 (so let-to-case is inappropriate).
535 completeLazyBind :: SimplEnv
536 -> TopLevelFlag -- Flag stuck into unfolding
537 -> InId -- Old binder
538 -> OutId -- New binder
539 -> OutExpr -- Simplified RHS
540 -> SimplM (FloatsWith SimplEnv)
541 -- We return a new SimplEnv, because completeLazyBind may choose to do its work
542 -- by extending the substitution (e.g. let x = y in ...)
543 -- The new binding (if any) is returned as part of the floats.
544 -- NB: the returned SimplEnv has the right SubstEnv, but you should
545 -- (as usual) use the in-scope-env from the floats
547 completeLazyBind env top_lvl old_bndr new_bndr new_rhs
548 | postInlineUnconditionally env new_bndr loop_breaker new_rhs
549 = -- Drop the binding
550 tick (PostInlineUnconditionally old_bndr) `thenSmpl_`
551 returnSmpl (emptyFloats env, extendSubst env old_bndr (DoneEx new_rhs))
552 -- Use the substitution to make quite, quite sure that the substitution
553 -- will happen, since we are going to discard the binding
558 new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs
560 -- Add the unfolding *only* for non-loop-breakers
561 -- Making loop breakers not have an unfolding at all
562 -- means that we can avoid tests in exprIsConApp, for example.
563 -- This is important: if exprIsConApp says 'yes' for a recursive
564 -- thing, then we can get into an infinite loop
565 info_w_unf | loop_breaker = new_bndr_info
566 | otherwise = new_bndr_info `setUnfoldingInfo` unfolding
567 unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs
569 final_id = new_bndr `setIdInfo` info_w_unf
571 -- These seqs forces the Id, and hence its IdInfo,
572 -- and hence any inner substitutions
574 returnSmpl (unitFloat env final_id new_rhs, env)
577 loop_breaker = isLoopBreaker occ_info
578 old_info = idInfo old_bndr
579 occ_info = occInfo old_info
584 %************************************************************************
586 \subsection[Simplify-simplExpr]{The main function: simplExpr}
588 %************************************************************************
590 The reason for this OutExprStuff stuff is that we want to float *after*
591 simplifying a RHS, not before. If we do so naively we get quadratic
592 behaviour as things float out.
594 To see why it's important to do it after, consider this (real) example:
608 a -- Can't inline a this round, cos it appears twice
612 Each of the ==> steps is a round of simplification. We'd save a
613 whole round if we float first. This can cascade. Consider
618 let f = let d1 = ..d.. in \y -> e
622 in \x -> ...(\y ->e)...
624 Only in this second round can the \y be applied, and it
625 might do the same again.
629 simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
630 simplExpr env expr = simplExprC env expr (mkBoringStop expr_ty')
632 expr_ty' = substTy (getSubst env) (exprType expr)
633 -- The type in the Stop continuation, expr_ty', is usually not used
634 -- It's only needed when discarding continuations after finding
635 -- a function that returns bottom.
636 -- Hence the lazy substitution
639 simplExprC :: SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr
640 -- Simplify an expression, given a continuation
641 simplExprC env expr cont
642 = simplExprF env expr cont `thenSmpl` \ (floats, expr) ->
643 returnSmpl (wrapFloats floats expr)
645 simplExprF :: SimplEnv -> InExpr -> SimplCont -> SimplM FloatsWithExpr
646 -- Simplify an expression, returning floated binds
648 simplExprF env (Var v) cont = simplVar env v cont
649 simplExprF env (Lit lit) cont = rebuild env (Lit lit) cont
650 simplExprF env expr@(Lam _ _) cont = simplLam env expr cont
651 simplExprF env (Note note expr) cont = simplNote env note expr cont
652 simplExprF env (App fun arg) cont = simplExprF env fun (ApplyTo NoDup arg env cont)
654 simplExprF env (Type ty) cont
655 = ASSERT( contIsRhsOrArg cont )
656 simplType env ty `thenSmpl` \ ty' ->
657 rebuild env (Type ty') cont
659 simplExprF env (Case scrut bndr alts) cont
660 | not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
661 = -- Simplify the scrutinee with a Select continuation
662 simplExprF env scrut (Select NoDup bndr alts env cont)
665 = -- If case-of-case is off, simply simplify the case expression
666 -- in a vanilla Stop context, and rebuild the result around it
667 simplExprC env scrut case_cont `thenSmpl` \ case_expr' ->
668 rebuild env case_expr' cont
670 case_cont = Select NoDup bndr alts env (mkBoringStop (contResultType cont))
672 simplExprF env (Let (Rec pairs) body) cont
673 = simplRecBndrs env (map fst pairs) `thenSmpl` \ (env, bndrs') ->
674 -- NB: bndrs' don't have unfoldings or spec-envs
675 -- We add them as we go down, using simplPrags
677 simplRecBind env NotTopLevel pairs bndrs' `thenSmpl` \ (floats, env) ->
678 addFloats env floats $ \ env ->
679 simplExprF env body cont
681 -- A non-recursive let is dealt with by simplNonRecBind
682 simplExprF env (Let (NonRec bndr rhs) body) cont
683 = simplNonRecBind env bndr rhs env (contResultType cont) $ \ env ->
684 simplExprF env body cont
687 ---------------------------------
688 simplType :: SimplEnv -> InType -> SimplM OutType
689 -- Kept monadic just so we can do the seqType
691 = seqType new_ty `seq` returnSmpl new_ty
693 new_ty = substTy (getSubst env) ty
697 %************************************************************************
701 %************************************************************************
704 simplLam env fun cont
707 zap_it = mkLamBndrZapper fun (countArgs cont)
708 cont_ty = contResultType cont
710 -- Type-beta reduction
711 go env (Lam bndr body) (ApplyTo _ (Type ty_arg) arg_se body_cont)
712 = ASSERT( isTyVar bndr )
713 tick (BetaReduction bndr) `thenSmpl_`
714 simplType (setInScope arg_se env) ty_arg `thenSmpl` \ ty_arg' ->
715 go (extendSubst env bndr (DoneTy ty_arg')) body body_cont
717 -- Ordinary beta reduction
718 go env (Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont)
719 = tick (BetaReduction bndr) `thenSmpl_`
720 simplNonRecBind env (zap_it bndr) arg arg_se cont_ty $ \ env ->
721 go env body body_cont
723 -- Not enough args, so there are real lambdas left to put in the result
724 go env lam@(Lam _ _) cont
725 = simplLamBndrs env bndrs `thenSmpl` \ (env, bndrs') ->
726 simplExpr env body `thenSmpl` \ body' ->
727 mkLam env bndrs' body' cont `thenSmpl` \ (floats, new_lam) ->
728 addFloats env floats $ \ env ->
729 rebuild env new_lam cont
731 (bndrs,body) = collectBinders lam
733 -- Exactly enough args
734 go env expr cont = simplExprF env expr cont
736 mkLamBndrZapper :: CoreExpr -- Function
737 -> Int -- Number of args supplied, *including* type args
738 -> Id -> Id -- Use this to zap the binders
739 mkLamBndrZapper fun n_args
740 | n_args >= n_params fun = \b -> b -- Enough args
741 | otherwise = \b -> zapLamIdInfo b
743 -- NB: we count all the args incl type args
744 -- so we must count all the binders (incl type lambdas)
745 n_params (Note _ e) = n_params e
746 n_params (Lam b e) = 1 + n_params e
747 n_params other = 0::Int
751 %************************************************************************
755 %************************************************************************
758 simplNote env (Coerce to from) body cont
760 in_scope = getInScope env
762 addCoerce s1 k1 (CoerceIt t1 cont)
763 -- coerce T1 S1 (coerce S1 K1 e)
766 -- coerce T1 K1 e, otherwise
768 -- For example, in the initial form of a worker
769 -- we may find (coerce T (coerce S (\x.e))) y
770 -- and we'd like it to simplify to e[y/x] in one round
772 | t1 `eqType` k1 = cont -- The coerces cancel out
773 | otherwise = CoerceIt t1 cont -- They don't cancel, but
774 -- the inner one is redundant
776 addCoerce t1t2 s1s2 (ApplyTo dup arg arg_se cont)
777 | Just (s1, s2) <- splitFunTy_maybe s1s2
778 -- (coerce (T1->T2) (S1->S2) F) E
780 -- coerce T2 S2 (F (coerce S1 T1 E))
782 -- t1t2 must be a function type, T1->T2
783 -- but s1s2 might conceivably not be
785 -- When we build the ApplyTo we can't mix the out-types
786 -- with the InExpr in the argument, so we simply substitute
787 -- to make it all consistent. It's a bit messy.
788 -- But it isn't a common case.
790 (t1,t2) = splitFunTy t1t2
791 new_arg = mkCoerce s1 t1 (substExpr (mkSubst in_scope (getSubstEnv arg_se)) arg)
793 ApplyTo dup new_arg (zapSubstEnv env) (addCoerce t2 s2 cont)
795 addCoerce to' _ cont = CoerceIt to' cont
797 simplType env to `thenSmpl` \ to' ->
798 simplType env from `thenSmpl` \ from' ->
799 simplExprF env body (addCoerce to' from' cont)
802 -- Hack: we only distinguish subsumed cost centre stacks for the purposes of
803 -- inlining. All other CCCSs are mapped to currentCCS.
804 simplNote env (SCC cc) e cont
805 = simplExpr (setEnclosingCC env currentCCS) e `thenSmpl` \ e' ->
806 rebuild env (mkSCC cc e') cont
808 simplNote env InlineCall e cont
809 = simplExprF env e (InlinePlease cont)
811 -- See notes with SimplMonad.inlineMode
812 simplNote env InlineMe e cont
813 | contIsRhsOrArg cont -- Totally boring continuation; see notes above
814 = -- Don't inline inside an INLINE expression
815 simplExpr (setMode inlineMode env ) e `thenSmpl` \ e' ->
816 rebuild env (mkInlineMe e') cont
818 | otherwise -- Dissolve the InlineMe note if there's
819 -- an interesting context of any kind to combine with
820 -- (even a type application -- anything except Stop)
821 = simplExprF env e cont
825 %************************************************************************
827 \subsection{Dealing with calls}
829 %************************************************************************
832 simplVar env var cont
833 = case lookupIdSubst (getSubst env) var of
834 DoneEx e -> simplExprF (zapSubstEnv env) e cont
835 ContEx se e -> simplExprF (setSubstEnv env se) e cont
836 DoneId var1 occ -> WARN( not (isInScope var1 (getSubst env)) && mustHaveLocalBinding var1,
837 text "simplVar:" <+> ppr var )
838 completeCall (zapSubstEnv env) var1 occ cont
839 -- The template is already simplified, so don't re-substitute.
840 -- This is VITAL. Consider
842 -- let y = \z -> ...x... in
844 -- We'll clone the inner \x, adding x->x' in the id_subst
845 -- Then when we inline y, we must *not* replace x by x' in
846 -- the inlined copy!!
848 ---------------------------------------------------------
849 -- Dealing with a call site
851 completeCall env var occ_info cont
852 = -- Simplify the arguments
853 getDOptsSmpl `thenSmpl` \ dflags ->
855 chkr = getSwitchChecker env
856 (args, call_cont, inline_call) = getContArgs chkr var cont
858 simplifyArgs env args (contResultType call_cont) $ \ env args ->
860 -- Next, look for rules or specialisations that match
862 -- It's important to simplify the args first, because the rule-matcher
863 -- doesn't do substitution as it goes. We don't want to use subst_args
864 -- (defined in the 'where') because that throws away useful occurrence info,
865 -- and perhaps-very-important specialisations.
867 -- Some functions have specialisations *and* are strict; in this case,
868 -- we don't want to inline the wrapper of the non-specialised thing; better
869 -- to call the specialised thing instead.
870 -- We used to use the black-listing mechanism to ensure that inlining of
871 -- the wrapper didn't occur for things that have specialisations till a
872 -- later phase, so but now we just try RULES first
874 -- You might think that we shouldn't apply rules for a loop breaker:
875 -- doing so might give rise to an infinite loop, because a RULE is
876 -- rather like an extra equation for the function:
877 -- RULE: f (g x) y = x+y
880 -- But it's too drastic to disable rules for loop breakers.
881 -- Even the foldr/build rule would be disabled, because foldr
882 -- is recursive, and hence a loop breaker:
883 -- foldr k z (build g) = g k z
884 -- So it's up to the programmer: rules can cause divergence
887 in_scope = getInScope env
888 maybe_rule = case activeRule env of
889 Nothing -> Nothing -- No rules apply
890 Just act_fn -> lookupRule act_fn in_scope var args
893 Just (rule_name, rule_rhs) ->
894 tick (RuleFired rule_name) `thenSmpl_`
895 (if dopt Opt_D_dump_inlinings dflags then
896 pprTrace "Rule fired" (vcat [
897 text "Rule:" <+> ptext rule_name,
898 text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
899 text "After: " <+> pprCoreExpr rule_rhs])
902 simplExprF env rule_rhs call_cont ;
904 Nothing -> -- No rules
906 -- Next, look for an inlining
908 arg_infos = [ interestingArg arg | arg <- args, isValArg arg]
910 interesting_cont = interestingCallContext (not (null args))
911 (not (null arg_infos))
914 active_inline = activeInline env var
915 maybe_inline = callSiteInline dflags active_inline inline_call occ_info
916 var arg_infos interesting_cont
918 case maybe_inline of {
919 Just unfolding -- There is an inlining!
920 -> tick (UnfoldingDone var) `thenSmpl_`
921 makeThatCall env var unfolding args call_cont
924 Nothing -> -- No inlining!
927 rebuild env (mkApps (Var var) args) call_cont
930 makeThatCall :: SimplEnv
932 -> InExpr -- Inlined function rhs
933 -> [OutExpr] -- Arguments, already simplified
934 -> SimplCont -- After the call
935 -> SimplM FloatsWithExpr
936 -- Similar to simplLam, but this time
937 -- the arguments are already simplified
938 makeThatCall orig_env var fun@(Lam _ _) args cont
939 = go orig_env fun args
941 zap_it = mkLamBndrZapper fun (length args)
943 -- Type-beta reduction
944 go env (Lam bndr body) (Type ty_arg : args)
945 = ASSERT( isTyVar bndr )
946 tick (BetaReduction bndr) `thenSmpl_`
947 go (extendSubst env bndr (DoneTy ty_arg)) body args
949 -- Ordinary beta reduction
950 go env (Lam bndr body) (arg : args)
951 = tick (BetaReduction bndr) `thenSmpl_`
952 simplNonRecX env (zap_it bndr) arg $ \ env ->
955 -- Not enough args, so there are real lambdas left to put in the result
957 = simplExprF env fun (pushContArgs orig_env args cont)
958 -- NB: orig_env; the correct environment to capture with
959 -- the arguments.... env has been augmented with substitutions
960 -- from the beta reductions.
962 makeThatCall env var fun args cont
963 = simplExprF env fun (pushContArgs env args cont)
967 %************************************************************************
969 \subsection{Arguments}
971 %************************************************************************
974 ---------------------------------------------------------
975 -- Simplifying the arguments of a call
977 simplifyArgs :: SimplEnv
978 -> [(InExpr, SimplEnv, Bool)] -- Details of the arguments
979 -> OutType -- Type of the continuation
980 -> (SimplEnv -> [OutExpr] -> SimplM FloatsWithExpr)
981 -> SimplM FloatsWithExpr
983 -- [CPS-like because of strict arguments]
985 -- Simplify the arguments to a call.
986 -- This part of the simplifier may break the no-shadowing invariant
988 -- f (...(\a -> e)...) (case y of (a,b) -> e')
989 -- where f is strict in its second arg
990 -- If we simplify the innermost one first we get (...(\a -> e)...)
991 -- Simplifying the second arg makes us float the case out, so we end up with
992 -- case y of (a,b) -> f (...(\a -> e)...) e'
993 -- So the output does not have the no-shadowing invariant. However, there is
994 -- no danger of getting name-capture, because when the first arg was simplified
995 -- we used an in-scope set that at least mentioned all the variables free in its
996 -- static environment, and that is enough.
998 -- We can't just do innermost first, or we'd end up with a dual problem:
999 -- case x of (a,b) -> f e (...(\a -> e')...)
1001 -- I spent hours trying to recover the no-shadowing invariant, but I just could
1002 -- not think of an elegant way to do it. The simplifier is already knee-deep in
1003 -- continuations. We have to keep the right in-scope set around; AND we have
1004 -- to get the effect that finding (error "foo") in a strict arg position will
1005 -- discard the entire application and replace it with (error "foo"). Getting
1006 -- all this at once is TOO HARD!
1008 simplifyArgs env args cont_ty thing_inside
1009 = go env args thing_inside
1011 go env [] thing_inside = thing_inside env []
1012 go env (arg:args) thing_inside = simplifyArg env arg cont_ty $ \ env arg' ->
1013 go env args $ \ env args' ->
1014 thing_inside env (arg':args')
1016 simplifyArg env (Type ty_arg, se, _) cont_ty thing_inside
1017 = simplType (setInScope se env) ty_arg `thenSmpl` \ new_ty_arg ->
1018 thing_inside env (Type new_ty_arg)
1020 simplifyArg env (val_arg, arg_se, is_strict) cont_ty thing_inside
1022 = simplStrictArg env AnArg val_arg arg_se cont_ty thing_inside
1026 arg_env = setInScope arg_se env
1028 simplType arg_env (exprType val_arg) `thenSmpl` \ arg_ty ->
1029 simplExprF arg_env val_arg (mkStop arg_ty AnArg) `thenSmpl` \ (floats, arg1) ->
1030 addFloats env floats $ \ env ->
1031 thing_inside env arg1
1034 simplStrictArg :: SimplEnv -- The env of the call
1036 -> InExpr -> SimplEnv -- The arg plus its env
1037 -> OutType -- cont_ty: Type of thing computed by the context
1038 -> (SimplEnv -> OutExpr -> SimplM FloatsWithExpr)
1039 -- Takes an expression of type rhs_ty,
1040 -- returns an expression of type cont_ty
1041 -- The env passed to this continuation is the
1042 -- env of the call, plus any new in-scope variables
1043 -> SimplM FloatsWithExpr -- An expression of type cont_ty
1045 simplStrictArg call_env is_rhs arg arg_env cont_ty thing_inside
1046 = simplExprF (setInScope arg_env call_env) arg
1047 (ArgOf NoDup is_rhs cont_ty (\ new_env -> thing_inside (setInScope call_env new_env)))
1048 -- Notice the way we use arg_env (augmented with in-scope vars from call_env)
1049 -- to simplify the argument
1050 -- and call-env (augmented with in-scope vars from the arg) to pass to the continuation
1054 %************************************************************************
1056 \subsection{mkAtomicArgs}
1058 %************************************************************************
1060 mkAtomicArgs takes a putative RHS, checks whether it's a PAP or
1061 constructor application and, if so, converts it to ANF, so that the
1062 resulting thing can be inlined more easily. Thus
1069 There are three sorts of binding context, specified by the two
1075 N N Top-level or recursive Only bind args of lifted type
1077 N Y Non-top-level and non-recursive, Bind args of lifted type, or
1078 but lazy unlifted-and-ok-for-speculation
1080 Y Y Non-top-level, non-recursive, Bind all args
1081 and strict (demanded)
1088 there is no point in transforming to
1090 x = case (y div# z) of r -> MkC r
1092 because the (y div# z) can't float out of the let. But if it was
1093 a *strict* let, then it would be a good thing to do. Hence the
1094 context information.
1097 mkAtomicArgs :: Bool -- A strict binding
1098 -> Bool -- OK to float unlifted args
1100 -> SimplM ([(OutId,OutExpr)], -- The floats (unusually) may include
1101 OutExpr) -- things that need case-binding,
1102 -- if the strict-binding flag is on
1104 mkAtomicArgs is_strict ok_float_unlifted rhs
1105 = mk_atomic_args rhs `thenSmpl` \ maybe_stuff ->
1107 Nothing -> returnSmpl ([], rhs)
1108 Just (ol_binds, rhs') -> returnSmpl (fromOL ol_binds, rhs')
1111 mk_atomic_args :: OutExpr -> SimplM (Maybe (OrdList (Id,OutExpr), OutExpr))
1112 -- Nothing => no change
1114 | (Var fun, args) <- collectArgs rhs, -- It's an application
1115 isDataConId fun || valArgCount args < idArity fun -- And it's a constructor or PAP
1117 go nilOL [] args `thenSmpl` \ maybe_stuff ->
1119 Nothing -> returnSmpl Nothing
1120 Just (aux_binds, args') -> returnSmpl (Just (aux_binds, mkApps (Var fun) args'))
1123 = returnSmpl Nothing
1125 go binds rev_args []
1126 = returnSmpl (Just (binds, reverse rev_args))
1127 go binds rev_args (arg : args)
1128 | exprIsTrivial arg -- Easy case
1129 = go binds (arg:rev_args) args
1131 | not can_float_arg -- Can't make this arg atomic
1132 = returnSmpl Nothing -- ... so give up
1134 | otherwise -- Don't forget to do it recursively
1135 -- E.g. x = a:b:c:[]
1136 = mk_atomic_args arg `thenSmpl` \ maybe_anf ->
1138 Nothing -> returnSmpl Nothing ;
1139 Just (arg_binds,arg') ->
1141 newId SLIT("a") arg_ty `thenSmpl` \ arg_id ->
1142 go ((arg_binds `snocOL` (arg_id,arg')) `appOL` binds)
1143 (Var arg_id : rev_args) args
1146 arg_ty = exprType arg
1147 can_float_arg = is_strict
1148 || not (isUnLiftedType arg_ty)
1149 || (ok_float_unlifted && exprOkForSpeculation arg)
1151 addAtomicBinds :: SimplEnv -> [(OutId,OutExpr)]
1152 -> (SimplEnv -> SimplM (FloatsWith a))
1153 -> SimplM (FloatsWith a)
1154 addAtomicBinds env [] thing_inside = thing_inside env
1155 addAtomicBinds env ((v,r):bs) thing_inside = addAuxiliaryBind env (NonRec v r) $ \ env ->
1156 addAtomicBinds env bs thing_inside
1158 addAtomicBindsE :: SimplEnv -> [(OutId,OutExpr)]
1159 -> (SimplEnv -> SimplM FloatsWithExpr)
1160 -> SimplM FloatsWithExpr
1161 -- Same again, but this time we're in an expression context,
1162 -- and may need to do some case bindings
1164 addAtomicBindsE env [] thing_inside
1166 addAtomicBindsE env ((v,r):bs) thing_inside
1167 | needsCaseBinding (idType v) r
1168 = addAtomicBindsE (addNewInScopeIds env [v]) bs thing_inside `thenSmpl` \ (floats, expr) ->
1169 WARN( exprIsTrivial expr, ppr v <+> pprCoreExpr expr )
1170 returnSmpl (emptyFloats env, Case r v [(DEFAULT,[], wrapFloats floats expr)])
1173 = addAuxiliaryBind env (NonRec v r) $ \ env ->
1174 addAtomicBindsE env bs thing_inside
1178 %************************************************************************
1180 \subsection{The main rebuilder}
1182 %************************************************************************
1185 rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM FloatsWithExpr
1187 rebuild env expr (Stop _ _ _) = rebuildDone env expr
1188 rebuild env expr (ArgOf _ _ _ cont_fn) = cont_fn env expr
1189 rebuild env expr (CoerceIt to_ty cont) = rebuild env (mkCoerce to_ty (exprType expr) expr) cont
1190 rebuild env expr (InlinePlease cont) = rebuild env (Note InlineCall expr) cont
1191 rebuild env expr (Select _ bndr alts se cont) = rebuildCase (setInScope se env) expr bndr alts cont
1192 rebuild env expr (ApplyTo _ arg se cont) = rebuildApp (setInScope se env) expr arg cont
1194 rebuildApp env fun arg cont
1195 = simplExpr env arg `thenSmpl` \ arg' ->
1196 rebuild env (App fun arg') cont
1198 rebuildDone env expr = returnSmpl (emptyFloats env, expr)
1202 %************************************************************************
1204 \subsection{Functions dealing with a case}
1206 %************************************************************************
1208 Blob of helper functions for the "case-of-something-else" situation.
1211 ---------------------------------------------------------
1212 -- Eliminate the case if possible
1214 rebuildCase :: SimplEnv
1215 -> OutExpr -- Scrutinee
1216 -> InId -- Case binder
1217 -> [InAlt] -- Alternatives
1219 -> SimplM FloatsWithExpr
1221 rebuildCase env scrut case_bndr alts cont
1222 | Just (con,args) <- exprIsConApp_maybe scrut
1223 -- Works when the scrutinee is a variable with a known unfolding
1224 -- as well as when it's an explicit constructor application
1225 = knownCon env (DataAlt con) args case_bndr alts cont
1227 | Lit lit <- scrut -- No need for same treatment as constructors
1228 -- because literals are inlined more vigorously
1229 = knownCon env (LitAlt lit) [] case_bndr alts cont
1232 = -- Prepare case alternatives
1233 -- Filter out alternatives that can't possibly match
1235 impossible_cons = case scrut of
1236 Var v -> otherCons (idUnfolding v)
1238 better_alts = case impossible_cons of
1240 other -> [alt | alt@(con,_,_) <- alts,
1241 not (con `elem` impossible_cons)]
1243 -- "handled_cons" are handled either by the context,
1244 -- or by a branch in this case expression
1245 -- Don't add DEFAULT to the handled_cons!!
1246 (alts_wo_default, _) = findDefault better_alts
1247 handled_cons = impossible_cons ++ [con | (con,_,_) <- alts_wo_default]
1250 -- Deal with the case binder, and prepare the continuation;
1251 -- The new subst_env is in place
1252 prepareCaseCont env better_alts cont `thenSmpl` \ (floats, cont') ->
1253 addFloats env floats $ \ env ->
1255 -- Deal with variable scrutinee
1256 simplCaseBinder env scrut case_bndr `thenSmpl` \ (alt_env, case_bndr', zap_occ_info) ->
1258 -- Deal with the case alternatives
1259 simplAlts alt_env zap_occ_info handled_cons
1260 case_bndr' better_alts cont' `thenSmpl` \ alts' ->
1262 -- Put the case back together
1263 mkCase scrut handled_cons case_bndr' alts' `thenSmpl` \ case_expr ->
1265 -- Notice that rebuildDone returns the in-scope set from env, not alt_env
1266 -- The case binder *not* scope over the whole returned case-expression
1267 rebuildDone env case_expr
1270 simplCaseBinder checks whether the scrutinee is a variable, v. If so,
1271 try to eliminate uses of v in the RHSs in favour of case_bndr; that
1272 way, there's a chance that v will now only be used once, and hence
1277 There is a time we *don't* want to do that, namely when
1278 -fno-case-of-case is on. This happens in the first simplifier pass,
1279 and enhances full laziness. Here's the bad case:
1280 f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )
1281 If we eliminate the inner case, we trap it inside the I# v -> arm,
1282 which might prevent some full laziness happening. I've seen this
1283 in action in spectral/cichelli/Prog.hs:
1284 [(m,n) | m <- [1..max], n <- [1..max]]
1285 Hence the check for NoCaseOfCase.
1289 There is another situation when we don't want to do it. If we have
1291 case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }
1292 ...other cases .... }
1294 We'll perform the binder-swap for the outer case, giving
1296 case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }
1297 ...other cases .... }
1299 But there is no point in doing it for the inner case,
1300 because w1 can't be inlined anyway. Furthermore, doing the case-swapping
1301 involves zapping w2's occurrence info (see paragraphs that follow),
1302 and that forces us to bind w2 when doing case merging. So we get
1304 case x of w1 { A -> let w2 = w1 in e1
1305 B -> let w2 = w1 in e2
1306 ...other cases .... }
1308 This is plain silly in the common case where w2 is dead.
1310 Even so, I can't see a good way to implement this idea. I tried
1311 not doing the binder-swap if the scrutinee was already evaluated
1312 but that failed big-time:
1316 case v of w { MkT x ->
1317 case x of x1 { I# y1 ->
1318 case x of x2 { I# y2 -> ...
1320 Notice that because MkT is strict, x is marked "evaluated". But to
1321 eliminate the last case, we must either make sure that x (as well as
1322 x1) has unfolding MkT y1. THe straightforward thing to do is to do
1323 the binder-swap. So this whole note is a no-op.
1327 If we replace the scrutinee, v, by tbe case binder, then we have to nuke
1328 any occurrence info (eg IAmDead) in the case binder, because the
1329 case-binder now effectively occurs whenever v does. AND we have to do
1330 the same for the pattern-bound variables! Example:
1332 (case x of { (a,b) -> a }) (case x of { (p,q) -> q })
1334 Here, b and p are dead. But when we move the argment inside the first
1335 case RHS, and eliminate the second case, we get
1337 case x or { (a,b) -> a b }
1339 Urk! b is alive! Reason: the scrutinee was a variable, and case elimination
1340 happened. Hence the zap_occ_info function returned by simplCaseBinder
1343 simplCaseBinder env (Var v) case_bndr
1344 | not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
1346 -- Failed try [see Note 2 above]
1347 -- not (isEvaldUnfolding (idUnfolding v))
1349 = simplBinder env (zap case_bndr) `thenSmpl` \ (env, case_bndr') ->
1350 returnSmpl (modifyInScope env v case_bndr', case_bndr', zap)
1351 -- We could extend the substitution instead, but it would be
1352 -- a hack because then the substitution wouldn't be idempotent
1353 -- any more (v is an OutId). And this just just as well.
1355 zap b = b `setIdOccInfo` NoOccInfo
1357 simplCaseBinder env other_scrut case_bndr
1358 = simplBinder env case_bndr `thenSmpl` \ (env, case_bndr') ->
1359 returnSmpl (env, case_bndr', \ bndr -> bndr) -- NoOp on bndr
1365 simplAlts :: SimplEnv
1366 -> (InId -> InId) -- Occ-info zapper
1367 -> [AltCon] -- Alternatives the scrutinee can't be
1368 -- in the default case
1369 -> OutId -- Case binder
1370 -> [InAlt] -> SimplCont
1371 -> SimplM [OutAlt] -- Includes the continuation
1373 simplAlts env zap_occ_info handled_cons case_bndr' alts cont'
1374 = mapSmpl simpl_alt alts
1376 inst_tys' = tyConAppArgs (idType case_bndr')
1378 simpl_alt (DEFAULT, _, rhs)
1380 -- In the default case we record the constructors that the
1381 -- case-binder *can't* be.
1382 -- We take advantage of any OtherCon info in the case scrutinee
1383 case_bndr_w_unf = case_bndr' `setIdUnfolding` mkOtherCon handled_cons
1384 env_with_unf = modifyInScope env case_bndr' case_bndr_w_unf
1386 simplExprC env_with_unf rhs cont' `thenSmpl` \ rhs' ->
1387 returnSmpl (DEFAULT, [], rhs')
1389 simpl_alt (con, vs, rhs)
1390 = -- Deal with the pattern-bound variables
1391 -- Mark the ones that are in ! positions in the data constructor
1392 -- as certainly-evaluated.
1393 -- NB: it happens that simplBinders does *not* erase the OtherCon
1394 -- form of unfolding, so it's ok to add this info before
1395 -- doing simplBinders
1396 simplBinders env (add_evals con vs) `thenSmpl` \ (env, vs') ->
1398 -- Bind the case-binder to (con args)
1400 unfolding = mkUnfolding False (mkAltExpr con vs' inst_tys')
1401 env_with_unf = modifyInScope env case_bndr' (case_bndr' `setIdUnfolding` unfolding)
1403 simplExprC env_with_unf rhs cont' `thenSmpl` \ rhs' ->
1404 returnSmpl (con, vs', rhs')
1407 -- add_evals records the evaluated-ness of the bound variables of
1408 -- a case pattern. This is *important*. Consider
1409 -- data T = T !Int !Int
1411 -- case x of { T a b -> T (a+1) b }
1413 -- We really must record that b is already evaluated so that we don't
1414 -- go and re-evaluate it when constructing the result.
1416 add_evals (DataAlt dc) vs = cat_evals vs (dataConRepStrictness dc)
1417 add_evals other_con vs = vs
1419 cat_evals [] [] = []
1420 cat_evals (v:vs) (str:strs)
1421 | isTyVar v = v : cat_evals vs (str:strs)
1422 | isMarkedStrict str = evald_v : cat_evals vs strs
1423 | otherwise = zapped_v : cat_evals vs strs
1425 zapped_v = zap_occ_info v
1426 evald_v = zapped_v `setIdUnfolding` mkOtherCon []
1430 %************************************************************************
1432 \subsection{Known constructor}
1434 %************************************************************************
1436 We are a bit careful with occurrence info. Here's an example
1438 (\x* -> case x of (a*, b) -> f a) (h v, e)
1440 where the * means "occurs once". This effectively becomes
1441 case (h v, e) of (a*, b) -> f a)
1443 let a* = h v; b = e in f a
1447 All this should happen in one sweep.
1450 knownCon :: SimplEnv -> AltCon -> [OutExpr]
1451 -> InId -> [InAlt] -> SimplCont
1452 -> SimplM FloatsWithExpr
1454 knownCon env con args bndr alts cont
1455 = tick (KnownBranch bndr) `thenSmpl_`
1456 case findAlt con alts of
1457 (DEFAULT, bs, rhs) -> ASSERT( null bs )
1458 simplNonRecX env bndr scrut $ \ env ->
1459 -- This might give rise to a binding with non-atomic args
1460 -- like x = Node (f x) (g x)
1461 -- but no harm will be done
1462 simplExprF env rhs cont
1465 LitAlt lit -> Lit lit
1466 DataAlt dc -> mkConApp dc args
1468 (LitAlt lit, bs, rhs) -> ASSERT( null bs )
1469 simplNonRecX env bndr (Lit lit) $ \ env ->
1470 simplExprF env rhs cont
1472 (DataAlt dc, bs, rhs) -> ASSERT( length bs + n_tys == length args )
1473 bind_args env bs (drop n_tys args) $ \ env ->
1475 con_app = mkConApp dc (take n_tys args ++ con_args)
1476 con_args = [substExpr (getSubst env) (varToCoreExpr b) | b <- bs]
1477 -- args are aready OutExprs, but bs are InIds
1479 simplNonRecX env bndr con_app $ \ env ->
1480 simplExprF env rhs cont
1482 n_tys = dataConNumInstArgs dc -- Non-existential type args
1484 bind_args env [] _ thing_inside = thing_inside env
1486 bind_args env (b:bs) (Type ty : args) thing_inside
1487 = bind_args (extendSubst env b (DoneTy ty)) bs args thing_inside
1489 bind_args env (b:bs) (arg : args) thing_inside
1490 = simplNonRecX env b arg $ \ env ->
1491 bind_args env bs args thing_inside
1495 %************************************************************************
1497 \subsection{Duplicating continuations}
1499 %************************************************************************
1502 prepareCaseCont :: SimplEnv
1503 -> [InAlt] -> SimplCont
1504 -> SimplM (FloatsWith SimplCont) -- Return a duplicatable continuation,
1505 -- plus some extra bindings
1507 prepareCaseCont env [alt] cont = returnSmpl (emptyFloats env, cont)
1508 -- No need to make it duplicatable if there's only one alternative
1510 prepareCaseCont env alts cont = simplType env (coreAltsType alts) `thenSmpl` \ alts_ty ->
1511 mkDupableCont env alts_ty cont
1512 -- At one time I passed in the un-simplified type, and simplified
1513 -- it only if we needed to construct a join binder, but that
1514 -- didn't work because we have to decompse function types
1515 -- (using funResultTy) in mkDupableCont.
1519 mkDupableCont :: SimplEnv
1520 -> OutType -- Type of the thing to be given to the continuation
1522 -> SimplM (FloatsWith SimplCont) -- Return a duplicatable continuation,
1523 -- plus some extra bindings
1525 mkDupableCont env ty cont
1526 | contIsDupable cont
1527 = returnSmpl (emptyFloats env, cont)
1529 mkDupableCont env _ (CoerceIt ty cont)
1530 = mkDupableCont env ty cont `thenSmpl` \ (floats, cont') ->
1531 returnSmpl (floats, CoerceIt ty cont')
1533 mkDupableCont env ty (InlinePlease cont)
1534 = mkDupableCont env ty cont `thenSmpl` \ (floats, cont') ->
1535 returnSmpl (floats, InlinePlease cont')
1537 mkDupableCont env join_arg_ty (ArgOf _ is_rhs cont_ty cont_fn)
1538 = -- e.g. (...strict-fn...) [...hole...]
1540 -- let $j = \a -> ...strict-fn...
1541 -- in $j [...hole...]
1543 -- Build the join Id and continuation
1544 -- We give it a "$j" name just so that for later amusement
1545 -- we can identify any join points that don't end up as let-no-escapes
1546 -- [NOTE: the type used to be exprType join_rhs, but this seems more elegant.]
1547 newId SLIT("$j") (mkFunTy join_arg_ty cont_ty) `thenSmpl` \ join_id ->
1548 newId SLIT("a") join_arg_ty `thenSmpl` \ arg_id ->
1550 cont_fn (addNewInScopeIds env [arg_id]) (Var arg_id) `thenSmpl` \ (floats, rhs) ->
1552 cont_fn env arg' = rebuildDone env (App (Var join_id) arg')
1553 join_rhs = Lam (setOneShotLambda arg_id) (wrapFloats floats rhs)
1556 tick (CaseOfCase join_id) `thenSmpl_`
1557 -- Want to tick here so that we go round again,
1558 -- and maybe copy or inline the code;
1559 -- not strictly CaseOf Case
1561 returnSmpl (unitFloat env join_id join_rhs,
1562 ArgOf OkToDup is_rhs cont_ty cont_fn)
1564 mkDupableCont env ty (ApplyTo _ arg se cont)
1565 = -- e.g. [...hole...] (...arg...)
1567 -- let a = ...arg...
1568 -- in [...hole...] a
1569 mkDupableCont env (funResultTy ty) cont `thenSmpl` \ (floats, cont') ->
1570 addFloats env floats $ \ env ->
1572 simplExpr (setInScope se env) arg `thenSmpl` \ arg' ->
1573 if exprIsDupable arg' then
1574 returnSmpl (emptyFloats env, ApplyTo OkToDup arg' (zapSubstEnv se) cont')
1576 newId SLIT("a") (exprType arg') `thenSmpl` \ arg_id ->
1578 tick (CaseOfCase arg_id) `thenSmpl_`
1579 -- Want to tick here so that we go round again,
1580 -- and maybe copy or inline the code.
1581 -- Not strictly CaseOfCase, but never mind
1583 returnSmpl (unitFloat env arg_id arg',
1584 ApplyTo OkToDup (Var arg_id) (zapSubstEnv se) cont')
1585 -- But what if the arg should be case-bound?
1586 -- This has been this way for a long time, so I'll leave it,
1587 -- but I can't convince myself that it's right.
1590 mkDupableCont env ty (Select _ case_bndr alts se cont)
1591 = -- e.g. (case [...hole...] of { pi -> ei })
1593 -- let ji = \xij -> ei
1594 -- in case [...hole...] of { pi -> ji xij }
1595 tick (CaseOfCase case_bndr) `thenSmpl_`
1597 alt_env = setInScope se env
1599 prepareCaseCont alt_env alts cont `thenSmpl` \ (floats1, dupable_cont) ->
1600 addFloats alt_env floats1 $ \ alt_env ->
1602 simplBinder alt_env case_bndr `thenSmpl` \ (alt_env, case_bndr') ->
1603 -- NB: simplBinder does not zap deadness occ-info, so
1604 -- a dead case_bndr' will still advertise its deadness
1605 -- This is really important because in
1606 -- case e of b { (# a,b #) -> ... }
1607 -- b is always dead, and indeed we are not allowed to bind b to (# a,b #),
1608 -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.
1609 -- In the new alts we build, we have the new case binder, so it must retain
1612 mkDupableAlts alt_env case_bndr' alts dupable_cont `thenSmpl` \ (floats2, alts') ->
1613 addFloats alt_env floats2 $ \ alt_env ->
1614 returnSmpl (emptyFloats alt_env, Select OkToDup case_bndr' alts' (zapSubstEnv se)
1615 (mkBoringStop (contResultType cont)))
1617 mkDupableAlts :: SimplEnv -> OutId -> [InAlt] -> SimplCont
1618 -> SimplM (FloatsWith [InAlt])
1619 -- Absorbs the continuation into the new alternatives
1621 mkDupableAlts env case_bndr' alts dupable_cont
1624 go env [] = returnSmpl (emptyFloats env, [])
1626 = mkDupableAlt env case_bndr' dupable_cont alt `thenSmpl` \ (floats1, alt') ->
1627 addFloats env floats1 $ \ env ->
1628 go env alts `thenSmpl` \ (floats2, alts') ->
1629 returnSmpl (floats2, alt' : alts')
1631 mkDupableAlt env case_bndr' cont alt@(con, bndrs, rhs)
1632 = simplBinders env bndrs `thenSmpl` \ (env, bndrs') ->
1633 simplExprC env rhs cont `thenSmpl` \ rhs' ->
1635 if exprIsDupable rhs' then
1636 returnSmpl (emptyFloats env, (con, bndrs', rhs'))
1637 -- It is worth checking for a small RHS because otherwise we
1638 -- get extra let bindings that may cause an extra iteration of the simplifier to
1639 -- inline back in place. Quite often the rhs is just a variable or constructor.
1640 -- The Ord instance of Maybe in PrelMaybe.lhs, for example, took several extra
1641 -- iterations because the version with the let bindings looked big, and so wasn't
1642 -- inlined, but after the join points had been inlined it looked smaller, and so
1645 -- NB: we have to check the size of rhs', not rhs.
1646 -- Duplicating a small InAlt might invalidate occurrence information
1647 -- However, if it *is* dupable, we return the *un* simplified alternative,
1648 -- because otherwise we'd need to pair it up with an empty subst-env....
1649 -- but we only have one env shared between all the alts.
1650 -- (Remember we must zap the subst-env before re-simplifying something).
1651 -- Rather than do this we simply agree to re-simplify the original (small) thing later.
1655 rhs_ty' = exprType rhs'
1656 used_bndrs' = filter (not . isDeadBinder) (case_bndr' : bndrs')
1657 -- The deadness info on the new binders is unscathed
1659 -- If we try to lift a primitive-typed something out
1660 -- for let-binding-purposes, we will *caseify* it (!),
1661 -- with potentially-disastrous strictness results. So
1662 -- instead we turn it into a function: \v -> e
1663 -- where v::State# RealWorld#. The value passed to this function
1664 -- is realworld#, which generates (almost) no code.
1666 -- There's a slight infelicity here: we pass the overall
1667 -- case_bndr to all the join points if it's used in *any* RHS,
1668 -- because we don't know its usage in each RHS separately
1670 -- We used to say "&& isUnLiftedType rhs_ty'" here, but now
1671 -- we make the join point into a function whenever used_bndrs'
1672 -- is empty. This makes the join-point more CPR friendly.
1673 -- Consider: let j = if .. then I# 3 else I# 4
1674 -- in case .. of { A -> j; B -> j; C -> ... }
1676 -- Now CPR doesn't w/w j because it's a thunk, so
1677 -- that means that the enclosing function can't w/w either,
1678 -- which is a lose. Here's the example that happened in practice:
1679 -- kgmod :: Int -> Int -> Int
1680 -- kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
1684 -- I have seen a case alternative like this:
1685 -- True -> \v -> ...
1686 -- It's a bit silly to add the realWorld dummy arg in this case, making
1689 -- (the \v alone is enough to make CPR happy) but I think it's rare
1691 ( if null used_bndrs'
1692 then newId SLIT("w") realWorldStatePrimTy `thenSmpl` \ rw_id ->
1693 returnSmpl ([rw_id], [Var realWorldPrimId])
1695 returnSmpl (used_bndrs', map varToCoreExpr used_bndrs')
1696 ) `thenSmpl` \ (final_bndrs', final_args) ->
1698 -- See comment about "$j" name above
1699 newId SLIT("$j") (foldr mkPiType rhs_ty' final_bndrs') `thenSmpl` \ join_bndr ->
1700 -- Notice the funky mkPiType. If the contructor has existentials
1701 -- it's possible that the join point will be abstracted over
1702 -- type varaibles as well as term variables.
1703 -- Example: Suppose we have
1704 -- data T = forall t. C [t]
1706 -- case (case e of ...) of
1707 -- C t xs::[t] -> rhs
1708 -- We get the join point
1709 -- let j :: forall t. [t] -> ...
1710 -- j = /\t \xs::[t] -> rhs
1712 -- case (case e of ...) of
1713 -- C t xs::[t] -> j t xs
1715 -- We make the lambdas into one-shot-lambdas. The
1716 -- join point is sure to be applied at most once, and doing so
1717 -- prevents the body of the join point being floated out by
1718 -- the full laziness pass
1719 really_final_bndrs = map one_shot final_bndrs'
1720 one_shot v | isId v = setOneShotLambda v
1722 join_rhs = mkLams really_final_bndrs rhs'
1723 join_call = mkApps (Var join_bndr) final_args
1725 returnSmpl (unitFloat env join_bndr join_rhs, (con, bndrs', join_call))