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 simplTopBndrs, 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, isLocalId,
28 zapLamIdInfo, setOneShotLambda,
30 import IdInfo ( OccInfo(..), isLoopBreaker,
35 import NewDemand ( isStrictDmd )
36 import DataCon ( dataConNumInstArgs, dataConRepStrictness )
38 import PprCore ( pprParendExpr, pprCoreExpr )
39 import CoreUnfold ( mkOtherCon, mkUnfolding, otherCons, callSiteInline )
40 import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding,
41 exprIsConApp_maybe, mkPiType, findAlt, findDefault,
42 exprType, coreAltsType, exprIsValue,
43 exprOkForSpeculation, exprArity,
44 mkCoerce, mkSCC, mkInlineMe, mkAltExpr
46 import Rules ( lookupRule )
47 import BasicTypes ( isMarkedStrict )
48 import CostCentre ( currentCCS )
49 import Type ( isUnLiftedType, seqType, mkFunTy, tyConAppArgs,
50 funResultTy, 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, isNotTopLevel,
61 import Maybe ( Maybe )
66 The guts of the simplifier is in this module, but the driver loop for
67 the simplifier is in SimplCore.lhs.
70 -----------------------------------------
71 *** IMPORTANT NOTE ***
72 -----------------------------------------
73 The simplifier used to guarantee that the output had no shadowing, but
74 it does not do so any more. (Actually, it never did!) The reason is
75 documented with simplifyArgs.
78 -----------------------------------------
79 *** IMPORTANT NOTE ***
80 -----------------------------------------
81 Many parts of the simplifier return a bunch of "floats" as well as an
82 expression. This is wrapped as a datatype SimplUtils.FloatsWith.
84 All "floats" are let-binds, not case-binds, but some non-rec lets may
85 be unlifted (with RHS ok-for-speculation).
89 -----------------------------------------
90 ORGANISATION OF FUNCTIONS
91 -----------------------------------------
93 - simplify all top-level binders
94 - for NonRec, call simplRecOrTopPair
95 - for Rec, call simplRecBind
98 ------------------------------
99 simplExpr (applied lambda) ==> simplNonRecBind
100 simplExpr (Let (NonRec ...) ..) ==> simplNonRecBind
101 simplExpr (Let (Rec ...) ..) ==> simplify binders; simplRecBind
103 ------------------------------
104 simplRecBind [binders already simplfied]
105 - use simplRecOrTopPair on each pair in turn
107 simplRecOrTopPair [binder already simplified]
108 Used for: recursive bindings (top level and nested)
109 top-level non-recursive bindings
111 - check for PreInlineUnconditionally
115 Used for: non-top-level non-recursive bindings
116 beta reductions (which amount to the same thing)
117 Because it can deal with strict arts, it takes a
118 "thing-inside" and returns an expression
120 - check for PreInlineUnconditionally
121 - simplify binder, including its IdInfo
130 simplNonRecX: [given a *simplified* RHS, but an *unsimplified* binder]
131 Used for: binding case-binder and constr args in a known-constructor case
132 - check for PreInLineUnconditionally
136 ------------------------------
137 simplLazyBind: [binder already simplified, RHS not]
138 Used for: recursive bindings (top level and nested)
139 top-level non-recursive bindings
140 non-top-level, but *lazy* non-recursive bindings
141 [must not be strict or unboxed]
142 Returns floats + an augmented environment, not an expression
143 - substituteIdInfo and add result to in-scope
144 [so that rules are available in rec rhs]
147 - float if exposes constructor or PAP
151 completeNonRecX: [binder and rhs both simplified]
152 - if the the thing needs case binding (unlifted and not ok-for-spec)
158 completeLazyBind: [given a simplified RHS]
159 [used for both rec and non-rec bindings, top level and not]
160 - try PostInlineUnconditionally
161 - add unfolding [this is the only place we add an unfolding]
166 Right hand sides and arguments
167 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
168 In many ways we want to treat
169 (a) the right hand side of a let(rec), and
170 (b) a function argument
171 in the same way. But not always! In particular, we would
172 like to leave these arguments exactly as they are, so they
173 will match a RULE more easily.
178 It's harder to make the rule match if we ANF-ise the constructor,
179 or eta-expand the PAP:
181 f (let { a = g x; b = h x } in (a,b))
184 On the other hand if we see the let-defns
189 then we *do* want to ANF-ise and eta-expand, so that p and q
190 can be safely inlined.
192 Even floating lets out is a bit dubious. For let RHS's we float lets
193 out if that exposes a value, so that the value can be inlined more vigorously.
196 r = let x = e in (x,x)
198 Here, if we float the let out we'll expose a nice constructor. We did experiments
199 that showed this to be a generally good thing. But it was a bad thing to float
200 lets out unconditionally, because that meant they got allocated more often.
202 For function arguments, there's less reason to expose a constructor (it won't
203 get inlined). Just possibly it might make a rule match, but I'm pretty skeptical.
204 So for the moment we don't float lets out of function arguments either.
209 For eta expansion, we want to catch things like
211 case e of (a,b) -> \x -> case a of (p,q) -> \y -> r
213 If the \x was on the RHS of a let, we'd eta expand to bring the two
214 lambdas together. And in general that's a good thing to do. Perhaps
215 we should eta expand wherever we find a (value) lambda? Then the eta
216 expansion at a let RHS can concentrate solely on the PAP case.
219 %************************************************************************
221 \subsection{Bindings}
223 %************************************************************************
226 simplTopBinds :: SimplEnv -> [InBind] -> SimplM [OutBind]
228 simplTopBinds env binds
229 = -- Put all the top-level binders into scope at the start
230 -- so that if a transformation rule has unexpectedly brought
231 -- anything into scope, then we don't get a complaint about that.
232 -- It's rather as if the top-level binders were imported.
233 simplTopBndrs env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') ->
234 simpl_binds env binds bndrs' `thenSmpl` \ (floats, _) ->
235 freeTick SimplifierDone `thenSmpl_`
236 returnSmpl (floatBinds floats)
238 -- We need to track the zapped top-level binders, because
239 -- they should have their fragile IdInfo zapped (notably occurrence info)
240 -- That's why we run down binds and bndrs' simultaneously.
241 simpl_binds :: SimplEnv -> [InBind] -> [OutId] -> SimplM (FloatsWith ())
242 simpl_binds env [] bs = ASSERT( null bs ) returnSmpl (emptyFloats env, ())
243 simpl_binds env (bind:binds) bs = simpl_bind env bind bs `thenSmpl` \ (floats,env) ->
244 addFloats env floats $ \env ->
245 simpl_binds env binds (drop_bs bind bs)
247 drop_bs (NonRec _ _) (_ : bs) = bs
248 drop_bs (Rec prs) bs = drop (length prs) bs
250 simpl_bind env (NonRec b r) (b':_) = simplRecOrTopPair env TopLevel b b' r
251 simpl_bind env (Rec pairs) bs' = simplRecBind env TopLevel pairs bs'
255 %************************************************************************
257 \subsection{simplNonRec}
259 %************************************************************************
261 simplNonRecBind is used for
262 * non-top-level non-recursive lets in expressions
266 * An unsimplified (binder, rhs) pair
267 * The env for the RHS. It may not be the same as the
268 current env because the bind might occur via (\x.E) arg
270 It uses the CPS form because the binding might be strict, in which
271 case we might discard the continuation:
272 let x* = error "foo" in (...x...)
274 It needs to turn unlifted bindings into a @case@. They can arise
275 from, say: (\x -> e) (4# + 3#)
278 simplNonRecBind :: SimplEnv
280 -> InExpr -> SimplEnv -- Arg, with its subst-env
281 -> OutType -- Type of thing computed by the context
282 -> (SimplEnv -> SimplM FloatsWithExpr) -- The body
283 -> SimplM FloatsWithExpr
285 simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside
287 = pprPanic "simplNonRecBind" (ppr bndr <+> ppr rhs)
290 simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside
291 | preInlineUnconditionally env NotTopLevel bndr
292 = tick (PreInlineUnconditionally bndr) `thenSmpl_`
293 thing_inside (extendSubst env bndr (ContEx (getSubstEnv rhs_se) rhs))
296 | isStrictDmd (idNewDemandInfo bndr) || isStrictType (idType bndr) -- A strict let
297 = -- Don't use simplBinder because that doesn't keep
298 -- fragile occurrence in the substitution
299 simplLetBndr env bndr `thenSmpl` \ (env, bndr') ->
300 simplStrictArg env AnRhs rhs rhs_se cont_ty $ \ env rhs1 ->
302 -- Now complete the binding and simplify the body
303 completeNonRecX env True {- strict -} bndr bndr' rhs1 thing_inside
305 | otherwise -- Normal, lazy case
306 = -- Don't use simplBinder because that doesn't keep
307 -- fragile occurrence in the substitution
308 simplLetBndr env bndr `thenSmpl` \ (env, bndr') ->
309 simplLazyBind env NotTopLevel NonRecursive
310 bndr bndr' rhs rhs_se `thenSmpl` \ (floats, env) ->
311 addFloats env floats thing_inside
314 A specialised variant of simplNonRec used when the RHS is already simplified, notably
315 in knownCon. It uses case-binding where necessary.
318 simplNonRecX :: SimplEnv
319 -> InId -- Old binder
320 -> OutExpr -- Simplified RHS
321 -> (SimplEnv -> SimplM FloatsWithExpr)
322 -> SimplM FloatsWithExpr
324 simplNonRecX env bndr new_rhs thing_inside
325 | preInlineUnconditionally env NotTopLevel bndr
326 -- This happens; for example, the case_bndr during case of
327 -- known constructor: case (a,b) of x { (p,q) -> ... }
328 -- Here x isn't mentioned in the RHS, so we don't want to
329 -- create the (dead) let-binding let x = (a,b) in ...
331 -- Similarly, single occurrences can be inlined vigourously
332 -- e.g. case (f x, g y) of (a,b) -> ....
333 -- If a,b occur once we can avoid constructing the let binding for them.
334 = thing_inside (extendSubst env bndr (ContEx emptySubstEnv new_rhs))
337 = simplBinder env bndr `thenSmpl` \ (env, bndr') ->
338 completeNonRecX env False {- Non-strict; pessimistic -}
339 bndr bndr' new_rhs thing_inside
341 completeNonRecX env is_strict old_bndr new_bndr new_rhs thing_inside
342 | needsCaseBinding (idType new_bndr) new_rhs
343 = thing_inside env `thenSmpl` \ (floats, body) ->
344 returnSmpl (emptyFloats env, Case new_rhs new_bndr [(DEFAULT, [], wrapFloats floats body)])
347 = mkAtomicArgs is_strict
348 True {- OK to float unlifted -}
349 new_rhs `thenSmpl` \ (aux_binds, rhs2) ->
351 -- Make the arguments atomic if necessary,
352 -- adding suitable bindings
353 addAtomicBindsE env aux_binds $ \ env ->
354 completeLazyBind env NotTopLevel
355 old_bndr new_bndr rhs2 `thenSmpl` \ (floats, env) ->
356 addFloats env floats thing_inside
360 %************************************************************************
362 \subsection{Lazy bindings}
364 %************************************************************************
366 simplRecBind is used for
367 * recursive bindings only
370 simplRecBind :: SimplEnv -> TopLevelFlag
371 -> [(InId, InExpr)] -> [OutId]
372 -> SimplM (FloatsWith SimplEnv)
373 simplRecBind env top_lvl pairs bndrs'
374 = go env pairs bndrs' `thenSmpl` \ (floats, env) ->
375 returnSmpl (flattenFloats floats, env)
377 go env [] _ = returnSmpl (emptyFloats env, env)
379 go env ((bndr, rhs) : pairs) (bndr' : bndrs')
380 = simplRecOrTopPair env top_lvl bndr bndr' rhs `thenSmpl` \ (floats, env) ->
381 addFloats env floats (\env -> go env pairs bndrs')
385 simplRecOrTopPair is used for
386 * recursive bindings (whether top level or not)
387 * top-level non-recursive bindings
389 It assumes the binder has already been simplified, but not its IdInfo.
392 simplRecOrTopPair :: SimplEnv
394 -> InId -> OutId -- Binder, both pre-and post simpl
395 -> InExpr -- The RHS and its environment
396 -> SimplM (FloatsWith SimplEnv)
398 simplRecOrTopPair env top_lvl bndr bndr' rhs
399 | preInlineUnconditionally env top_lvl bndr -- Check for unconditional inline
400 = tick (PreInlineUnconditionally bndr) `thenSmpl_`
401 returnSmpl (emptyFloats env, extendSubst env bndr (ContEx (getSubstEnv env) rhs))
404 = simplLazyBind env top_lvl Recursive bndr bndr' rhs env
405 -- May not actually be recursive, but it doesn't matter
409 simplLazyBind is used for
410 * recursive bindings (whether top level or not)
411 * top-level non-recursive bindings
412 * non-top-level *lazy* non-recursive bindings
414 [Thus it deals with the lazy cases from simplNonRecBind, and all cases
415 from SimplRecOrTopBind]
418 1. It assumes that the binder is *already* simplified,
419 and is in scope, but not its IdInfo
421 2. It assumes that the binder type is lifted.
423 3. It does not check for pre-inline-unconditionallly;
424 that should have been done already.
427 simplLazyBind :: SimplEnv
428 -> TopLevelFlag -> RecFlag
429 -> InId -> OutId -- Binder, both pre-and post simpl
430 -> InExpr -> SimplEnv -- The RHS and its environment
431 -> SimplM (FloatsWith SimplEnv)
433 simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se
434 = -- Substitute IdInfo on binder, in the light of earlier
435 -- substitutions in this very letrec, and extend the
436 -- in-scope env, so that the IdInfo for this binder extends
437 -- over the RHS for the binder itself.
439 -- This is important. Manuel found cases where he really, really
440 -- wanted a RULE for a recursive function to apply in that function's
441 -- own right-hand side.
443 -- NB: does no harm for non-recursive bindings
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 = isNotTopLevel top_lvl && 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 exprIsTrivial rhs2 || exprIsValue rhs2 then
485 -- There's a subtlety here. There may be a binding (x* = e) in the
486 -- floats, where the '*' means 'will be demanded'. So is it safe
487 -- to float it out? Answer no, but it won't matter because
488 -- we only float if arg' is a WHNF,
489 -- and so there can't be any 'will be demanded' bindings in the floats.
491 WARN( any demanded_float (floatBinds floats),
492 ppr (filter demanded_float (floatBinds floats)) )
494 tick LetFloatFromLet `thenSmpl_` (
495 addFloats env1 floats $ \ env2 ->
496 addAtomicBinds env2 aux_binds $ \ env3 ->
497 completeLazyBind env3 top_lvl bndr bndr'' rhs2)
500 completeLazyBind env1 top_lvl bndr bndr'' (wrapFloats floats rhs1)
503 demanded_float (NonRec b r) = isStrictDmd (idNewDemandInfo b) && not (isUnLiftedType (idType b))
504 -- Unlifted-type (cheap-eagerness) lets may well have a demanded flag on them
505 demanded_float (Rec _) = False
510 %************************************************************************
512 \subsection{Completing a lazy binding}
514 %************************************************************************
517 * deals only with Ids, not TyVars
518 * takes an already-simplified binder and RHS
519 * is used for both recursive and non-recursive bindings
520 * is used for both top-level and non-top-level bindings
522 It does the following:
523 - tries discarding a dead binding
524 - tries PostInlineUnconditionally
525 - add unfolding [this is the only place we add an unfolding]
528 It does *not* attempt to do let-to-case. Why? Because it is used for
529 - top-level bindings (when let-to-case is impossible)
530 - many situations where the "rhs" is known to be a WHNF
531 (so let-to-case is inappropriate).
534 completeLazyBind :: SimplEnv
535 -> TopLevelFlag -- Flag stuck into unfolding
536 -> InId -- Old binder
537 -> OutId -- New binder
538 -> OutExpr -- Simplified RHS
539 -> SimplM (FloatsWith SimplEnv)
540 -- We return a new SimplEnv, because completeLazyBind may choose to do its work
541 -- by extending the substitution (e.g. let x = y in ...)
542 -- The new binding (if any) is returned as part of the floats.
543 -- NB: the returned SimplEnv has the right SubstEnv, but you should
544 -- (as usual) use the in-scope-env from the floats
546 completeLazyBind env top_lvl old_bndr new_bndr new_rhs
547 | postInlineUnconditionally env new_bndr loop_breaker new_rhs
548 = -- Drop the binding
549 tick (PostInlineUnconditionally old_bndr) `thenSmpl_`
550 returnSmpl (emptyFloats env, extendSubst env old_bndr (DoneEx new_rhs))
551 -- Use the substitution to make quite, quite sure that the substitution
552 -- will happen, since we are going to discard the binding
557 new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs
559 -- Add the unfolding *only* for non-loop-breakers
560 -- Making loop breakers not have an unfolding at all
561 -- means that we can avoid tests in exprIsConApp, for example.
562 -- This is important: if exprIsConApp says 'yes' for a recursive
563 -- thing, then we can get into an infinite loop
564 info_w_unf | loop_breaker = new_bndr_info
565 | otherwise = new_bndr_info `setUnfoldingInfo` unfolding
566 unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs
568 final_id = new_bndr `setIdInfo` info_w_unf
570 -- These seqs forces the Id, and hence its IdInfo,
571 -- and hence any inner substitutions
573 returnSmpl (unitFloat env final_id new_rhs, env)
576 loop_breaker = isLoopBreaker occ_info
577 old_info = idInfo old_bndr
578 occ_info = occInfo old_info
583 %************************************************************************
585 \subsection[Simplify-simplExpr]{The main function: simplExpr}
587 %************************************************************************
589 The reason for this OutExprStuff stuff is that we want to float *after*
590 simplifying a RHS, not before. If we do so naively we get quadratic
591 behaviour as things float out.
593 To see why it's important to do it after, consider this (real) example:
607 a -- Can't inline a this round, cos it appears twice
611 Each of the ==> steps is a round of simplification. We'd save a
612 whole round if we float first. This can cascade. Consider
617 let f = let d1 = ..d.. in \y -> e
621 in \x -> ...(\y ->e)...
623 Only in this second round can the \y be applied, and it
624 might do the same again.
628 simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
629 simplExpr env expr = simplExprC env expr (mkBoringStop expr_ty')
631 expr_ty' = substTy (getSubst env) (exprType expr)
632 -- The type in the Stop continuation, expr_ty', is usually not used
633 -- It's only needed when discarding continuations after finding
634 -- a function that returns bottom.
635 -- Hence the lazy substitution
638 simplExprC :: SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr
639 -- Simplify an expression, given a continuation
640 simplExprC env expr cont
641 = simplExprF env expr cont `thenSmpl` \ (floats, expr) ->
642 returnSmpl (wrapFloats floats expr)
644 simplExprF :: SimplEnv -> InExpr -> SimplCont -> SimplM FloatsWithExpr
645 -- Simplify an expression, returning floated binds
647 simplExprF env (Var v) cont = simplVar env v cont
648 simplExprF env (Lit lit) cont = rebuild env (Lit lit) cont
649 simplExprF env expr@(Lam _ _) cont = simplLam env expr cont
650 simplExprF env (Note note expr) cont = simplNote env note expr cont
651 simplExprF env (App fun arg) cont = simplExprF env fun (ApplyTo NoDup arg env cont)
653 simplExprF env (Type ty) cont
654 = ASSERT( contIsRhsOrArg cont )
655 simplType env ty `thenSmpl` \ ty' ->
656 rebuild env (Type ty') cont
658 simplExprF env (Case scrut bndr alts) cont
659 | not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
660 = -- Simplify the scrutinee with a Select continuation
661 simplExprF env scrut (Select NoDup bndr alts env cont)
664 = -- If case-of-case is off, simply simplify the case expression
665 -- in a vanilla Stop context, and rebuild the result around it
666 simplExprC env scrut case_cont `thenSmpl` \ case_expr' ->
667 rebuild env case_expr' cont
669 case_cont = Select NoDup bndr alts env (mkBoringStop (contResultType cont))
671 simplExprF env (Let (Rec pairs) body) cont
672 = simplRecBndrs env (map fst pairs) `thenSmpl` \ (env, bndrs') ->
673 -- NB: bndrs' don't have unfoldings or spec-envs
674 -- We add them as we go down, using simplPrags
676 simplRecBind env NotTopLevel pairs bndrs' `thenSmpl` \ (floats, env) ->
677 addFloats env floats $ \ env ->
678 simplExprF env body cont
680 -- A non-recursive let is dealt with by simplNonRecBind
681 simplExprF env (Let (NonRec bndr rhs) body) cont
682 = simplNonRecBind env bndr rhs env (contResultType cont) $ \ env ->
683 simplExprF env body cont
686 ---------------------------------
687 simplType :: SimplEnv -> InType -> SimplM OutType
688 -- Kept monadic just so we can do the seqType
690 = seqType new_ty `seq` returnSmpl new_ty
692 new_ty = substTy (getSubst env) ty
696 %************************************************************************
700 %************************************************************************
703 simplLam env fun cont
706 zap_it = mkLamBndrZapper fun (countArgs cont)
707 cont_ty = contResultType cont
709 -- Type-beta reduction
710 go env (Lam bndr body) (ApplyTo _ (Type ty_arg) arg_se body_cont)
711 = ASSERT( isTyVar bndr )
712 tick (BetaReduction bndr) `thenSmpl_`
713 simplType (setInScope arg_se env) ty_arg `thenSmpl` \ ty_arg' ->
714 go (extendSubst env bndr (DoneTy ty_arg')) body body_cont
716 -- Ordinary beta reduction
717 go env (Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont)
718 = tick (BetaReduction bndr) `thenSmpl_`
719 simplNonRecBind env (zap_it bndr) arg arg_se cont_ty $ \ env ->
720 go env body body_cont
722 -- Not enough args, so there are real lambdas left to put in the result
723 go env lam@(Lam _ _) cont
724 = simplLamBndrs env bndrs `thenSmpl` \ (env, bndrs') ->
725 simplExpr env body `thenSmpl` \ body' ->
726 mkLam env bndrs' body' cont `thenSmpl` \ (floats, new_lam) ->
727 addFloats env floats $ \ env ->
728 rebuild env new_lam cont
730 (bndrs,body) = collectBinders lam
732 -- Exactly enough args
733 go env expr cont = simplExprF env expr cont
735 mkLamBndrZapper :: CoreExpr -- Function
736 -> Int -- Number of args supplied, *including* type args
737 -> Id -> Id -- Use this to zap the binders
738 mkLamBndrZapper fun n_args
739 | n_args >= n_params fun = \b -> b -- Enough args
740 | otherwise = \b -> zapLamIdInfo b
742 -- NB: we count all the args incl type args
743 -- so we must count all the binders (incl type lambdas)
744 n_params (Note _ e) = n_params e
745 n_params (Lam b e) = 1 + n_params e
746 n_params other = 0::Int
750 %************************************************************************
754 %************************************************************************
757 simplNote env (Coerce to from) body cont
759 in_scope = getInScope env
761 addCoerce s1 k1 (CoerceIt t1 cont)
762 -- coerce T1 S1 (coerce S1 K1 e)
765 -- coerce T1 K1 e, otherwise
767 -- For example, in the initial form of a worker
768 -- we may find (coerce T (coerce S (\x.e))) y
769 -- and we'd like it to simplify to e[y/x] in one round
771 | t1 `eqType` k1 = cont -- The coerces cancel out
772 | otherwise = CoerceIt t1 cont -- They don't cancel, but
773 -- the inner one is redundant
775 addCoerce t1t2 s1s2 (ApplyTo dup arg arg_se cont)
776 | Just (s1, s2) <- splitFunTy_maybe s1s2
777 -- (coerce (T1->T2) (S1->S2) F) E
779 -- coerce T2 S2 (F (coerce S1 T1 E))
781 -- t1t2 must be a function type, T1->T2
782 -- but s1s2 might conceivably not be
784 -- When we build the ApplyTo we can't mix the out-types
785 -- with the InExpr in the argument, so we simply substitute
786 -- to make it all consistent. It's a bit messy.
787 -- But it isn't a common case.
789 (t1,t2) = splitFunTy t1t2
790 new_arg = mkCoerce s1 t1 (substExpr (mkSubst in_scope (getSubstEnv arg_se)) arg)
792 ApplyTo dup new_arg (zapSubstEnv env) (addCoerce t2 s2 cont)
794 addCoerce to' _ cont = CoerceIt to' cont
796 simplType env to `thenSmpl` \ to' ->
797 simplType env from `thenSmpl` \ from' ->
798 simplExprF env body (addCoerce to' from' cont)
801 -- Hack: we only distinguish subsumed cost centre stacks for the purposes of
802 -- inlining. All other CCCSs are mapped to currentCCS.
803 simplNote env (SCC cc) e cont
804 = simplExpr (setEnclosingCC env currentCCS) e `thenSmpl` \ e' ->
805 rebuild env (mkSCC cc e') cont
807 simplNote env InlineCall e cont
808 = simplExprF env e (InlinePlease cont)
810 -- See notes with SimplMonad.inlineMode
811 simplNote env InlineMe e cont
812 | contIsRhsOrArg cont -- Totally boring continuation; see notes above
813 = -- Don't inline inside an INLINE expression
814 simplExpr (setMode inlineMode env ) e `thenSmpl` \ e' ->
815 rebuild env (mkInlineMe e') cont
817 | otherwise -- Dissolve the InlineMe note if there's
818 -- an interesting context of any kind to combine with
819 -- (even a type application -- anything except Stop)
820 = simplExprF env e cont
824 %************************************************************************
826 \subsection{Dealing with calls}
828 %************************************************************************
831 simplVar env var cont
832 = case lookupIdSubst (getSubst env) var of
833 DoneEx e -> simplExprF (zapSubstEnv env) e cont
834 ContEx se e -> simplExprF (setSubstEnv env se) e cont
835 DoneId var1 occ -> WARN( not (isInScope var1 (getSubst env)) && mustHaveLocalBinding var1,
836 text "simplVar:" <+> ppr var )
837 completeCall (zapSubstEnv env) var1 occ cont
838 -- The template is already simplified, so don't re-substitute.
839 -- This is VITAL. Consider
841 -- let y = \z -> ...x... in
843 -- We'll clone the inner \x, adding x->x' in the id_subst
844 -- Then when we inline y, we must *not* replace x by x' in
845 -- the inlined copy!!
847 ---------------------------------------------------------
848 -- Dealing with a call site
850 completeCall env var occ_info cont
851 = -- Simplify the arguments
852 getDOptsSmpl `thenSmpl` \ dflags ->
854 chkr = getSwitchChecker env
855 (args, call_cont, inline_call) = getContArgs chkr var cont
857 simplifyArgs env args (contResultType call_cont) $ \ env args ->
859 -- Next, look for rules or specialisations that match
861 -- It's important to simplify the args first, because the rule-matcher
862 -- doesn't do substitution as it goes. We don't want to use subst_args
863 -- (defined in the 'where') because that throws away useful occurrence info,
864 -- and perhaps-very-important specialisations.
866 -- Some functions have specialisations *and* are strict; in this case,
867 -- we don't want to inline the wrapper of the non-specialised thing; better
868 -- to call the specialised thing instead.
869 -- We used to use the black-listing mechanism to ensure that inlining of
870 -- the wrapper didn't occur for things that have specialisations till a
871 -- later phase, so but now we just try RULES first
873 -- You might think that we shouldn't apply rules for a loop breaker:
874 -- doing so might give rise to an infinite loop, because a RULE is
875 -- rather like an extra equation for the function:
876 -- RULE: f (g x) y = x+y
879 -- But it's too drastic to disable rules for loop breakers.
880 -- Even the foldr/build rule would be disabled, because foldr
881 -- is recursive, and hence a loop breaker:
882 -- foldr k z (build g) = g k z
883 -- So it's up to the programmer: rules can cause divergence
886 in_scope = getInScope env
887 maybe_rule = case activeRule env of
888 Nothing -> Nothing -- No rules apply
889 Just act_fn -> lookupRule act_fn in_scope var args
892 Just (rule_name, rule_rhs) ->
893 tick (RuleFired rule_name) `thenSmpl_`
894 (if dopt Opt_D_dump_inlinings dflags then
895 pprTrace "Rule fired" (vcat [
896 text "Rule:" <+> ptext rule_name,
897 text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
898 text "After: " <+> pprCoreExpr rule_rhs])
901 simplExprF env rule_rhs call_cont ;
903 Nothing -> -- No rules
905 -- Next, look for an inlining
907 arg_infos = [ interestingArg arg | arg <- args, isValArg arg]
909 interesting_cont = interestingCallContext (not (null args))
910 (not (null arg_infos))
913 active_inline = activeInline env var
914 maybe_inline = callSiteInline dflags active_inline inline_call occ_info
915 var arg_infos interesting_cont
917 case maybe_inline of {
918 Just unfolding -- There is an inlining!
919 -> tick (UnfoldingDone var) `thenSmpl_`
920 makeThatCall env var unfolding args call_cont
923 Nothing -> -- No inlining!
926 rebuild env (mkApps (Var var) args) call_cont
929 makeThatCall :: SimplEnv
931 -> InExpr -- Inlined function rhs
932 -> [OutExpr] -- Arguments, already simplified
933 -> SimplCont -- After the call
934 -> SimplM FloatsWithExpr
935 -- Similar to simplLam, but this time
936 -- the arguments are already simplified
937 makeThatCall orig_env var fun@(Lam _ _) args cont
938 = go orig_env fun args
940 zap_it = mkLamBndrZapper fun (length args)
942 -- Type-beta reduction
943 go env (Lam bndr body) (Type ty_arg : args)
944 = ASSERT( isTyVar bndr )
945 tick (BetaReduction bndr) `thenSmpl_`
946 go (extendSubst env bndr (DoneTy ty_arg)) body args
948 -- Ordinary beta reduction
949 go env (Lam bndr body) (arg : args)
950 = tick (BetaReduction bndr) `thenSmpl_`
951 simplNonRecX env (zap_it bndr) arg $ \ env ->
954 -- Not enough args, so there are real lambdas left to put in the result
956 = simplExprF env fun (pushContArgs orig_env args cont)
957 -- NB: orig_env; the correct environment to capture with
958 -- the arguments.... env has been augmented with substitutions
959 -- from the beta reductions.
961 makeThatCall env var fun args cont
962 = simplExprF env fun (pushContArgs env args cont)
966 %************************************************************************
968 \subsection{Arguments}
970 %************************************************************************
973 ---------------------------------------------------------
974 -- Simplifying the arguments of a call
976 simplifyArgs :: SimplEnv
977 -> [(InExpr, SimplEnv, Bool)] -- Details of the arguments
978 -> OutType -- Type of the continuation
979 -> (SimplEnv -> [OutExpr] -> SimplM FloatsWithExpr)
980 -> SimplM FloatsWithExpr
982 -- [CPS-like because of strict arguments]
984 -- Simplify the arguments to a call.
985 -- This part of the simplifier may break the no-shadowing invariant
987 -- f (...(\a -> e)...) (case y of (a,b) -> e')
988 -- where f is strict in its second arg
989 -- If we simplify the innermost one first we get (...(\a -> e)...)
990 -- Simplifying the second arg makes us float the case out, so we end up with
991 -- case y of (a,b) -> f (...(\a -> e)...) e'
992 -- So the output does not have the no-shadowing invariant. However, there is
993 -- no danger of getting name-capture, because when the first arg was simplified
994 -- we used an in-scope set that at least mentioned all the variables free in its
995 -- static environment, and that is enough.
997 -- We can't just do innermost first, or we'd end up with a dual problem:
998 -- case x of (a,b) -> f e (...(\a -> e')...)
1000 -- I spent hours trying to recover the no-shadowing invariant, but I just could
1001 -- not think of an elegant way to do it. The simplifier is already knee-deep in
1002 -- continuations. We have to keep the right in-scope set around; AND we have
1003 -- to get the effect that finding (error "foo") in a strict arg position will
1004 -- discard the entire application and replace it with (error "foo"). Getting
1005 -- all this at once is TOO HARD!
1007 simplifyArgs env args cont_ty thing_inside
1008 = go env args thing_inside
1010 go env [] thing_inside = thing_inside env []
1011 go env (arg:args) thing_inside = simplifyArg env arg cont_ty $ \ env arg' ->
1012 go env args $ \ env args' ->
1013 thing_inside env (arg':args')
1015 simplifyArg env (Type ty_arg, se, _) cont_ty thing_inside
1016 = simplType (setInScope se env) ty_arg `thenSmpl` \ new_ty_arg ->
1017 thing_inside env (Type new_ty_arg)
1019 simplifyArg env (val_arg, arg_se, is_strict) cont_ty thing_inside
1021 = simplStrictArg env AnArg val_arg arg_se cont_ty thing_inside
1025 arg_env = setInScope arg_se env
1027 simplType arg_env (exprType val_arg) `thenSmpl` \ arg_ty ->
1028 simplExprF arg_env val_arg (mkStop arg_ty AnArg) `thenSmpl` \ (floats, arg1) ->
1029 addFloats env floats $ \ env ->
1030 thing_inside env arg1
1033 simplStrictArg :: SimplEnv -- The env of the call
1035 -> InExpr -> SimplEnv -- The arg plus its env
1036 -> OutType -- cont_ty: Type of thing computed by the context
1037 -> (SimplEnv -> OutExpr -> SimplM FloatsWithExpr)
1038 -- Takes an expression of type rhs_ty,
1039 -- returns an expression of type cont_ty
1040 -- The env passed to this continuation is the
1041 -- env of the call, plus any new in-scope variables
1042 -> SimplM FloatsWithExpr -- An expression of type cont_ty
1044 simplStrictArg call_env is_rhs arg arg_env cont_ty thing_inside
1045 = simplExprF (setInScope arg_env call_env) arg
1046 (ArgOf NoDup is_rhs cont_ty (\ new_env -> thing_inside (setInScope call_env new_env)))
1047 -- Notice the way we use arg_env (augmented with in-scope vars from call_env)
1048 -- to simplify the argument
1049 -- and call-env (augmented with in-scope vars from the arg) to pass to the continuation
1053 %************************************************************************
1055 \subsection{mkAtomicArgs}
1057 %************************************************************************
1059 mkAtomicArgs takes a putative RHS, checks whether it's a PAP or
1060 constructor application and, if so, converts it to ANF, so that the
1061 resulting thing can be inlined more easily. Thus
1068 There are three sorts of binding context, specified by the two
1074 N N Top-level or recursive Only bind args of lifted type
1076 N Y Non-top-level and non-recursive, Bind args of lifted type, or
1077 but lazy unlifted-and-ok-for-speculation
1079 Y Y Non-top-level, non-recursive, Bind all args
1080 and strict (demanded)
1087 there is no point in transforming to
1089 x = case (y div# z) of r -> MkC r
1091 because the (y div# z) can't float out of the let. But if it was
1092 a *strict* let, then it would be a good thing to do. Hence the
1093 context information.
1096 mkAtomicArgs :: Bool -- A strict binding
1097 -> Bool -- OK to float unlifted args
1099 -> SimplM ([(OutId,OutExpr)], -- The floats (unusually) may include
1100 OutExpr) -- things that need case-binding,
1101 -- if the strict-binding flag is on
1103 mkAtomicArgs is_strict ok_float_unlifted rhs
1104 = mk_atomic_args rhs `thenSmpl` \ maybe_stuff ->
1106 Nothing -> returnSmpl ([], rhs)
1107 Just (ol_binds, rhs') -> returnSmpl (fromOL ol_binds, rhs')
1110 mk_atomic_args :: OutExpr -> SimplM (Maybe (OrdList (Id,OutExpr), OutExpr))
1111 -- Nothing => no change
1113 | (Var fun, args) <- collectArgs rhs, -- It's an application
1114 isDataConId fun || valArgCount args < idArity fun -- And it's a constructor or PAP
1116 go nilOL [] args `thenSmpl` \ maybe_stuff ->
1118 Nothing -> returnSmpl Nothing
1119 Just (aux_binds, args') -> returnSmpl (Just (aux_binds, mkApps (Var fun) args'))
1122 = returnSmpl Nothing
1124 go binds rev_args []
1125 = returnSmpl (Just (binds, reverse rev_args))
1126 go binds rev_args (arg : args)
1127 | exprIsTrivial arg -- Easy case
1128 = go binds (arg:rev_args) args
1130 | not can_float_arg -- Can't make this arg atomic
1131 = returnSmpl Nothing -- ... so give up
1133 | otherwise -- Don't forget to do it recursively
1134 -- E.g. x = a:b:c:[]
1135 = mk_atomic_args arg `thenSmpl` \ maybe_anf ->
1137 Nothing -> returnSmpl Nothing ;
1138 Just (arg_binds,arg') ->
1140 newId SLIT("a") arg_ty `thenSmpl` \ arg_id ->
1141 go ((arg_binds `snocOL` (arg_id,arg')) `appOL` binds)
1142 (Var arg_id : rev_args) args
1145 arg_ty = exprType arg
1146 can_float_arg = is_strict
1147 || not (isUnLiftedType arg_ty)
1148 || (ok_float_unlifted && exprOkForSpeculation arg)
1150 addAtomicBinds :: SimplEnv -> [(OutId,OutExpr)]
1151 -> (SimplEnv -> SimplM (FloatsWith a))
1152 -> SimplM (FloatsWith a)
1153 addAtomicBinds env [] thing_inside = thing_inside env
1154 addAtomicBinds env ((v,r):bs) thing_inside = addAuxiliaryBind env (NonRec v r) $ \ env ->
1155 addAtomicBinds env bs thing_inside
1157 addAtomicBindsE :: SimplEnv -> [(OutId,OutExpr)]
1158 -> (SimplEnv -> SimplM FloatsWithExpr)
1159 -> SimplM FloatsWithExpr
1160 -- Same again, but this time we're in an expression context,
1161 -- and may need to do some case bindings
1163 addAtomicBindsE env [] thing_inside
1165 addAtomicBindsE env ((v,r):bs) thing_inside
1166 | needsCaseBinding (idType v) r
1167 = addAtomicBindsE (addNewInScopeIds env [v]) bs thing_inside `thenSmpl` \ (floats, expr) ->
1168 WARN( exprIsTrivial expr, ppr v <+> pprCoreExpr expr )
1169 returnSmpl (emptyFloats env, Case r v [(DEFAULT,[], wrapFloats floats expr)])
1172 = addAuxiliaryBind env (NonRec v r) $ \ env ->
1173 addAtomicBindsE env bs thing_inside
1177 %************************************************************************
1179 \subsection{The main rebuilder}
1181 %************************************************************************
1184 rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM FloatsWithExpr
1186 rebuild env expr (Stop _ _ _) = rebuildDone env expr
1187 rebuild env expr (ArgOf _ _ _ cont_fn) = cont_fn env expr
1188 rebuild env expr (CoerceIt to_ty cont) = rebuild env (mkCoerce to_ty (exprType expr) expr) cont
1189 rebuild env expr (InlinePlease cont) = rebuild env (Note InlineCall expr) cont
1190 rebuild env expr (Select _ bndr alts se cont) = rebuildCase (setInScope se env) expr bndr alts cont
1191 rebuild env expr (ApplyTo _ arg se cont) = rebuildApp (setInScope se env) expr arg cont
1193 rebuildApp env fun arg cont
1194 = simplExpr env arg `thenSmpl` \ arg' ->
1195 rebuild env (App fun arg') cont
1197 rebuildDone env expr = returnSmpl (emptyFloats env, expr)
1201 %************************************************************************
1203 \subsection{Functions dealing with a case}
1205 %************************************************************************
1207 Blob of helper functions for the "case-of-something-else" situation.
1210 ---------------------------------------------------------
1211 -- Eliminate the case if possible
1213 rebuildCase :: SimplEnv
1214 -> OutExpr -- Scrutinee
1215 -> InId -- Case binder
1216 -> [InAlt] -- Alternatives
1218 -> SimplM FloatsWithExpr
1220 rebuildCase env scrut case_bndr alts cont
1221 | Just (con,args) <- exprIsConApp_maybe scrut
1222 -- Works when the scrutinee is a variable with a known unfolding
1223 -- as well as when it's an explicit constructor application
1224 = knownCon env (DataAlt con) args case_bndr alts cont
1226 | Lit lit <- scrut -- No need for same treatment as constructors
1227 -- because literals are inlined more vigorously
1228 = knownCon env (LitAlt lit) [] case_bndr alts cont
1231 = -- Prepare case alternatives
1232 -- Filter out alternatives that can't possibly match
1234 impossible_cons = case scrut of
1235 Var v -> otherCons (idUnfolding v)
1237 better_alts = case impossible_cons of
1239 other -> [alt | alt@(con,_,_) <- alts,
1240 not (con `elem` impossible_cons)]
1242 -- "handled_cons" are handled either by the context,
1243 -- or by a branch in this case expression
1244 -- Don't add DEFAULT to the handled_cons!!
1245 (alts_wo_default, _) = findDefault better_alts
1246 handled_cons = impossible_cons ++ [con | (con,_,_) <- alts_wo_default]
1249 -- Deal with the case binder, and prepare the continuation;
1250 -- The new subst_env is in place
1251 prepareCaseCont env better_alts cont `thenSmpl` \ (floats, cont') ->
1252 addFloats env floats $ \ env ->
1254 -- Deal with variable scrutinee
1255 simplCaseBinder env scrut case_bndr `thenSmpl` \ (alt_env, case_bndr', zap_occ_info) ->
1257 -- Deal with the case alternatives
1258 simplAlts alt_env zap_occ_info handled_cons
1259 case_bndr' better_alts cont' `thenSmpl` \ alts' ->
1261 -- Put the case back together
1262 mkCase scrut handled_cons case_bndr' alts' `thenSmpl` \ case_expr ->
1264 -- Notice that rebuildDone returns the in-scope set from env, not alt_env
1265 -- The case binder *not* scope over the whole returned case-expression
1266 rebuildDone env case_expr
1269 simplCaseBinder checks whether the scrutinee is a variable, v. If so,
1270 try to eliminate uses of v in the RHSs in favour of case_bndr; that
1271 way, there's a chance that v will now only be used once, and hence
1276 There is a time we *don't* want to do that, namely when
1277 -fno-case-of-case is on. This happens in the first simplifier pass,
1278 and enhances full laziness. Here's the bad case:
1279 f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )
1280 If we eliminate the inner case, we trap it inside the I# v -> arm,
1281 which might prevent some full laziness happening. I've seen this
1282 in action in spectral/cichelli/Prog.hs:
1283 [(m,n) | m <- [1..max], n <- [1..max]]
1284 Hence the check for NoCaseOfCase.
1288 There is another situation when we don't want to do it. If we have
1290 case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }
1291 ...other cases .... }
1293 We'll perform the binder-swap for the outer case, giving
1295 case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }
1296 ...other cases .... }
1298 But there is no point in doing it for the inner case,
1299 because w1 can't be inlined anyway. Furthermore, doing the case-swapping
1300 involves zapping w2's occurrence info (see paragraphs that follow),
1301 and that forces us to bind w2 when doing case merging. So we get
1303 case x of w1 { A -> let w2 = w1 in e1
1304 B -> let w2 = w1 in e2
1305 ...other cases .... }
1307 This is plain silly in the common case where w2 is dead.
1309 Even so, I can't see a good way to implement this idea. I tried
1310 not doing the binder-swap if the scrutinee was already evaluated
1311 but that failed big-time:
1315 case v of w { MkT x ->
1316 case x of x1 { I# y1 ->
1317 case x of x2 { I# y2 -> ...
1319 Notice that because MkT is strict, x is marked "evaluated". But to
1320 eliminate the last case, we must either make sure that x (as well as
1321 x1) has unfolding MkT y1. THe straightforward thing to do is to do
1322 the binder-swap. So this whole note is a no-op.
1326 If we replace the scrutinee, v, by tbe case binder, then we have to nuke
1327 any occurrence info (eg IAmDead) in the case binder, because the
1328 case-binder now effectively occurs whenever v does. AND we have to do
1329 the same for the pattern-bound variables! Example:
1331 (case x of { (a,b) -> a }) (case x of { (p,q) -> q })
1333 Here, b and p are dead. But when we move the argment inside the first
1334 case RHS, and eliminate the second case, we get
1336 case x or { (a,b) -> a b }
1338 Urk! b is alive! Reason: the scrutinee was a variable, and case elimination
1339 happened. Hence the zap_occ_info function returned by simplCaseBinder
1342 simplCaseBinder env (Var v) case_bndr
1343 | not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
1345 -- Failed try [see Note 2 above]
1346 -- not (isEvaldUnfolding (idUnfolding v))
1348 = simplBinder env (zap case_bndr) `thenSmpl` \ (env, case_bndr') ->
1349 returnSmpl (modifyInScope env v case_bndr', case_bndr', zap)
1350 -- We could extend the substitution instead, but it would be
1351 -- a hack because then the substitution wouldn't be idempotent
1352 -- any more (v is an OutId). And this just just as well.
1354 zap b = b `setIdOccInfo` NoOccInfo
1356 simplCaseBinder env other_scrut case_bndr
1357 = simplBinder env case_bndr `thenSmpl` \ (env, case_bndr') ->
1358 returnSmpl (env, case_bndr', \ bndr -> bndr) -- NoOp on bndr
1364 simplAlts :: SimplEnv
1365 -> (InId -> InId) -- Occ-info zapper
1366 -> [AltCon] -- Alternatives the scrutinee can't be
1367 -- in the default case
1368 -> OutId -- Case binder
1369 -> [InAlt] -> SimplCont
1370 -> SimplM [OutAlt] -- Includes the continuation
1372 simplAlts env zap_occ_info handled_cons case_bndr' alts cont'
1373 = mapSmpl simpl_alt alts
1375 inst_tys' = tyConAppArgs (idType case_bndr')
1377 simpl_alt (DEFAULT, _, rhs)
1379 -- In the default case we record the constructors that the
1380 -- case-binder *can't* be.
1381 -- We take advantage of any OtherCon info in the case scrutinee
1382 case_bndr_w_unf = case_bndr' `setIdUnfolding` mkOtherCon handled_cons
1383 env_with_unf = modifyInScope env case_bndr' case_bndr_w_unf
1385 simplExprC env_with_unf rhs cont' `thenSmpl` \ rhs' ->
1386 returnSmpl (DEFAULT, [], rhs')
1388 simpl_alt (con, vs, rhs)
1389 = -- Deal with the pattern-bound variables
1390 -- Mark the ones that are in ! positions in the data constructor
1391 -- as certainly-evaluated.
1392 -- NB: it happens that simplBinders does *not* erase the OtherCon
1393 -- form of unfolding, so it's ok to add this info before
1394 -- doing simplBinders
1395 simplBinders env (add_evals con vs) `thenSmpl` \ (env, vs') ->
1397 -- Bind the case-binder to (con args)
1399 unfolding = mkUnfolding False (mkAltExpr con vs' inst_tys')
1400 env_with_unf = modifyInScope env case_bndr' (case_bndr' `setIdUnfolding` unfolding)
1402 simplExprC env_with_unf rhs cont' `thenSmpl` \ rhs' ->
1403 returnSmpl (con, vs', rhs')
1406 -- add_evals records the evaluated-ness of the bound variables of
1407 -- a case pattern. This is *important*. Consider
1408 -- data T = T !Int !Int
1410 -- case x of { T a b -> T (a+1) b }
1412 -- We really must record that b is already evaluated so that we don't
1413 -- go and re-evaluate it when constructing the result.
1415 add_evals (DataAlt dc) vs = cat_evals vs (dataConRepStrictness dc)
1416 add_evals other_con vs = vs
1418 cat_evals [] [] = []
1419 cat_evals (v:vs) (str:strs)
1420 | isTyVar v = v : cat_evals vs (str:strs)
1421 | isMarkedStrict str = evald_v : cat_evals vs strs
1422 | otherwise = zapped_v : cat_evals vs strs
1424 zapped_v = zap_occ_info v
1425 evald_v = zapped_v `setIdUnfolding` mkOtherCon []
1429 %************************************************************************
1431 \subsection{Known constructor}
1433 %************************************************************************
1435 We are a bit careful with occurrence info. Here's an example
1437 (\x* -> case x of (a*, b) -> f a) (h v, e)
1439 where the * means "occurs once". This effectively becomes
1440 case (h v, e) of (a*, b) -> f a)
1442 let a* = h v; b = e in f a
1446 All this should happen in one sweep.
1449 knownCon :: SimplEnv -> AltCon -> [OutExpr]
1450 -> InId -> [InAlt] -> SimplCont
1451 -> SimplM FloatsWithExpr
1453 knownCon env con args bndr alts cont
1454 = tick (KnownBranch bndr) `thenSmpl_`
1455 case findAlt con alts of
1456 (DEFAULT, bs, rhs) -> ASSERT( null bs )
1457 simplNonRecX env bndr scrut $ \ env ->
1458 -- This might give rise to a binding with non-atomic args
1459 -- like x = Node (f x) (g x)
1460 -- but no harm will be done
1461 simplExprF env rhs cont
1464 LitAlt lit -> Lit lit
1465 DataAlt dc -> mkConApp dc args
1467 (LitAlt lit, bs, rhs) -> ASSERT( null bs )
1468 simplNonRecX env bndr (Lit lit) $ \ env ->
1469 simplExprF env rhs cont
1471 (DataAlt dc, bs, rhs) -> ASSERT( length bs + n_tys == length args )
1472 bind_args env bs (drop n_tys args) $ \ env ->
1474 con_app = mkConApp dc (take n_tys args ++ con_args)
1475 con_args = [substExpr (getSubst env) (varToCoreExpr b) | b <- bs]
1476 -- args are aready OutExprs, but bs are InIds
1478 simplNonRecX env bndr con_app $ \ env ->
1479 simplExprF env rhs cont
1481 n_tys = dataConNumInstArgs dc -- Non-existential type args
1483 bind_args env [] _ thing_inside = thing_inside env
1485 bind_args env (b:bs) (Type ty : args) thing_inside
1486 = bind_args (extendSubst env b (DoneTy ty)) bs args thing_inside
1488 bind_args env (b:bs) (arg : args) thing_inside
1489 = simplNonRecX env b arg $ \ env ->
1490 bind_args env bs args thing_inside
1494 %************************************************************************
1496 \subsection{Duplicating continuations}
1498 %************************************************************************
1501 prepareCaseCont :: SimplEnv
1502 -> [InAlt] -> SimplCont
1503 -> SimplM (FloatsWith SimplCont) -- Return a duplicatable continuation,
1504 -- plus some extra bindings
1506 prepareCaseCont env [alt] cont = returnSmpl (emptyFloats env, cont)
1507 -- No need to make it duplicatable if there's only one alternative
1509 prepareCaseCont env alts cont = simplType env (coreAltsType alts) `thenSmpl` \ alts_ty ->
1510 mkDupableCont env alts_ty cont
1511 -- At one time I passed in the un-simplified type, and simplified
1512 -- it only if we needed to construct a join binder, but that
1513 -- didn't work because we have to decompse function types
1514 -- (using funResultTy) in mkDupableCont.
1518 mkDupableCont :: SimplEnv
1519 -> OutType -- Type of the thing to be given to the continuation
1521 -> SimplM (FloatsWith SimplCont) -- Return a duplicatable continuation,
1522 -- plus some extra bindings
1524 mkDupableCont env ty cont
1525 | contIsDupable cont
1526 = returnSmpl (emptyFloats env, cont)
1528 mkDupableCont env _ (CoerceIt ty cont)
1529 = mkDupableCont env ty cont `thenSmpl` \ (floats, cont') ->
1530 returnSmpl (floats, CoerceIt ty cont')
1532 mkDupableCont env ty (InlinePlease cont)
1533 = mkDupableCont env ty cont `thenSmpl` \ (floats, cont') ->
1534 returnSmpl (floats, InlinePlease cont')
1536 mkDupableCont env join_arg_ty (ArgOf _ is_rhs cont_ty cont_fn)
1537 = -- e.g. (...strict-fn...) [...hole...]
1539 -- let $j = \a -> ...strict-fn...
1540 -- in $j [...hole...]
1542 -- Build the join Id and continuation
1543 -- We give it a "$j" name just so that for later amusement
1544 -- we can identify any join points that don't end up as let-no-escapes
1545 -- [NOTE: the type used to be exprType join_rhs, but this seems more elegant.]
1546 newId SLIT("$j") (mkFunTy join_arg_ty cont_ty) `thenSmpl` \ join_id ->
1547 newId SLIT("a") join_arg_ty `thenSmpl` \ arg_id ->
1549 cont_fn (addNewInScopeIds env [arg_id]) (Var arg_id) `thenSmpl` \ (floats, rhs) ->
1551 cont_fn env arg' = rebuildDone env (App (Var join_id) arg')
1552 join_rhs = Lam (setOneShotLambda arg_id) (wrapFloats floats rhs)
1555 tick (CaseOfCase join_id) `thenSmpl_`
1556 -- Want to tick here so that we go round again,
1557 -- and maybe copy or inline the code;
1558 -- not strictly CaseOf Case
1560 returnSmpl (unitFloat env join_id join_rhs,
1561 ArgOf OkToDup is_rhs cont_ty cont_fn)
1563 mkDupableCont env ty (ApplyTo _ arg se cont)
1564 = -- e.g. [...hole...] (...arg...)
1566 -- let a = ...arg...
1567 -- in [...hole...] a
1568 mkDupableCont env (funResultTy ty) cont `thenSmpl` \ (floats, cont') ->
1569 addFloats env floats $ \ env ->
1571 simplExpr (setInScope se env) arg `thenSmpl` \ arg' ->
1572 if exprIsDupable arg' then
1573 returnSmpl (emptyFloats env, ApplyTo OkToDup arg' (zapSubstEnv se) cont')
1575 newId SLIT("a") (exprType arg') `thenSmpl` \ arg_id ->
1577 tick (CaseOfCase arg_id) `thenSmpl_`
1578 -- Want to tick here so that we go round again,
1579 -- and maybe copy or inline the code.
1580 -- Not strictly CaseOfCase, but never mind
1582 returnSmpl (unitFloat env arg_id arg',
1583 ApplyTo OkToDup (Var arg_id) (zapSubstEnv se) cont')
1584 -- But what if the arg should be case-bound?
1585 -- This has been this way for a long time, so I'll leave it,
1586 -- but I can't convince myself that it's right.
1589 mkDupableCont env ty (Select _ case_bndr alts se cont)
1590 = -- e.g. (case [...hole...] of { pi -> ei })
1592 -- let ji = \xij -> ei
1593 -- in case [...hole...] of { pi -> ji xij }
1594 tick (CaseOfCase case_bndr) `thenSmpl_`
1596 alt_env = setInScope se env
1598 prepareCaseCont alt_env alts cont `thenSmpl` \ (floats1, dupable_cont) ->
1599 addFloats alt_env floats1 $ \ alt_env ->
1601 simplBinder alt_env case_bndr `thenSmpl` \ (alt_env, case_bndr') ->
1602 -- NB: simplBinder does not zap deadness occ-info, so
1603 -- a dead case_bndr' will still advertise its deadness
1604 -- This is really important because in
1605 -- case e of b { (# a,b #) -> ... }
1606 -- b is always dead, and indeed we are not allowed to bind b to (# a,b #),
1607 -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.
1608 -- In the new alts we build, we have the new case binder, so it must retain
1611 mkDupableAlts alt_env case_bndr' alts dupable_cont `thenSmpl` \ (floats2, alts') ->
1612 addFloats alt_env floats2 $ \ alt_env ->
1613 returnSmpl (emptyFloats alt_env, Select OkToDup case_bndr' alts' (zapSubstEnv se)
1614 (mkBoringStop (contResultType cont)))
1616 mkDupableAlts :: SimplEnv -> OutId -> [InAlt] -> SimplCont
1617 -> SimplM (FloatsWith [InAlt])
1618 -- Absorbs the continuation into the new alternatives
1620 mkDupableAlts env case_bndr' alts dupable_cont
1623 go env [] = returnSmpl (emptyFloats env, [])
1625 = mkDupableAlt env case_bndr' dupable_cont alt `thenSmpl` \ (floats1, alt') ->
1626 addFloats env floats1 $ \ env ->
1627 go env alts `thenSmpl` \ (floats2, alts') ->
1628 returnSmpl (floats2, alt' : alts')
1630 mkDupableAlt env case_bndr' cont alt@(con, bndrs, rhs)
1631 = simplBinders env bndrs `thenSmpl` \ (env, bndrs') ->
1632 simplExprC env rhs cont `thenSmpl` \ rhs' ->
1634 if exprIsDupable rhs' then
1635 returnSmpl (emptyFloats env, (con, bndrs', rhs'))
1636 -- It is worth checking for a small RHS because otherwise we
1637 -- get extra let bindings that may cause an extra iteration of the simplifier to
1638 -- inline back in place. Quite often the rhs is just a variable or constructor.
1639 -- The Ord instance of Maybe in PrelMaybe.lhs, for example, took several extra
1640 -- iterations because the version with the let bindings looked big, and so wasn't
1641 -- inlined, but after the join points had been inlined it looked smaller, and so
1644 -- NB: we have to check the size of rhs', not rhs.
1645 -- Duplicating a small InAlt might invalidate occurrence information
1646 -- However, if it *is* dupable, we return the *un* simplified alternative,
1647 -- because otherwise we'd need to pair it up with an empty subst-env....
1648 -- but we only have one env shared between all the alts.
1649 -- (Remember we must zap the subst-env before re-simplifying something).
1650 -- Rather than do this we simply agree to re-simplify the original (small) thing later.
1654 rhs_ty' = exprType rhs'
1655 used_bndrs' = filter (not . isDeadBinder) (case_bndr' : bndrs')
1656 -- The deadness info on the new binders is unscathed
1658 -- If we try to lift a primitive-typed something out
1659 -- for let-binding-purposes, we will *caseify* it (!),
1660 -- with potentially-disastrous strictness results. So
1661 -- instead we turn it into a function: \v -> e
1662 -- where v::State# RealWorld#. The value passed to this function
1663 -- is realworld#, which generates (almost) no code.
1665 -- There's a slight infelicity here: we pass the overall
1666 -- case_bndr to all the join points if it's used in *any* RHS,
1667 -- because we don't know its usage in each RHS separately
1669 -- We used to say "&& isUnLiftedType rhs_ty'" here, but now
1670 -- we make the join point into a function whenever used_bndrs'
1671 -- is empty. This makes the join-point more CPR friendly.
1672 -- Consider: let j = if .. then I# 3 else I# 4
1673 -- in case .. of { A -> j; B -> j; C -> ... }
1675 -- Now CPR doesn't w/w j because it's a thunk, so
1676 -- that means that the enclosing function can't w/w either,
1677 -- which is a lose. Here's the example that happened in practice:
1678 -- kgmod :: Int -> Int -> Int
1679 -- kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
1683 -- I have seen a case alternative like this:
1684 -- True -> \v -> ...
1685 -- It's a bit silly to add the realWorld dummy arg in this case, making
1688 -- (the \v alone is enough to make CPR happy) but I think it's rare
1690 ( if null used_bndrs'
1691 then newId SLIT("w") realWorldStatePrimTy `thenSmpl` \ rw_id ->
1692 returnSmpl ([rw_id], [Var realWorldPrimId])
1694 returnSmpl (used_bndrs', map varToCoreExpr used_bndrs')
1695 ) `thenSmpl` \ (final_bndrs', final_args) ->
1697 -- See comment about "$j" name above
1698 newId SLIT("$j") (foldr mkPiType rhs_ty' final_bndrs') `thenSmpl` \ join_bndr ->
1699 -- Notice the funky mkPiType. If the contructor has existentials
1700 -- it's possible that the join point will be abstracted over
1701 -- type varaibles as well as term variables.
1702 -- Example: Suppose we have
1703 -- data T = forall t. C [t]
1705 -- case (case e of ...) of
1706 -- C t xs::[t] -> rhs
1707 -- We get the join point
1708 -- let j :: forall t. [t] -> ...
1709 -- j = /\t \xs::[t] -> rhs
1711 -- case (case e of ...) of
1712 -- C t xs::[t] -> j t xs
1714 -- We make the lambdas into one-shot-lambdas. The
1715 -- join point is sure to be applied at most once, and doing so
1716 -- prevents the body of the join point being floated out by
1717 -- the full laziness pass
1718 really_final_bndrs = map one_shot final_bndrs'
1719 one_shot v | isId v = setOneShotLambda v
1721 join_rhs = mkLams really_final_bndrs rhs'
1722 join_call = mkApps (Var join_bndr) final_args
1724 returnSmpl (unitFloat env join_bndr join_rhs, (con, bndrs', join_call))