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, simplLamBinders, simplBinders, simplRecIds, simplLetId,
17 SimplCont(..), DupFlag(..), LetRhsFlag(..),
19 contResultType, discardInline, 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,
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 simplRecIds 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 simplLetId env bndr `thenSmpl` \ (env, bndr') ->
300 simplStrictArg env AnRhs rhs rhs_se cont_ty $ \ env rhs1 ->
302 -- Make the arguments atomic if necessary,
303 -- adding suitable bindings
304 mkAtomicArgs True True rhs1 `thenSmpl` \ (aux_binds, rhs2) ->
305 addAtomicBindsE env aux_binds $ \ env ->
307 -- Now complete the binding and simplify the body
308 completeNonRecX env bndr bndr' rhs2 thing_inside
310 | otherwise -- Normal, lazy case
311 = -- Don't use simplBinder because that doesn't keep
312 -- fragile occurrence in the substitution
313 simplLetId env bndr `thenSmpl` \ (env, bndr') ->
314 simplLazyBind env NotTopLevel NonRecursive
315 bndr bndr' rhs rhs_se `thenSmpl` \ (floats, env) ->
316 addFloats env floats thing_inside
319 A specialised variant of simplNonRec used when the RHS is already simplified, notably
320 in knownCon. It uses case-binding where necessary.
323 simplNonRecX :: SimplEnv
324 -> InId -- Old binder
325 -> OutExpr -- Simplified RHS
326 -> (SimplEnv -> SimplM FloatsWithExpr)
327 -> SimplM FloatsWithExpr
329 simplNonRecX env bndr new_rhs thing_inside
330 | preInlineUnconditionally env NotTopLevel bndr
331 -- This happens; for example, the case_bndr during case of
332 -- known constructor: case (a,b) of x { (p,q) -> ... }
333 -- Here x isn't mentioned in the RHS, so we don't want to
334 -- create the (dead) let-binding let x = (a,b) in ...
336 -- Similarly, single occurrences can be inlined vigourously
337 -- e.g. case (f x, g y) of (a,b) -> ....
338 -- If a,b occur once we can avoid constructing the let binding for them.
339 = thing_inside (extendSubst env bndr (ContEx emptySubstEnv new_rhs))
342 = simplBinder env bndr `thenSmpl` \ (env, bndr') ->
343 completeNonRecX env bndr bndr' new_rhs thing_inside
345 completeNonRecX env old_bndr new_bndr new_rhs thing_inside
346 | needsCaseBinding (idType new_bndr) new_rhs
347 = thing_inside env `thenSmpl` \ (floats, body) ->
348 returnSmpl (emptyFloats env, Case new_rhs new_bndr [(DEFAULT, [], wrapFloats floats body)])
351 = completeLazyBind env NotTopLevel
352 old_bndr new_bndr new_rhs `thenSmpl` \ (floats, env) ->
353 addFloats env floats thing_inside
357 %************************************************************************
359 \subsection{Lazy bindings}
361 %************************************************************************
363 simplRecBind is used for
364 * recursive bindings only
367 simplRecBind :: SimplEnv -> TopLevelFlag
368 -> [(InId, InExpr)] -> [OutId]
369 -> SimplM (FloatsWith SimplEnv)
370 simplRecBind env top_lvl pairs bndrs'
371 = go env pairs bndrs' `thenSmpl` \ (floats, env) ->
372 returnSmpl (flattenFloats floats, env)
374 go env [] _ = returnSmpl (emptyFloats env, env)
376 go env ((bndr, rhs) : pairs) (bndr' : bndrs')
377 = simplRecOrTopPair env top_lvl bndr bndr' rhs `thenSmpl` \ (floats, env) ->
378 addFloats env floats (\env -> go env pairs bndrs')
382 simplRecOrTopPair is used for
383 * recursive bindings (whether top level or not)
384 * top-level non-recursive bindings
386 It assumes the binder has already been simplified, but not its IdInfo.
389 simplRecOrTopPair :: SimplEnv
391 -> InId -> OutId -- Binder, both pre-and post simpl
392 -> InExpr -- The RHS and its environment
393 -> SimplM (FloatsWith SimplEnv)
395 simplRecOrTopPair env top_lvl bndr bndr' rhs
396 | preInlineUnconditionally env top_lvl bndr -- Check for unconditional inline
397 = tick (PreInlineUnconditionally bndr) `thenSmpl_`
398 returnSmpl (emptyFloats env, extendSubst env bndr (ContEx (getSubstEnv env) rhs))
401 = simplLazyBind env top_lvl Recursive bndr bndr' rhs env
402 -- May not actually be recursive, but it doesn't matter
406 simplLazyBind is used for
407 * recursive bindings (whether top level or not)
408 * top-level non-recursive bindings
409 * non-top-level *lazy* non-recursive bindings
411 [Thus it deals with the lazy cases from simplNonRecBind, and all cases
412 from SimplRecOrTopBind]
415 1. It assumes that the binder is *already* simplified,
416 and is in scope, but not its IdInfo
418 2. It assumes that the binder type is lifted.
420 3. It does not check for pre-inline-unconditionallly;
421 that should have been done already.
424 simplLazyBind :: SimplEnv
425 -> TopLevelFlag -> RecFlag
426 -> InId -> OutId -- Binder, both pre-and post simpl
427 -> InExpr -> SimplEnv -- The RHS and its environment
428 -> SimplM (FloatsWith SimplEnv)
430 simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se
431 = -- Substitute IdInfo on binder, in the light of earlier
432 -- substitutions in this very letrec, and extend the
433 -- in-scope env, so that the IdInfo for this binder extends
434 -- over the RHS for the binder itself.
436 -- This is important. Manuel found cases where he really, really
437 -- wanted a RULE for a recursive function to apply in that function's
438 -- own right-hand side.
440 -- NB: does no harm for non-recursive bindings
442 bndr_ty' = idType bndr'
443 bndr'' = simplIdInfo (getSubst rhs_se) (idInfo bndr) bndr'
444 env1 = modifyInScope env bndr'' bndr''
445 rhs_env = setInScope rhs_se env1
446 ok_float_unlifted = isNotTopLevel top_lvl && isNonRec is_rec
447 rhs_cont = mkStop bndr_ty' AnRhs
449 -- Simplify the RHS; note the mkStop, which tells
450 -- the simplifier that this is the RHS of a let.
451 simplExprF rhs_env rhs rhs_cont `thenSmpl` \ (floats, rhs1) ->
453 -- If any of the floats can't be floated, give up now
454 -- (The allLifted predicate says True for empty floats.)
455 if (not ok_float_unlifted && not (allLifted floats)) then
456 completeLazyBind env1 top_lvl bndr bndr''
457 (wrapFloats floats rhs1)
460 -- ANF-ise a constructor or PAP rhs
461 mkAtomicArgs False {- Not strict -}
462 ok_float_unlifted rhs1 `thenSmpl` \ (aux_binds, rhs2) ->
464 -- If the result is a PAP, float the floats out, else wrap them
465 -- By this time it's already been ANF-ised (if necessary)
466 if isEmptyFloats floats && null aux_binds then -- Shortcut a common case
467 completeLazyBind env1 top_lvl bndr bndr'' rhs2
469 -- We use exprIsTrivial here because we want to reveal lone variables.
470 -- E.g. let { x = letrec { y = E } in y } in ...
471 -- Here we definitely want to float the y=E defn.
472 -- exprIsValue definitely isn't right for that.
474 -- BUT we can't use "exprIsCheap", because that causes a strictness bug.
475 -- x = let y* = E in case (scc y) of { T -> F; F -> T}
476 -- The case expression is 'cheap', but it's wrong to transform to
477 -- y* = E; x = case (scc y) of {...}
478 -- Either we must be careful not to float demanded non-values, or
479 -- we must use exprIsValue for the test, which ensures that the
480 -- thing is non-strict. I think. The WARN below tests for this
481 else if exprIsTrivial rhs2 || exprIsValue rhs2 then
482 -- There's a subtlety here. There may be a binding (x* = e) in the
483 -- floats, where the '*' means 'will be demanded'. So is it safe
484 -- to float it out? Answer no, but it won't matter because
485 -- we only float if arg' is a WHNF,
486 -- and so there can't be any 'will be demanded' bindings in the floats.
488 WARN( any demanded_float (floatBinds floats),
489 ppr (filter demanded_float (floatBinds floats)) )
491 tick LetFloatFromLet `thenSmpl_` (
492 addFloats env1 floats $ \ env2 ->
493 addAtomicBinds env2 aux_binds $ \ env3 ->
494 completeLazyBind env3 top_lvl bndr bndr'' rhs2)
497 completeLazyBind env1 top_lvl bndr bndr'' (wrapFloats floats rhs1)
500 demanded_float (NonRec b r) = isStrictDmd (idNewDemandInfo b) && not (isUnLiftedType (idType b))
501 -- Unlifted-type (cheap-eagerness) lets may well have a demanded flag on them
502 demanded_float (Rec _) = False
507 %************************************************************************
509 \subsection{Completing a lazy binding}
511 %************************************************************************
514 * deals only with Ids, not TyVars
515 * takes an already-simplified binder and RHS
516 * is used for both recursive and non-recursive bindings
517 * is used for both top-level and non-top-level bindings
519 It does the following:
520 - tries discarding a dead binding
521 - tries PostInlineUnconditionally
522 - add unfolding [this is the only place we add an unfolding]
525 It does *not* attempt to do let-to-case. Why? Because it is used for
526 - top-level bindings (when let-to-case is impossible)
527 - many situations where the "rhs" is known to be a WHNF
528 (so let-to-case is inappropriate).
531 completeLazyBind :: SimplEnv
532 -> TopLevelFlag -- Flag stuck into unfolding
533 -> InId -- Old binder
534 -> OutId -- New binder
535 -> OutExpr -- Simplified RHS
536 -> SimplM (FloatsWith SimplEnv)
537 -- We return a new SimplEnv, because completeLazyBind may choose to do its work
538 -- by extending the substitution (e.g. let x = y in ...)
539 -- The new binding (if any) is returned as part of the floats.
540 -- NB: the returned SimplEnv has the right SubstEnv, but you should
541 -- (as usual) use the in-scope-env from the floats
543 completeLazyBind env top_lvl old_bndr new_bndr new_rhs
544 | postInlineUnconditionally env new_bndr loop_breaker new_rhs
545 = -- Drop the binding
546 tick (PostInlineUnconditionally old_bndr) `thenSmpl_`
547 returnSmpl (emptyFloats env, extendSubst env old_bndr (DoneEx new_rhs))
548 -- Use the substitution to make quite, quite sure that the substitution
549 -- will happen, since we are going to discard the binding
554 new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs
556 -- Add the unfolding *only* for non-loop-breakers
557 -- Making loop breakers not have an unfolding at all
558 -- means that we can avoid tests in exprIsConApp, for example.
559 -- This is important: if exprIsConApp says 'yes' for a recursive
560 -- thing, then we can get into an infinite loop
561 info_w_unf | loop_breaker = new_bndr_info
562 | otherwise = new_bndr_info `setUnfoldingInfo` unfolding
563 unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs
565 final_id = new_bndr `setIdInfo` info_w_unf
567 -- These seqs forces the Id, and hence its IdInfo,
568 -- and hence any inner substitutions
570 returnSmpl (unitFloat env final_id new_rhs, env)
573 loop_breaker = isLoopBreaker occ_info
574 old_info = idInfo old_bndr
575 occ_info = occInfo old_info
580 %************************************************************************
582 \subsection[Simplify-simplExpr]{The main function: simplExpr}
584 %************************************************************************
586 The reason for this OutExprStuff stuff is that we want to float *after*
587 simplifying a RHS, not before. If we do so naively we get quadratic
588 behaviour as things float out.
590 To see why it's important to do it after, consider this (real) example:
604 a -- Can't inline a this round, cos it appears twice
608 Each of the ==> steps is a round of simplification. We'd save a
609 whole round if we float first. This can cascade. Consider
614 let f = let d1 = ..d.. in \y -> e
618 in \x -> ...(\y ->e)...
620 Only in this second round can the \y be applied, and it
621 might do the same again.
625 simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
626 simplExpr env expr = simplExprC env expr (mkBoringStop expr_ty')
628 expr_ty' = substTy (getSubst env) (exprType expr)
629 -- The type in the Stop continuation, expr_ty', is usually not used
630 -- It's only needed when discarding continuations after finding
631 -- a function that returns bottom.
632 -- Hence the lazy substitution
635 simplExprC :: SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr
636 -- Simplify an expression, given a continuation
637 simplExprC env expr cont
638 = simplExprF env expr cont `thenSmpl` \ (floats, expr) ->
639 returnSmpl (wrapFloats floats expr)
641 simplExprF :: SimplEnv -> InExpr -> SimplCont -> SimplM FloatsWithExpr
642 -- Simplify an expression, returning floated binds
644 simplExprF env (Var v) cont = simplVar env v cont
645 simplExprF env (Lit lit) cont = rebuild env (Lit lit) cont
646 simplExprF env expr@(Lam _ _) cont = simplLam env expr cont
647 simplExprF env (Note note expr) cont = simplNote env note expr cont
648 simplExprF env (App fun arg) cont = simplExprF env fun (ApplyTo NoDup arg env cont)
650 simplExprF env (Type ty) cont
651 = ASSERT( contIsRhsOrArg cont )
652 simplType env ty `thenSmpl` \ ty' ->
653 rebuild env (Type ty') cont
655 simplExprF env (Case scrut bndr alts) cont
656 | not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
657 = -- Simplify the scrutinee with a Select continuation
658 simplExprF env scrut (Select NoDup bndr alts env cont)
661 = -- If case-of-case is off, simply simplify the case expression
662 -- in a vanilla Stop context, and rebuild the result around it
663 simplExprC env scrut case_cont `thenSmpl` \ case_expr' ->
664 rebuild env case_expr' cont
666 case_cont = Select NoDup bndr alts env (mkBoringStop (contResultType cont))
668 simplExprF env (Let (Rec pairs) body) cont
669 = simplRecIds env (map fst pairs) `thenSmpl` \ (env, bndrs') ->
670 -- NB: bndrs' don't have unfoldings or spec-envs
671 -- We add them as we go down, using simplPrags
673 simplRecBind env NotTopLevel pairs bndrs' `thenSmpl` \ (floats, env) ->
674 addFloats env floats $ \ env ->
675 simplExprF env body cont
677 -- A non-recursive let is dealt with by simplNonRecBind
678 simplExprF env (Let (NonRec bndr rhs) body) cont
679 = simplNonRecBind env bndr rhs env (contResultType cont) $ \ env ->
680 simplExprF env body cont
683 ---------------------------------
684 simplType :: SimplEnv -> InType -> SimplM OutType
685 -- Kept monadic just so we can do the seqType
687 = seqType new_ty `seq` returnSmpl new_ty
689 new_ty = substTy (getSubst env) ty
693 %************************************************************************
697 %************************************************************************
700 simplLam env fun cont
703 zap_it = mkLamBndrZapper fun cont
704 cont_ty = contResultType cont
706 -- Type-beta reduction
707 go env (Lam bndr body) (ApplyTo _ (Type ty_arg) arg_se body_cont)
708 = ASSERT( isTyVar bndr )
709 tick (BetaReduction bndr) `thenSmpl_`
710 simplType (setInScope arg_se env) ty_arg `thenSmpl` \ ty_arg' ->
711 go (extendSubst env bndr (DoneTy ty_arg')) body body_cont
713 -- Ordinary beta reduction
714 go env (Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont)
715 = tick (BetaReduction bndr) `thenSmpl_`
716 simplNonRecBind env zapped_bndr arg arg_se cont_ty $ \ env ->
717 go env body body_cont
719 zapped_bndr = zap_it bndr
721 -- Not enough args, so there are real lambdas left to put in the result
722 go env lam@(Lam _ _) cont
723 = simplLamBinders env bndrs `thenSmpl` \ (env, bndrs') ->
724 simplExpr env body `thenSmpl` \ body' ->
725 mkLam env bndrs' body' cont `thenSmpl` \ (floats, new_lam) ->
726 addFloats env floats $ \ env ->
727 rebuild env new_lam cont
729 (bndrs,body) = collectBinders lam
731 -- Exactly enough args
732 go env expr cont = simplExprF env expr cont
734 mkLamBndrZapper :: CoreExpr -- Function
735 -> SimplCont -- The context
736 -> Id -> Id -- Use this to zap the binders
737 mkLamBndrZapper fun cont
738 | n_args >= n_params fun = \b -> b -- Enough args
739 | otherwise = \b -> zapLamIdInfo b
741 -- NB: we count all the args incl type args
742 -- so we must count all the binders (incl type lambdas)
743 n_args = countArgs cont
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
851 completeCall env var occ_info cont
852 = getDOptsSmpl `thenSmpl` \ dflags ->
854 in_scope = getInScope env
855 chkr = getSwitchChecker env
857 (args, call_cont, inline_call) = getContArgs chkr var cont
859 arg_infos = [ interestingArg in_scope arg (getSubstEnv arg_env)
860 | (arg, arg_env, _) <- args, isValArg arg]
862 interesting_cont = interestingCallContext (not (null args))
863 (not (null arg_infos))
866 inline_cont | inline_call = discardInline cont
869 active_inline = activeInline env var
870 maybe_inline = callSiteInline dflags active_inline inline_call occ_info
871 var arg_infos interesting_cont
873 -- First, look for an inlining
874 case maybe_inline of {
875 Just unfolding -- There is an inlining!
876 -> tick (UnfoldingDone var) `thenSmpl_`
877 simplExprF env unfolding inline_cont
880 Nothing -> -- No inlining!
883 simplifyArgs env args (contResultType call_cont) $ \ env args' ->
885 -- Next, look for rules or specialisations that match
887 -- It's important to simplify the args first, because the rule-matcher
888 -- doesn't do substitution as it goes. We don't want to use subst_args
889 -- (defined in the 'where') because that throws away useful occurrence info,
890 -- and perhaps-very-important specialisations.
892 -- Some functions have specialisations *and* are strict; in this case,
893 -- we don't want to inline the wrapper of the non-specialised thing; better
894 -- to call the specialised thing instead.
895 -- But the black-listing mechanism means that inlining of the wrapper
896 -- won't occur for things that have specialisations till a later phase, so
897 -- it's ok to try for inlining first.
899 -- You might think that we shouldn't apply rules for a loop breaker:
900 -- doing so might give rise to an infinite loop, because a RULE is
901 -- rather like an extra equation for the function:
902 -- RULE: f (g x) y = x+y
905 -- But it's too drastic to disable rules for loop breakers.
906 -- Even the foldr/build rule would be disabled, because foldr
907 -- is recursive, and hence a loop breaker:
908 -- foldr k z (build g) = g k z
909 -- So it's up to the programmer: rules can cause divergence
912 maybe_rule = case activeRule env of
913 Nothing -> Nothing -- No rules apply
914 Just act_fn -> lookupRule act_fn in_scope var args'
917 Just (rule_name, rule_rhs) ->
918 tick (RuleFired rule_name) `thenSmpl_`
919 (if dopt Opt_D_dump_inlinings dflags then
920 pprTrace "Rule fired" (vcat [
921 text "Rule:" <+> ptext rule_name,
922 text "Before:" <+> ppr var <+> sep (map pprParendExpr args'),
923 text "After: " <+> pprCoreExpr rule_rhs])
926 simplExprF env rule_rhs call_cont ;
928 Nothing -> -- No rules
931 rebuild env (mkApps (Var var) args') call_cont
936 %************************************************************************
938 \subsection{Arguments}
940 %************************************************************************
943 ---------------------------------------------------------
944 -- Simplifying the arguments of a call
946 simplifyArgs :: SimplEnv
947 -> [(InExpr, SimplEnv, Bool)] -- Details of the arguments
948 -> OutType -- Type of the continuation
949 -> (SimplEnv -> [OutExpr] -> SimplM FloatsWithExpr)
950 -> SimplM FloatsWithExpr
952 -- [CPS-like because of strict arguments]
954 -- Simplify the arguments to a call.
955 -- This part of the simplifier may break the no-shadowing invariant
957 -- f (...(\a -> e)...) (case y of (a,b) -> e')
958 -- where f is strict in its second arg
959 -- If we simplify the innermost one first we get (...(\a -> e)...)
960 -- Simplifying the second arg makes us float the case out, so we end up with
961 -- case y of (a,b) -> f (...(\a -> e)...) e'
962 -- So the output does not have the no-shadowing invariant. However, there is
963 -- no danger of getting name-capture, because when the first arg was simplified
964 -- we used an in-scope set that at least mentioned all the variables free in its
965 -- static environment, and that is enough.
967 -- We can't just do innermost first, or we'd end up with a dual problem:
968 -- case x of (a,b) -> f e (...(\a -> e')...)
970 -- I spent hours trying to recover the no-shadowing invariant, but I just could
971 -- not think of an elegant way to do it. The simplifier is already knee-deep in
972 -- continuations. We have to keep the right in-scope set around; AND we have
973 -- to get the effect that finding (error "foo") in a strict arg position will
974 -- discard the entire application and replace it with (error "foo"). Getting
975 -- all this at once is TOO HARD!
977 simplifyArgs env args cont_ty thing_inside
978 = go env args thing_inside
980 go env [] thing_inside = thing_inside env []
981 go env (arg:args) thing_inside = simplifyArg env arg cont_ty $ \ env arg' ->
982 go env args $ \ env args' ->
983 thing_inside env (arg':args')
985 simplifyArg env (Type ty_arg, se, _) cont_ty thing_inside
986 = simplType (setInScope se env) ty_arg `thenSmpl` \ new_ty_arg ->
987 thing_inside env (Type new_ty_arg)
989 simplifyArg env (val_arg, arg_se, is_strict) cont_ty thing_inside
991 = simplStrictArg env AnArg val_arg arg_se cont_ty thing_inside
995 arg_env = setInScope arg_se env
997 simplType arg_env (exprType val_arg) `thenSmpl` \ arg_ty ->
998 simplExprF arg_env val_arg (mkStop arg_ty AnArg) `thenSmpl` \ (floats, arg1) ->
999 addFloats env floats $ \ env ->
1000 thing_inside env arg1
1003 simplStrictArg :: SimplEnv -- The env of the call
1005 -> InExpr -> SimplEnv -- The arg plus its env
1006 -> OutType -- cont_ty: Type of thing computed by the context
1007 -> (SimplEnv -> OutExpr -> SimplM FloatsWithExpr)
1008 -- Takes an expression of type rhs_ty,
1009 -- returns an expression of type cont_ty
1010 -- The env passed to this continuation is the
1011 -- env of the call, plus any new in-scope variables
1012 -> SimplM FloatsWithExpr -- An expression of type cont_ty
1014 simplStrictArg call_env is_rhs arg arg_env cont_ty thing_inside
1015 = simplExprF (setInScope arg_env call_env) arg
1016 (ArgOf NoDup is_rhs cont_ty (\ new_env -> thing_inside (setInScope call_env new_env)))
1017 -- Notice the way we use arg_env (augmented with in-scope vars from call_env)
1018 -- to simplify the argument
1019 -- and call-env (augmented with in-scope vars from the arg) to pass to the continuation
1023 %************************************************************************
1025 \subsection{mkAtomicArgs}
1027 %************************************************************************
1029 mkAtomicArgs takes a putative RHS, checks whether it's a PAP or
1030 constructor application and, if so, converts it to ANF, so that the
1031 resulting thing can be inlined more easily. Thus
1038 There are three sorts of binding context, specified by the two
1044 N N Top-level or recursive Only bind args of lifted type
1046 N Y Non-top-level and non-recursive, Bind args of lifted type, or
1047 but lazy unlifted-and-ok-for-speculation
1049 Y Y Non-top-level, non-recursive, Bind all args
1050 and strict (demanded)
1057 there is no point in transforming to
1059 x = case (y div# z) of r -> MkC r
1061 because the (y div# z) can't float out of the let. But if it was
1062 a *strict* let, then it would be a good thing to do. Hence the
1063 context information.
1066 mkAtomicArgs :: Bool -- A strict binding
1067 -> Bool -- OK to float unlifted args
1069 -> SimplM ([(OutId,OutExpr)], -- The floats (unusually) may include
1070 OutExpr) -- things that need case-binding,
1071 -- if the strict-binding flag is on
1073 mkAtomicArgs is_strict ok_float_unlifted rhs
1074 = mk_atomic_args rhs `thenSmpl` \ maybe_stuff ->
1076 Nothing -> returnSmpl ([], rhs)
1077 Just (ol_binds, rhs') -> returnSmpl (fromOL ol_binds, rhs')
1080 mk_atomic_args :: OutExpr -> SimplM (Maybe (OrdList (Id,OutExpr), OutExpr))
1081 -- Nothing => no change
1083 | (Var fun, args) <- collectArgs rhs, -- It's an application
1084 isDataConId fun || valArgCount args < idArity fun -- And it's a constructor or PAP
1086 go nilOL [] args `thenSmpl` \ maybe_stuff ->
1088 Nothing -> returnSmpl Nothing
1089 Just (aux_binds, args') -> returnSmpl (Just (aux_binds, mkApps (Var fun) args'))
1092 = returnSmpl Nothing
1094 go binds rev_args []
1095 = returnSmpl (Just (binds, reverse rev_args))
1096 go binds rev_args (arg : args)
1097 | exprIsTrivial arg -- Easy case
1098 = go binds (arg:rev_args) args
1100 | not can_float_arg -- Can't make this arg atomic
1101 = returnSmpl Nothing -- ... so give up
1103 | otherwise -- Don't forget to do it recursively
1104 -- E.g. x = a:b:c:[]
1105 = mk_atomic_args arg `thenSmpl` \ maybe_anf ->
1107 Nothing -> returnSmpl Nothing ;
1108 Just (arg_binds,arg') ->
1110 newId SLIT("a") arg_ty `thenSmpl` \ arg_id ->
1111 go ((arg_binds `snocOL` (arg_id,arg')) `appOL` binds)
1112 (Var arg_id : rev_args) args
1115 arg_ty = exprType arg
1116 can_float_arg = is_strict
1117 || not (isUnLiftedType arg_ty)
1118 || (ok_float_unlifted && exprOkForSpeculation arg)
1120 addAtomicBinds :: SimplEnv -> [(OutId,OutExpr)]
1121 -> (SimplEnv -> SimplM (FloatsWith a))
1122 -> SimplM (FloatsWith a)
1123 addAtomicBinds env [] thing_inside = thing_inside env
1124 addAtomicBinds env ((v,r):bs) thing_inside = addAuxiliaryBind env (NonRec v r) $ \ env ->
1125 addAtomicBinds env bs thing_inside
1127 addAtomicBindsE :: SimplEnv -> [(OutId,OutExpr)]
1128 -> (SimplEnv -> SimplM FloatsWithExpr)
1129 -> SimplM FloatsWithExpr
1130 -- Same again, but this time we're in an expression context,
1131 -- and may need to do some case bindings
1133 addAtomicBindsE env [] thing_inside
1135 addAtomicBindsE env ((v,r):bs) thing_inside
1136 | needsCaseBinding (idType v) r
1137 = addAtomicBindsE (addNewInScopeIds env [v]) bs thing_inside `thenSmpl` \ (floats, expr) ->
1138 WARN( exprIsTrivial expr, ppr v <+> pprCoreExpr expr )
1139 returnSmpl (emptyFloats env, Case r v [(DEFAULT,[], wrapFloats floats expr)])
1142 = addAuxiliaryBind env (NonRec v r) $ \ env ->
1143 addAtomicBindsE env bs thing_inside
1147 %************************************************************************
1149 \subsection{The main rebuilder}
1151 %************************************************************************
1154 rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM FloatsWithExpr
1156 rebuild env expr (Stop _ _ _) = rebuildDone env expr
1157 rebuild env expr (ArgOf _ _ _ cont_fn) = cont_fn env expr
1158 rebuild env expr (CoerceIt to_ty cont) = rebuild env (mkCoerce to_ty (exprType expr) expr) cont
1159 rebuild env expr (InlinePlease cont) = rebuild env (Note InlineCall expr) cont
1160 rebuild env expr (Select _ bndr alts se cont) = rebuildCase (setInScope se env) expr bndr alts cont
1161 rebuild env expr (ApplyTo _ arg se cont) = rebuildApp (setInScope se env) expr arg cont
1163 rebuildApp env fun arg cont
1164 = simplExpr env arg `thenSmpl` \ arg' ->
1165 rebuild env (App fun arg') cont
1167 rebuildDone env expr = returnSmpl (emptyFloats env, expr)
1171 %************************************************************************
1173 \subsection{Functions dealing with a case}
1175 %************************************************************************
1177 Blob of helper functions for the "case-of-something-else" situation.
1180 ---------------------------------------------------------
1181 -- Eliminate the case if possible
1183 rebuildCase :: SimplEnv
1184 -> OutExpr -- Scrutinee
1185 -> InId -- Case binder
1186 -> [InAlt] -- Alternatives
1188 -> SimplM FloatsWithExpr
1190 rebuildCase env scrut case_bndr alts cont
1191 | Just (con,args) <- exprIsConApp_maybe scrut
1192 -- Works when the scrutinee is a variable with a known unfolding
1193 -- as well as when it's an explicit constructor application
1194 = knownCon env (DataAlt con) args case_bndr alts cont
1196 | Lit lit <- scrut -- No need for same treatment as constructors
1197 -- because literals are inlined more vigorously
1198 = knownCon env (LitAlt lit) [] case_bndr alts cont
1201 = -- Prepare case alternatives
1202 -- Filter out alternatives that can't possibly match
1204 impossible_cons = case scrut of
1205 Var v -> otherCons (idUnfolding v)
1207 better_alts = case impossible_cons of
1209 other -> [alt | alt@(con,_,_) <- alts,
1210 not (con `elem` impossible_cons)]
1213 -- Deal with the case binder, and prepare the continuation;
1214 -- The new subst_env is in place
1215 prepareCaseCont env better_alts cont `thenSmpl` \ (floats, cont') ->
1216 addFloats env floats $ \ env ->
1218 -- Deal with variable scrutinee
1219 simplCaseBinder env scrut case_bndr `thenSmpl` \ (alt_env, case_bndr', zap_occ_info) ->
1221 -- Deal with the case alternatives
1222 simplAlts alt_env zap_occ_info impossible_cons
1223 case_bndr' better_alts cont' `thenSmpl` \ alts' ->
1225 -- Put the case back together
1226 mkCase scrut case_bndr' alts' `thenSmpl` \ case_expr ->
1228 -- Notice that rebuildDone returns the in-scope set from env, not alt_env
1229 -- The case binder *not* scope over the whole returned case-expression
1230 rebuildDone env case_expr
1233 simplCaseBinder checks whether the scrutinee is a variable, v. If so,
1234 try to eliminate uses of v in the RHSs in favour of case_bndr; that
1235 way, there's a chance that v will now only be used once, and hence
1240 There is a time we *don't* want to do that, namely when
1241 -fno-case-of-case is on. This happens in the first simplifier pass,
1242 and enhances full laziness. Here's the bad case:
1243 f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )
1244 If we eliminate the inner case, we trap it inside the I# v -> arm,
1245 which might prevent some full laziness happening. I've seen this
1246 in action in spectral/cichelli/Prog.hs:
1247 [(m,n) | m <- [1..max], n <- [1..max]]
1248 Hence the check for NoCaseOfCase.
1252 There is another situation when we don't want to do it. If we have
1254 case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }
1255 ...other cases .... }
1257 We'll perform the binder-swap for the outer case, giving
1259 case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }
1260 ...other cases .... }
1262 But there is no point in doing it for the inner case,
1263 because w1 can't be inlined anyway. Furthermore, doing the case-swapping
1264 involves zapping w2's occurrence info (see paragraphs that follow),
1265 and that forces us to bind w2 when doing case merging. So we get
1267 case x of w1 { A -> let w2 = w1 in e1
1268 B -> let w2 = w1 in e2
1269 ...other cases .... }
1271 This is plain silly in the common case where w2 is dead.
1273 Even so, I can't see a good way to implement this idea. I tried
1274 not doing the binder-swap if the scrutinee was already evaluated
1275 but that failed big-time:
1279 case v of w { MkT x ->
1280 case x of x1 { I# y1 ->
1281 case x of x2 { I# y2 -> ...
1283 Notice that because MkT is strict, x is marked "evaluated". But to
1284 eliminate the last case, we must either make sure that x (as well as
1285 x1) has unfolding MkT y1. THe straightforward thing to do is to do
1286 the binder-swap. So this whole note is a no-op.
1290 If we replace the scrutinee, v, by tbe case binder, then we have to nuke
1291 any occurrence info (eg IAmDead) in the case binder, because the
1292 case-binder now effectively occurs whenever v does. AND we have to do
1293 the same for the pattern-bound variables! Example:
1295 (case x of { (a,b) -> a }) (case x of { (p,q) -> q })
1297 Here, b and p are dead. But when we move the argment inside the first
1298 case RHS, and eliminate the second case, we get
1300 case x or { (a,b) -> a b }
1302 Urk! b is alive! Reason: the scrutinee was a variable, and case elimination
1303 happened. Hence the zap_occ_info function returned by simplCaseBinder
1306 simplCaseBinder env (Var v) case_bndr
1307 | not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
1309 -- Failed try [see Note 2 above]
1310 -- not (isEvaldUnfolding (idUnfolding v))
1312 = simplBinder env (zap case_bndr) `thenSmpl` \ (env, case_bndr') ->
1313 returnSmpl (modifyInScope env v case_bndr', case_bndr', zap)
1314 -- We could extend the substitution instead, but it would be
1315 -- a hack because then the substitution wouldn't be idempotent
1316 -- any more (v is an OutId). And this just just as well.
1318 zap b = b `setIdOccInfo` NoOccInfo
1320 simplCaseBinder env other_scrut case_bndr
1321 = simplBinder env case_bndr `thenSmpl` \ (env, case_bndr') ->
1322 returnSmpl (env, case_bndr', \ bndr -> bndr) -- NoOp on bndr
1328 simplAlts :: SimplEnv
1329 -> (InId -> InId) -- Occ-info zapper
1330 -> [AltCon] -- Alternatives the scrutinee can't be
1331 -> OutId -- Case binder
1332 -> [InAlt] -> SimplCont
1333 -> SimplM [OutAlt] -- Includes the continuation
1335 simplAlts env zap_occ_info impossible_cons case_bndr' alts cont'
1336 = mapSmpl simpl_alt alts
1338 inst_tys' = tyConAppArgs (idType case_bndr')
1340 -- handled_cons is all the constructors that are dealt
1341 -- with, either by being impossible, or by there being an alternative
1342 (con_alts,_) = findDefault alts
1343 handled_cons = impossible_cons ++ [con | (con,_,_) <- con_alts]
1345 simpl_alt (DEFAULT, _, rhs)
1347 -- In the default case we record the constructors that the
1348 -- case-binder *can't* be.
1349 -- We take advantage of any OtherCon info in the case scrutinee
1350 case_bndr_w_unf = case_bndr' `setIdUnfolding` mkOtherCon handled_cons
1351 env_with_unf = modifyInScope env case_bndr' case_bndr_w_unf
1353 simplExprC env_with_unf rhs cont' `thenSmpl` \ rhs' ->
1354 returnSmpl (DEFAULT, [], rhs')
1356 simpl_alt (con, vs, rhs)
1357 = -- Deal with the pattern-bound variables
1358 -- Mark the ones that are in ! positions in the data constructor
1359 -- as certainly-evaluated.
1360 -- NB: it happens that simplBinders does *not* erase the OtherCon
1361 -- form of unfolding, so it's ok to add this info before
1362 -- doing simplBinders
1363 simplBinders env (add_evals con vs) `thenSmpl` \ (env, vs') ->
1365 -- Bind the case-binder to (con args)
1367 unfolding = mkUnfolding False (mkAltExpr con vs' inst_tys')
1368 env_with_unf = modifyInScope env case_bndr' (case_bndr' `setIdUnfolding` unfolding)
1370 simplExprC env_with_unf rhs cont' `thenSmpl` \ rhs' ->
1371 returnSmpl (con, vs', rhs')
1374 -- add_evals records the evaluated-ness of the bound variables of
1375 -- a case pattern. This is *important*. Consider
1376 -- data T = T !Int !Int
1378 -- case x of { T a b -> T (a+1) b }
1380 -- We really must record that b is already evaluated so that we don't
1381 -- go and re-evaluate it when constructing the result.
1383 add_evals (DataAlt dc) vs = cat_evals vs (dataConRepStrictness dc)
1384 add_evals other_con vs = vs
1386 cat_evals [] [] = []
1387 cat_evals (v:vs) (str:strs)
1388 | isTyVar v = v : cat_evals vs (str:strs)
1389 | isMarkedStrict str = evald_v : cat_evals vs strs
1390 | otherwise = zapped_v : cat_evals vs strs
1392 zapped_v = zap_occ_info v
1393 evald_v = zapped_v `setIdUnfolding` mkOtherCon []
1397 %************************************************************************
1399 \subsection{Known constructor}
1401 %************************************************************************
1403 We are a bit careful with occurrence info. Here's an example
1405 (\x* -> case x of (a*, b) -> f a) (h v, e)
1407 where the * means "occurs once". This effectively becomes
1408 case (h v, e) of (a*, b) -> f a)
1410 let a* = h v; b = e in f a
1414 All this should happen in one sweep.
1417 knownCon :: SimplEnv -> AltCon -> [OutExpr]
1418 -> InId -> [InAlt] -> SimplCont
1419 -> SimplM FloatsWithExpr
1421 knownCon env con args bndr alts cont
1422 = tick (KnownBranch bndr) `thenSmpl_`
1423 case findAlt con alts of
1424 (DEFAULT, bs, rhs) -> ASSERT( null bs )
1425 simplNonRecX env bndr scrut $ \ env ->
1426 -- This might give rise to a binding with non-atomic args
1427 -- like x = Node (f x) (g x)
1428 -- but no harm will be done
1429 simplExprF env rhs cont
1432 LitAlt lit -> Lit lit
1433 DataAlt dc -> mkConApp dc args
1435 (LitAlt lit, bs, rhs) -> ASSERT( null bs )
1436 simplNonRecX env bndr (Lit lit) $ \ env ->
1437 simplExprF env rhs cont
1439 (DataAlt dc, bs, rhs) -> ASSERT( length bs + n_tys == length args )
1440 bind_args env bs (drop n_tys args) $ \ env ->
1442 con_app = mkConApp dc (take n_tys args ++ con_args)
1443 con_args = [substExpr (getSubst env) (varToCoreExpr b) | b <- bs]
1444 -- args are aready OutExprs, but bs are InIds
1446 simplNonRecX env bndr con_app $ \ env ->
1447 simplExprF env rhs cont
1449 n_tys = dataConNumInstArgs dc -- Non-existential type args
1451 bind_args env [] _ thing_inside = thing_inside env
1453 bind_args env (b:bs) (Type ty : args) thing_inside
1454 = bind_args (extendSubst env b (DoneTy ty)) bs args thing_inside
1456 bind_args env (b:bs) (arg : args) thing_inside
1457 = simplNonRecX env b arg $ \ env ->
1458 bind_args env bs args thing_inside
1462 %************************************************************************
1464 \subsection{Duplicating continuations}
1466 %************************************************************************
1469 prepareCaseCont :: SimplEnv
1470 -> [InAlt] -> SimplCont
1471 -> SimplM (FloatsWith SimplCont) -- Return a duplicatable continuation,
1472 -- plus some extra bindings
1474 prepareCaseCont env [alt] cont = returnSmpl (emptyFloats env, cont)
1475 -- No need to make it duplicatable if there's only one alternative
1477 prepareCaseCont env alts cont = simplType env (coreAltsType alts) `thenSmpl` \ alts_ty ->
1478 mkDupableCont env alts_ty cont
1479 -- At one time I passed in the un-simplified type, and simplified
1480 -- it only if we needed to construct a join binder, but that
1481 -- didn't work because we have to decompse function types
1482 -- (using funResultTy) in mkDupableCont.
1486 mkDupableCont :: SimplEnv
1487 -> OutType -- Type of the thing to be given to the continuation
1489 -> SimplM (FloatsWith SimplCont) -- Return a duplicatable continuation,
1490 -- plus some extra bindings
1492 mkDupableCont env ty cont
1493 | contIsDupable cont
1494 = returnSmpl (emptyFloats env, cont)
1496 mkDupableCont env _ (CoerceIt ty cont)
1497 = mkDupableCont env ty cont `thenSmpl` \ (floats, cont') ->
1498 returnSmpl (floats, CoerceIt ty cont')
1500 mkDupableCont env ty (InlinePlease cont)
1501 = mkDupableCont env ty cont `thenSmpl` \ (floats, cont') ->
1502 returnSmpl (floats, InlinePlease cont')
1504 mkDupableCont env join_arg_ty (ArgOf _ is_rhs cont_ty cont_fn)
1505 = -- e.g. (...strict-fn...) [...hole...]
1507 -- let $j = \a -> ...strict-fn...
1508 -- in $j [...hole...]
1510 -- Build the join Id and continuation
1511 -- We give it a "$j" name just so that for later amusement
1512 -- we can identify any join points that don't end up as let-no-escapes
1513 -- [NOTE: the type used to be exprType join_rhs, but this seems more elegant.]
1514 newId SLIT("$j") (mkFunTy join_arg_ty cont_ty) `thenSmpl` \ join_id ->
1515 newId SLIT("a") join_arg_ty `thenSmpl` \ arg_id ->
1517 cont_fn (addNewInScopeIds env [arg_id]) (Var arg_id) `thenSmpl` \ (floats, rhs) ->
1519 cont_fn env arg' = rebuildDone env (App (Var join_id) arg')
1520 join_rhs = Lam (setOneShotLambda arg_id) (wrapFloats floats rhs)
1523 tick (CaseOfCase join_id) `thenSmpl_`
1524 -- Want to tick here so that we go round again,
1525 -- and maybe copy or inline the code;
1526 -- not strictly CaseOf Case
1528 returnSmpl (unitFloat env join_id join_rhs,
1529 ArgOf OkToDup is_rhs cont_ty cont_fn)
1531 mkDupableCont env ty (ApplyTo _ arg se cont)
1532 = -- e.g. [...hole...] (...arg...)
1534 -- let a = ...arg...
1535 -- in [...hole...] a
1536 mkDupableCont env (funResultTy ty) cont `thenSmpl` \ (floats, cont') ->
1537 addFloats env floats $ \ env ->
1539 simplExpr (setInScope se env) arg `thenSmpl` \ arg' ->
1540 if exprIsDupable arg' then
1541 returnSmpl (emptyFloats env, ApplyTo OkToDup arg' (zapSubstEnv se) cont')
1543 newId SLIT("a") (exprType arg') `thenSmpl` \ arg_id ->
1545 tick (CaseOfCase arg_id) `thenSmpl_`
1546 -- Want to tick here so that we go round again,
1547 -- and maybe copy or inline the code.
1548 -- Not strictly CaseOfCase, but never mind
1550 returnSmpl (unitFloat env arg_id arg',
1551 ApplyTo OkToDup (Var arg_id) (zapSubstEnv se) cont')
1552 -- But what if the arg should be case-bound?
1553 -- This has been this way for a long time, so I'll leave it,
1554 -- but I can't convince myself that it's right.
1557 mkDupableCont env ty (Select _ case_bndr alts se cont)
1558 = -- e.g. (case [...hole...] of { pi -> ei })
1560 -- let ji = \xij -> ei
1561 -- in case [...hole...] of { pi -> ji xij }
1562 tick (CaseOfCase case_bndr) `thenSmpl_`
1564 alt_env = setInScope se env
1566 prepareCaseCont alt_env alts cont `thenSmpl` \ (floats1, dupable_cont) ->
1567 addFloats alt_env floats1 $ \ alt_env ->
1569 simplBinder alt_env case_bndr `thenSmpl` \ (alt_env, case_bndr') ->
1570 -- NB: simplBinder does not zap deadness occ-info, so
1571 -- a dead case_bndr' will still advertise its deadness
1572 -- This is really important because in
1573 -- case e of b { (# a,b #) -> ... }
1574 -- b is always dead, and indeed we are not allowed to bind b to (# a,b #),
1575 -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.
1576 -- In the new alts we build, we have the new case binder, so it must retain
1579 mkDupableAlts alt_env case_bndr' alts dupable_cont `thenSmpl` \ (floats2, alts') ->
1580 addFloats alt_env floats2 $ \ alt_env ->
1581 returnSmpl (emptyFloats alt_env, Select OkToDup case_bndr' alts' (zapSubstEnv se)
1582 (mkBoringStop (contResultType cont)))
1584 mkDupableAlts :: SimplEnv -> OutId -> [InAlt] -> SimplCont
1585 -> SimplM (FloatsWith [InAlt])
1586 -- Absorbs the continuation into the new alternatives
1588 mkDupableAlts env case_bndr' alts dupable_cont
1591 go env [] = returnSmpl (emptyFloats env, [])
1593 = mkDupableAlt env case_bndr' dupable_cont alt `thenSmpl` \ (floats1, alt') ->
1594 addFloats env floats1 $ \ env ->
1595 go env alts `thenSmpl` \ (floats2, alts') ->
1596 returnSmpl (floats2, alt' : alts')
1598 mkDupableAlt env case_bndr' cont alt@(con, bndrs, rhs)
1599 = simplBinders env bndrs `thenSmpl` \ (env, bndrs') ->
1600 simplExprC env rhs cont `thenSmpl` \ rhs' ->
1602 if exprIsDupable rhs' then
1603 returnSmpl (emptyFloats env, (con, bndrs', rhs'))
1604 -- It is worth checking for a small RHS because otherwise we
1605 -- get extra let bindings that may cause an extra iteration of the simplifier to
1606 -- inline back in place. Quite often the rhs is just a variable or constructor.
1607 -- The Ord instance of Maybe in PrelMaybe.lhs, for example, took several extra
1608 -- iterations because the version with the let bindings looked big, and so wasn't
1609 -- inlined, but after the join points had been inlined it looked smaller, and so
1612 -- NB: we have to check the size of rhs', not rhs.
1613 -- Duplicating a small InAlt might invalidate occurrence information
1614 -- However, if it *is* dupable, we return the *un* simplified alternative,
1615 -- because otherwise we'd need to pair it up with an empty subst-env....
1616 -- but we only have one env shared between all the alts.
1617 -- (Remember we must zap the subst-env before re-simplifying something).
1618 -- Rather than do this we simply agree to re-simplify the original (small) thing later.
1622 rhs_ty' = exprType rhs'
1623 used_bndrs' = filter (not . isDeadBinder) (case_bndr' : bndrs')
1624 -- The deadness info on the new binders is unscathed
1626 -- If we try to lift a primitive-typed something out
1627 -- for let-binding-purposes, we will *caseify* it (!),
1628 -- with potentially-disastrous strictness results. So
1629 -- instead we turn it into a function: \v -> e
1630 -- where v::State# RealWorld#. The value passed to this function
1631 -- is realworld#, which generates (almost) no code.
1633 -- There's a slight infelicity here: we pass the overall
1634 -- case_bndr to all the join points if it's used in *any* RHS,
1635 -- because we don't know its usage in each RHS separately
1637 -- We used to say "&& isUnLiftedType rhs_ty'" here, but now
1638 -- we make the join point into a function whenever used_bndrs'
1639 -- is empty. This makes the join-point more CPR friendly.
1640 -- Consider: let j = if .. then I# 3 else I# 4
1641 -- in case .. of { A -> j; B -> j; C -> ... }
1643 -- Now CPR doesn't w/w j because it's a thunk, so
1644 -- that means that the enclosing function can't w/w either,
1645 -- which is a lose. Here's the example that happened in practice:
1646 -- kgmod :: Int -> Int -> Int
1647 -- kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
1651 -- I have seen a case alternative like this:
1652 -- True -> \v -> ...
1653 -- It's a bit silly to add the realWorld dummy arg in this case, making
1656 -- (the \v alone is enough to make CPR happy) but I think it's rare
1658 ( if null used_bndrs'
1659 then newId SLIT("w") realWorldStatePrimTy `thenSmpl` \ rw_id ->
1660 returnSmpl ([rw_id], [Var realWorldPrimId])
1662 returnSmpl (used_bndrs', map varToCoreExpr used_bndrs')
1663 ) `thenSmpl` \ (final_bndrs', final_args) ->
1665 -- See comment about "$j" name above
1666 newId SLIT("$j") (foldr mkPiType rhs_ty' final_bndrs') `thenSmpl` \ join_bndr ->
1667 -- Notice the funky mkPiType. If the contructor has existentials
1668 -- it's possible that the join point will be abstracted over
1669 -- type varaibles as well as term variables.
1670 -- Example: Suppose we have
1671 -- data T = forall t. C [t]
1673 -- case (case e of ...) of
1674 -- C t xs::[t] -> rhs
1675 -- We get the join point
1676 -- let j :: forall t. [t] -> ...
1677 -- j = /\t \xs::[t] -> rhs
1679 -- case (case e of ...) of
1680 -- C t xs::[t] -> j t xs
1683 -- We make the lambdas into one-shot-lambdas. The
1684 -- join point is sure to be applied at most once, and doing so
1685 -- prevents the body of the join point being floated out by
1686 -- the full laziness pass
1687 really_final_bndrs = map one_shot final_bndrs'
1688 one_shot v | isId v = setOneShotLambda v
1690 join_rhs = mkLams really_final_bndrs rhs'
1691 join_call = mkApps (Var join_bndr) final_args
1693 returnSmpl (unitFloat env join_bndr join_rhs, (con, bndrs', join_call))