-
+%
% (c) The AQUA Project, Glasgow University, 1993-1998
%
\section[Simplify]{The main module of the simplifier}
\begin{code}
-module Simplify ( simplBind ) where
+module Simplify ( simplTopBinds, simplExpr ) where
#include "HsVersions.h"
-import CmdLineOpts ( switchIsOn, opt_SccProfilingOn, opt_PprStyle_Debug,
- opt_NoPreInlining, opt_DictsStrict, opt_D_dump_inlinings,
+import CmdLineOpts ( dopt, DynFlag(Opt_D_dump_inlinings),
SimplifierSwitch(..)
)
import SimplMonad
-import SimplUtils ( mkCase, etaCoreExpr, etaExpandCount, findAlt, mkRhsTyLam,
- simplBinder, simplBinders, simplIds, findDefault
+import SimplUtils ( mkCase, mkLam, newId,
+ simplBinder, simplLamBinders, simplBinders, simplRecIds, simplLetId,
+ SimplCont(..), DupFlag(..), LetRhsFlag(..),
+ mkStop, mkBoringStop,
+ contResultType, discardInline, countArgs, contIsDupable, contIsRhsOrArg,
+ getContArgs, interestingCallContext, interestingArg, isStrictType
)
-import Var ( TyVar, mkSysTyVar, tyVarKind )
+import Var ( mustHaveLocalBinding )
import VarEnv
-import VarSet
-import Id ( Id, idType,
- getIdUnfolding, setIdUnfolding,
- getIdSpecialisation, setIdSpecialisation,
- getIdDemandInfo, setIdDemandInfo,
- getIdArity, setIdArity,
- getIdStrictness,
- setInlinePragma, getInlinePragma, idMustBeINLINEd,
- idWantsToBeINLINEd
+import Id ( Id, idType, idInfo, idArity, isDataConId,
+ idUnfolding, setIdUnfolding, isDeadBinder,
+ idNewDemandInfo, setIdInfo,
+ setIdOccInfo,
+ zapLamIdInfo, setOneShotLambda,
)
-import IdInfo ( InlinePragInfo(..), OccInfo(..), StrictnessInfo(..),
- ArityInfo, atLeastArity, arityLowerBound, unknownArity
+import IdInfo ( OccInfo(..), isLoopBreaker,
+ setArityInfo,
+ setUnfoldingInfo,
+ occInfo
)
-import Demand ( Demand, isStrict, wwLazy )
-import Const ( isWHNFCon, conOkForAlt )
-import ConFold ( tryPrimOp )
-import PrimOp ( PrimOp, primOpStrictness )
-import DataCon ( DataCon, dataConNumInstArgs, dataConStrictMarks, dataConSig, dataConArgTys )
-import Const ( Con(..) )
-import MagicUFs ( applyMagicUnfoldingFun )
-import Name ( isExported, isLocallyDefined )
+import NewDemand ( isStrictDmd )
+import DataCon ( dataConNumInstArgs, dataConRepStrictness )
import CoreSyn
-import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..),
- mkUnfolding, smallEnoughToInline,
- isEvaldUnfolding
+import PprCore ( pprParendExpr, pprCoreExpr )
+import CoreUnfold ( mkOtherCon, mkUnfolding, otherCons, callSiteInline )
+import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding,
+ exprIsConApp_maybe, mkPiType, findAlt, findDefault,
+ exprType, coreAltsType, exprIsValue,
+ exprOkForSpeculation, exprArity,
+ mkCoerce, mkSCC, mkInlineMe, mkAltExpr
)
-import CoreUtils ( IdSubst, SubstCoreExpr(..),
- cheapEqExpr, exprIsDupable, exprIsWHNF, exprIsTrivial,
- coreExprType, coreAltsType, exprIsCheap, substExpr,
- FormSummary(..), mkFormSummary, whnfOrBottom
+import Rules ( lookupRule )
+import BasicTypes ( isMarkedStrict )
+import CostCentre ( currentCCS )
+import Type ( isUnLiftedType, seqType, mkFunTy, tyConAppArgs,
+ funResultTy, splitFunTy_maybe, splitFunTy, eqType
)
-import SpecEnv ( lookupSpecEnv, isEmptySpecEnv, substSpecEnv )
-import CostCentre ( isSubsumedCCS, currentCCS, isEmptyCC )
-import Type ( Type, mkTyVarTy, mkTyVarTys, isUnLiftedType, fullSubstTy,
- mkFunTy, splitFunTys, splitTyConApp_maybe, splitFunTy_maybe,
- applyTy, applyTys, funResultTy, isDictTy, isDataType
+import Subst ( mkSubst, substTy, substExpr,
+ isInScope, lookupIdSubst, simplIdInfo
)
-import TyCon ( isDataTyCon, tyConDataCons, tyConClass_maybe, tyConArity, isDataTyCon )
import TysPrim ( realWorldStatePrimTy )
-import PrelVals ( realWorldPrimId )
-import BasicTypes ( StrictnessMark(..) )
-import Maybes ( maybeToBool )
-import Util ( zipWithEqual, stretchZipEqual )
-import PprCore
+import PrelInfo ( realWorldPrimId )
+import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
+ RecFlag(..), isNonRec
+ )
+import OrdList
+import Maybe ( Maybe )
import Outputable
\end{code}
-The guts of the simplifier is in this module, but the driver
-loop for the simplifier is in SimplPgm.lhs.
+The guts of the simplifier is in this module, but the driver loop for
+the simplifier is in SimplCore.lhs.
-%************************************************************************
-%* *
-\subsection[Simplify-simplExpr]{The main function: simplExpr}
-%* *
-%************************************************************************
+-----------------------------------------
+ *** IMPORTANT NOTE ***
+-----------------------------------------
+The simplifier used to guarantee that the output had no shadowing, but
+it does not do so any more. (Actually, it never did!) The reason is
+documented with simplifyArgs.
-\begin{code}
-addBind :: CoreBind -> OutStuff a -> OutStuff a
-addBind bind (binds, res) = (bind:binds, res)
-addBinds :: [CoreBind] -> OutStuff a -> OutStuff a
-addBinds [] stuff = stuff
-addBinds binds1 (binds2, res) = (binds1++binds2, res)
-\end{code}
+-----------------------------------------
+ *** IMPORTANT NOTE ***
+-----------------------------------------
+Many parts of the simplifier return a bunch of "floats" as well as an
+expression. This is wrapped as a datatype SimplUtils.FloatsWith.
-The reason for this OutExprStuff stuff is that we want to float *after*
-simplifying a RHS, not before. If we do so naively we get quadratic
-behaviour as things float out.
+All "floats" are let-binds, not case-binds, but some non-rec lets may
+be unlifted (with RHS ok-for-speculation).
-To see why it's important to do it after, consider this (real) example:
- let t = f x
- in fst t
-==>
- let t = let a = e1
- b = e2
- in (a,b)
- in fst t
-==>
- let a = e1
- b = e2
- t = (a,b)
- in
- a -- Can't inline a this round, cos it appears twice
-==>
- e1
-Each of the ==> steps is a round of simplification. We'd save a
-whole round if we float first. This can cascade. Consider
+-----------------------------------------
+ ORGANISATION OF FUNCTIONS
+-----------------------------------------
+simplTopBinds
+ - simplify all top-level binders
+ - for NonRec, call simplRecOrTopPair
+ - for Rec, call simplRecBind
- let f = g d
- in \x -> ...f...
-==>
- let f = let d1 = ..d.. in \y -> e
- in \x -> ...f...
-==>
- let d1 = ..d..
- in \x -> ...(\y ->e)...
-
-Only in this second round can the \y be applied, and it
-might do the same again.
-
-
-\begin{code}
-simplExpr :: CoreExpr -> SimplCont -> SimplM CoreExpr
-simplExpr expr cont = simplExprB expr cont `thenSmpl` \ (binds, (_, body)) ->
- returnSmpl (mkLetBinds binds body)
-
-simplExprB :: InExpr -> SimplCont -> SimplM OutExprStuff
-
-simplExprB (Note InlineCall (Var v)) cont
- = simplVar True v cont
-
-simplExprB (Var v) cont
- = simplVar False v cont
-
-simplExprB expr@(Con (PrimOp op) args) cont
- = simplType (coreExprType expr) `thenSmpl` \ expr_ty ->
- getInScope `thenSmpl` \ in_scope ->
- getSubstEnv `thenSmpl` \ se ->
- let
- (val_arg_demands, _) = primOpStrictness op
-
- -- Main game plan: loop through the arguments, simplifying
- -- each of them with an ArgOf continuation. Getting the right
- -- cont_ty in the ArgOf continuation is a bit of a nuisance.
- go [] ds args' = rebuild_primop (reverse args')
- go (arg:args) ds args'
- | isTypeArg arg = setSubstEnv se (simplArg arg) `thenSmpl` \ arg' ->
- go args ds (arg':args')
- go (arg:args) (d:ds) args'
- | not (isStrict d) = setSubstEnv se (simplArg arg) `thenSmpl` \ arg' ->
- go args ds (arg':args')
- | otherwise = setSubstEnv se (simplExprB arg (mk_cont args ds args'))
-
- cont_ty = contResultType in_scope expr_ty cont
- mk_cont args ds args' = ArgOf NoDup (\ arg' -> go args ds (arg':args')) cont_ty
- in
- go args val_arg_demands []
- where
-
- rebuild_primop args'
- = -- Try the prim op simplification
- -- It's really worth trying simplExpr again if it succeeds,
- -- because you can find
- -- case (eqChar# x 'a') of ...
- -- ==>
- -- case (case x of 'a' -> True; other -> False) of ...
- case tryPrimOp op args' of
- Just e' -> zapSubstEnv (simplExprB e' cont)
- Nothing -> rebuild (Con (PrimOp op) args') cont
-
-simplExprB (Con con@(DataCon _) args) cont
- = simplConArgs args $ \ args' ->
- rebuild (Con con args') cont
-
-simplExprB expr@(Con con@(Literal _) args) cont
- = ASSERT( null args )
- rebuild expr cont
-
-simplExprB (App fun arg) cont
- = getSubstEnv `thenSmpl` \ se ->
- simplExprB fun (ApplyTo NoDup arg se cont)
-
-simplExprB (Case scrut bndr alts) cont
- = getSubstEnv `thenSmpl` \ se ->
- simplExprB scrut (Select NoDup bndr alts se cont)
-
-simplExprB (Note (Coerce to from) e) cont
- | to == from = simplExprB e cont
- | otherwise = getSubstEnv `thenSmpl` \ se ->
- simplExprB e (CoerceIt NoDup to se cont)
-
--- hack: we only distinguish subsumed cost centre stacks for the purposes of
--- inlining. All other CCCSs are mapped to currentCCS.
-simplExprB (Note (SCC cc) e) cont
- = setEnclosingCC currentCCS $
- simplExpr e Stop `thenSmpl` \ e ->
- rebuild (mkNote (SCC cc) e) cont
-
-simplExprB (Note note e) cont
- = simplExpr e Stop `thenSmpl` \ e' ->
- rebuild (mkNote note e') cont
-
--- A non-recursive let is dealt with by simplBeta
-simplExprB (Let (NonRec bndr rhs) body) cont
- = getSubstEnv `thenSmpl` \ se ->
- simplBeta bndr rhs se body cont
-
-simplExprB (Let (Rec pairs) body) cont
- = simplRecBind pairs (simplExprB body cont)
-
--- Type-beta reduction
-simplExprB expr@(Lam bndr body) cont@(ApplyTo _ (Type ty_arg) arg_se body_cont)
- = ASSERT( isTyVar bndr )
- tick BetaReduction `thenSmpl_`
- setSubstEnv arg_se (simplType ty_arg) `thenSmpl` \ ty' ->
- extendTySubst bndr ty' $
- simplExprB body body_cont
-
--- Ordinary beta reduction
-simplExprB expr@(Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont)
- = tick BetaReduction `thenSmpl_`
- simplBeta bndr' arg arg_se body body_cont
- where
- bndr' = zapLambdaBndr bndr body body_cont
-
-simplExprB (Lam bndr body) cont
- = simplBinder bndr $ \ bndr' ->
- simplExpr body Stop `thenSmpl` \ body' ->
- rebuild (Lam bndr' body') cont
-
-simplExprB (Type ty) cont
- = ASSERT( case cont of { Stop -> True; ArgOf _ _ _ -> True; other -> False } )
- simplType ty `thenSmpl` \ ty' ->
- rebuild (Type ty') cont
-\end{code}
-
-
----------------------------------
-\begin{code}
-simplArg :: InArg -> SimplM OutArg
-simplArg arg = simplExpr arg Stop
-\end{code}
+
+ ------------------------------
+simplExpr (applied lambda) ==> simplNonRecBind
+simplExpr (Let (NonRec ...) ..) ==> simplNonRecBind
+simplExpr (Let (Rec ...) ..) ==> simplify binders; simplRecBind
+
+ ------------------------------
+simplRecBind [binders already simplfied]
+ - use simplRecOrTopPair on each pair in turn
+
+simplRecOrTopPair [binder already simplified]
+ Used for: recursive bindings (top level and nested)
+ top-level non-recursive bindings
+ Returns:
+ - check for PreInlineUnconditionally
+ - simplLazyBind
+
+simplNonRecBind
+ Used for: non-top-level non-recursive bindings
+ beta reductions (which amount to the same thing)
+ Because it can deal with strict arts, it takes a
+ "thing-inside" and returns an expression
+
+ - check for PreInlineUnconditionally
+ - simplify binder, including its IdInfo
+ - if strict binding
+ simplStrictArg
+ mkAtomicArgs
+ completeNonRecX
+ else
+ simplLazyBind
+ addFloats
+
+simplNonRecX: [given a *simplified* RHS, but an *unsimplified* binder]
+ Used for: binding case-binder and constr args in a known-constructor case
+ - check for PreInLineUnconditionally
+ - simplify binder
+ - completeNonRecX
+
+ ------------------------------
+simplLazyBind: [binder already simplified, RHS not]
+ Used for: recursive bindings (top level and nested)
+ top-level non-recursive bindings
+ non-top-level, but *lazy* non-recursive bindings
+ [must not be strict or unboxed]
+ Returns floats + an augmented environment, not an expression
+ - substituteIdInfo and add result to in-scope
+ [so that rules are available in rec rhs]
+ - simplify rhs
+ - mkAtomicArgs
+ - float if exposes constructor or PAP
+ - completeLazyBind
+
+
+completeNonRecX: [binder and rhs both simplified]
+ - if the the thing needs case binding (unlifted and not ok-for-spec)
+ build a Case
+ else
+ completeLazyBind
+ addFloats
+
+completeLazyBind: [given a simplified RHS]
+ [used for both rec and non-rec bindings, top level and not]
+ - try PostInlineUnconditionally
+ - add unfolding [this is the only place we add an unfolding]
+ - add arity
+
+
+
+Right hand sides and arguments
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In many ways we want to treat
+ (a) the right hand side of a let(rec), and
+ (b) a function argument
+in the same way. But not always! In particular, we would
+like to leave these arguments exactly as they are, so they
+will match a RULE more easily.
+
+ f (g x, h x)
+ g (+ x)
----------------------------------
-simplConArgs makes sure that the arguments all end up being atomic.
-That means it may generate some Lets, hence the
+It's harder to make the rule match if we ANF-ise the constructor,
+or eta-expand the PAP:
-\begin{code}
-simplConArgs :: [InArg] -> ([OutArg] -> SimplM OutExprStuff) -> SimplM OutExprStuff
-simplConArgs [] thing_inside
- = thing_inside []
+ f (let { a = g x; b = h x } in (a,b))
+ g (\y. + x y)
-simplConArgs (arg:args) thing_inside
- = switchOffInlining (simplArg arg) `thenSmpl` \ arg' ->
- -- Simplify the RHS with inlining switched off, so that
- -- only absolutely essential things will happen.
+On the other hand if we see the let-defns
- simplConArgs args $ \ args' ->
+ p = (g x, h x)
+ q = + x
- -- If the argument ain't trivial, then let-bind it
- if exprIsTrivial arg' then
- thing_inside (arg' : args')
- else
- newId (coreExprType arg') $ \ arg_id ->
- thing_inside (Var arg_id : args') `thenSmpl` \ res ->
- returnSmpl (addBind (NonRec arg_id arg') res)
-\end{code}
+then we *do* want to ANF-ise and eta-expand, so that p and q
+can be safely inlined.
+Even floating lets out is a bit dubious. For let RHS's we float lets
+out if that exposes a value, so that the value can be inlined more vigorously.
+For example
----------------------------------
-\begin{code}
-simplType :: InType -> SimplM OutType
-simplType ty
- = getTyEnv `thenSmpl` \ (ty_subst, in_scope) ->
- returnSmpl (fullSubstTy ty_subst in_scope ty)
-\end{code}
+ r = let x = e in (x,x)
+Here, if we float the let out we'll expose a nice constructor. We did experiments
+that showed this to be a generally good thing. But it was a bad thing to float
+lets out unconditionally, because that meant they got allocated more often.
-\begin{code}
--- Find out whether the lambda is saturated,
--- if not zap the over-optimistic info in the binder
-
-zapLambdaBndr bndr body body_cont
- | isTyVar bndr || safe_info || definitely_saturated 20 body body_cont
- -- The "20" is to catch pathalogical cases with bazillions of arguments
- -- because we are using an n**2 algorithm here
- = bndr -- No need to zap
- | otherwise
- = setInlinePragma (setIdDemandInfo bndr wwLazy)
- safe_inline_prag
+For function arguments, there's less reason to expose a constructor (it won't
+get inlined). Just possibly it might make a rule match, but I'm pretty skeptical.
+So for the moment we don't float lets out of function arguments either.
- where
- inline_prag = getInlinePragma bndr
- demand = getIdDemandInfo bndr
- safe_info = is_safe_inline_prag && not (isStrict demand)
+Eta expansion
+~~~~~~~~~~~~~~
+For eta expansion, we want to catch things like
- is_safe_inline_prag = case inline_prag of
- ICanSafelyBeINLINEd StrictOcc nalts -> False
- ICanSafelyBeINLINEd LazyOcc nalts -> False
- other -> True
+ case e of (a,b) -> \x -> case a of (p,q) -> \y -> r
- safe_inline_prag = case inline_prag of
- ICanSafelyBeINLINEd _ nalts
- -> ICanSafelyBeINLINEd InsideLam nalts
- other -> inline_prag
+If the \x was on the RHS of a let, we'd eta expand to bring the two
+lambdas together. And in general that's a good thing to do. Perhaps
+we should eta expand wherever we find a (value) lambda? Then the eta
+expansion at a let RHS can concentrate solely on the PAP case.
- definitely_saturated 0 _ _ = False -- Too expensive to find out
- definitely_saturated n (Lam _ body) (ApplyTo _ _ _ cont) = definitely_saturated (n-1) body cont
- definitely_saturated n (Lam _ _) other_cont = False
- definitely_saturated n _ _ = True
-\end{code}
%************************************************************************
%* *
-\subsection{Variables}
+\subsection{Bindings}
%* *
%************************************************************************
-Coercions
-~~~~~~~~~
\begin{code}
-simplVar inline_call var cont
- = getValEnv `thenSmpl` \ (id_subst, in_scope) ->
- case lookupVarEnv id_subst var of
- Just (Done e)
- -> zapSubstEnv (simplExprB e cont)
-
- Just (SubstMe e ty_subst id_subst)
- -> setSubstEnv (ty_subst, id_subst) (simplExprB e cont)
-
- Nothing -> let
- var' = case lookupVarSet in_scope var of
- Just v' -> v'
- Nothing ->
-#ifdef DEBUG
- if isLocallyDefined var && not (idMustBeINLINEd var) then
- -- Not in scope
- pprTrace "simplVar:" (ppr var) var
- else
-#endif
- var
- in
- getSwitchChecker `thenSmpl` \ sw_chkr ->
- completeVar sw_chkr in_scope inline_call var' cont
-
-completeVar sw_chkr in_scope inline_call var cont
-
-{- MAGIC UNFOLDINGS NOT USED NOW
- | maybeToBool maybe_magic_result
- = tick MagicUnfold `thenSmpl_`
- magic_result
--}
- -- Look for existing specialisations before trying inlining
- | maybeToBool maybe_specialisation
- = tick SpecialisationDone `thenSmpl_`
- setSubstEnv (spec_bindings, emptyVarEnv) (
- -- See note below about zapping the substitution here
-
- simplExprB spec_template remaining_cont
- )
-
- -- Don't actually inline the scrutinee when we see
- -- case x of y { .... }
- -- and x has unfolding (C a b). Why not? Because
- -- we get a silly binding y = C a b. If we don't
- -- inline knownCon can directly substitute x for y instead.
- | has_unfolding && var_is_case_scrutinee && unfolding_is_constr
- = knownCon (Var var) con con_args cont
-
- -- Look for an unfolding. There's a binding for the
- -- thing, but perhaps we want to inline it anyway
- | has_unfolding && (inline_call || ok_to_inline)
- = getEnclosingCC `thenSmpl` \ encl_cc ->
- if must_be_unfolded || costCentreOk encl_cc (coreExprCc unf_template)
- then -- OK to unfold
-
- tickUnfold var `thenSmpl_` (
-
- zapSubstEnv $
- -- The template is already simplified, so don't re-substitute.
- -- This is VITAL. Consider
- -- let x = e in
- -- let y = \z -> ...x... in
- -- \ x -> ...y...
- -- We'll clone the inner \x, adding x->x' in the id_subst
- -- Then when we inline y, we must *not* replace x by x' in
- -- the inlined copy!!
-#ifdef DEBUG
- if opt_D_dump_inlinings then
- pprTrace "Inlining:" (ppr var <+> ppr unf_template) $
- simplExprB unf_template cont
- else
-#endif
- simplExprB unf_template cont
- )
- else
-#ifdef DEBUG
- pprTrace "Inlining disallowed due to CC:\n" (ppr encl_cc <+> ppr unf_template <+> ppr (coreExprCc unf_template)) $
-#endif
- -- Can't unfold because of bad cost centre
- rebuild (Var var) cont
-
- | inline_call -- There was an InlineCall note, but we didn't inline!
- = rebuild (Note InlineCall (Var var)) cont
-
- | otherwise
- = rebuild (Var var) cont
-
+simplTopBinds :: SimplEnv -> [InBind] -> SimplM [OutBind]
+
+simplTopBinds env binds
+ = -- Put all the top-level binders into scope at the start
+ -- so that if a transformation rule has unexpectedly brought
+ -- anything into scope, then we don't get a complaint about that.
+ -- It's rather as if the top-level binders were imported.
+ simplRecIds env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') ->
+ simpl_binds env binds bndrs' `thenSmpl` \ (floats, _) ->
+ freeTick SimplifierDone `thenSmpl_`
+ returnSmpl (floatBinds floats)
where
- unfolding = getIdUnfolding var
-
-{- MAGIC UNFOLDINGS NOT USED CURRENTLY
- ---------- Magic unfolding stuff
- maybe_magic_result = case unfolding of
- MagicUnfolding _ magic_fn -> applyMagicUnfoldingFun magic_fn
- cont
- other -> Nothing
- Just magic_result = maybe_magic_result
--}
-
- ---------- Unfolding stuff
- has_unfolding = case unfolding of
- CoreUnfolding _ _ _ -> True
- other -> False
- CoreUnfolding form guidance unf_template = unfolding
-
- -- overrides cost-centre business
- must_be_unfolded = case getInlinePragma var of
- IMustBeINLINEd -> True
- _ -> False
-
- ok_to_inline = okToInline sw_chkr in_scope var form guidance cont
- unfolding_is_constr = case unf_template of
- Con con _ -> conOkForAlt con
- other -> False
- Con con con_args = unf_template
-
- ---------- Specialisation stuff
- ty_args = initial_ty_args cont
- remaining_cont = drop_ty_args cont
- maybe_specialisation = lookupSpecEnv (ppr var) (getIdSpecialisation var) ty_args
- Just (spec_bindings, spec_template) = maybe_specialisation
-
- initial_ty_args (ApplyTo _ (Type ty) (ty_subst,_) cont)
- = fullSubstTy ty_subst in_scope ty : initial_ty_args cont
- -- Having to do the substitution here is a bit of a bore
- initial_ty_args other_cont = []
-
- drop_ty_args (ApplyTo _ (Type _) _ cont) = drop_ty_args cont
- drop_ty_args other_cont = other_cont
-
- ---------- Switches
-
- var_is_case_scrutinee = case cont of
- Select _ _ _ _ _ -> True
- other -> False
-
------------ costCentreOk
--- costCentreOk checks that it's ok to inline this thing
--- The time it *isn't* is this:
---
--- f x = let y = E in
--- scc "foo" (...y...)
---
--- Here y has a "current cost centre", and we can't inline it inside "foo",
--- regardless of whether E is a WHNF or not.
-
-costCentreOk ccs_encl cc_rhs
- = not opt_SccProfilingOn
- || isSubsumedCCS ccs_encl -- can unfold anything into a subsumed scope
- || not (isEmptyCC cc_rhs) -- otherwise need a cc on the unfolding
-\end{code}
+ -- We need to track the zapped top-level binders, because
+ -- they should have their fragile IdInfo zapped (notably occurrence info)
+ -- That's why we run down binds and bndrs' simultaneously.
+ simpl_binds :: SimplEnv -> [InBind] -> [OutId] -> SimplM (FloatsWith ())
+ simpl_binds env [] bs = ASSERT( null bs ) returnSmpl (emptyFloats env, ())
+ simpl_binds env (bind:binds) bs = simpl_bind env bind bs `thenSmpl` \ (floats,env) ->
+ addFloats env floats $ \env ->
+ simpl_binds env binds (drop_bs bind bs)
+
+ drop_bs (NonRec _ _) (_ : bs) = bs
+ drop_bs (Rec prs) bs = drop (length prs) bs
+
+ simpl_bind env (NonRec b r) (b':_) = simplRecOrTopPair env TopLevel b b' r
+ simpl_bind env (Rec pairs) bs' = simplRecBind env TopLevel pairs bs'
+\end{code}
%************************************************************************
%* *
-\subsection{Bindings}
+\subsection{simplNonRec}
%* *
%************************************************************************
-\begin{code}
-simplBind :: InBind -> SimplM (OutStuff a) -> SimplM (OutStuff a)
+simplNonRecBind is used for
+ * non-top-level non-recursive lets in expressions
+ * beta reduction
-simplBind (NonRec bndr rhs) thing_inside
- = simplTopRhs bndr rhs `thenSmpl` \ (binds, in_scope, rhs', arity) ->
- setInScope in_scope $
- completeBindNonRec (bndr `setIdArity` arity) rhs' thing_inside `thenSmpl` \ stuff ->
- returnSmpl (addBinds binds stuff)
+It takes
+ * An unsimplified (binder, rhs) pair
+ * The env for the RHS. It may not be the same as the
+ current env because the bind might occur via (\x.E) arg
-simplBind (Rec pairs) thing_inside
- = simplRecBind pairs thing_inside
- -- The assymetry between the two cases is a bit unclean
+It uses the CPS form because the binding might be strict, in which
+case we might discard the continuation:
+ let x* = error "foo" in (...x...)
-simplRecBind :: [(InId, InExpr)] -> SimplM (OutStuff a) -> SimplM (OutStuff a)
-simplRecBind pairs thing_inside
- = simplIds (map fst pairs) $ \ bndrs' ->
- -- NB: bndrs' don't have unfoldings or spec-envs
- -- We add them as we go down, using simplPrags
+It needs to turn unlifted bindings into a @case@. They can arise
+from, say: (\x -> e) (4# + 3#)
- go (pairs `zip` bndrs') `thenSmpl` \ (pairs', stuff) ->
- returnSmpl (addBind (Rec pairs') stuff)
- where
- go [] = thing_inside `thenSmpl` \ stuff ->
- returnSmpl ([], stuff)
+\begin{code}
+simplNonRecBind :: SimplEnv
+ -> InId -- Binder
+ -> InExpr -> SimplEnv -- Arg, with its subst-env
+ -> OutType -- Type of thing computed by the context
+ -> (SimplEnv -> SimplM FloatsWithExpr) -- The body
+ -> SimplM FloatsWithExpr
+#ifdef DEBUG
+simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside
+ | isTyVar bndr
+ = pprPanic "simplNonRecBind" (ppr bndr <+> ppr rhs)
+#endif
- go (((bndr, rhs), bndr') : pairs)
- = simplTopRhs bndr rhs `thenSmpl` \ (rhs_binds, in_scope, rhs', arity) ->
- setInScope in_scope $
- completeBindRec bndr (bndr' `setIdArity` arity)
- rhs' (go pairs) `thenSmpl` \ (pairs', stuff) ->
- returnSmpl (flatten rhs_binds pairs', stuff)
+simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside
+ | preInlineUnconditionally env NotTopLevel bndr
+ = tick (PreInlineUnconditionally bndr) `thenSmpl_`
+ thing_inside (extendSubst env bndr (ContEx (getSubstEnv rhs_se) rhs))
+
+
+ | isStrictDmd (idNewDemandInfo bndr) || isStrictType (idType bndr) -- A strict let
+ = -- Don't use simplBinder because that doesn't keep
+ -- fragile occurrence in the substitution
+ simplLetId env bndr `thenSmpl` \ (env, bndr') ->
+ simplStrictArg env AnRhs rhs rhs_se cont_ty $ \ env rhs1 ->
+
+ -- Make the arguments atomic if necessary,
+ -- adding suitable bindings
+ mkAtomicArgs True True rhs1 `thenSmpl` \ (aux_binds, rhs2) ->
+ addAtomicBindsE env aux_binds $ \ env ->
+
+ -- Now complete the binding and simplify the body
+ completeNonRecX env bndr bndr' rhs2 thing_inside
+
+ | otherwise -- Normal, lazy case
+ = -- Don't use simplBinder because that doesn't keep
+ -- fragile occurrence in the substitution
+ simplLetId env bndr `thenSmpl` \ (env, bndr') ->
+ simplLazyBind env NotTopLevel NonRecursive
+ bndr bndr' rhs rhs_se `thenSmpl` \ (floats, env) ->
+ addFloats env floats thing_inside
+\end{code}
+
+A specialised variant of simplNonRec used when the RHS is already simplified, notably
+in knownCon. It uses case-binding where necessary.
- flatten (NonRec b r : binds) prs = (b,r) : flatten binds prs
- flatten (Rec prs1 : binds) prs2 = prs1 ++ flatten binds prs2
- flatten [] prs = prs
+\begin{code}
+simplNonRecX :: SimplEnv
+ -> InId -- Old binder
+ -> OutExpr -- Simplified RHS
+ -> (SimplEnv -> SimplM FloatsWithExpr)
+ -> SimplM FloatsWithExpr
+
+simplNonRecX env bndr new_rhs thing_inside
+ | preInlineUnconditionally env NotTopLevel bndr
+ -- This happens; for example, the case_bndr during case of
+ -- known constructor: case (a,b) of x { (p,q) -> ... }
+ -- Here x isn't mentioned in the RHS, so we don't want to
+ -- create the (dead) let-binding let x = (a,b) in ...
+ --
+ -- Similarly, single occurrences can be inlined vigourously
+ -- e.g. case (f x, g y) of (a,b) -> ....
+ -- If a,b occur once we can avoid constructing the let binding for them.
+ = thing_inside (extendSubst env bndr (ContEx emptySubstEnv new_rhs))
+ | otherwise
+ = simplBinder env bndr `thenSmpl` \ (env, bndr') ->
+ completeNonRecX env bndr bndr' new_rhs thing_inside
-completeBindRec bndr bndr' rhs' thing_inside
- | postInlineUnconditionally bndr etad_rhs
- -- NB: a loop breaker never has postInlineUnconditionally True
- -- and non-loop-breakers only have *forward* references
- -- Hence, it's safe to discard the binding
- = tick PostInlineUnconditionally `thenSmpl_`
- extendIdSubst bndr (Done etad_rhs) thing_inside
+completeNonRecX env old_bndr new_bndr new_rhs thing_inside
+ | needsCaseBinding (idType new_bndr) new_rhs
+ = thing_inside env `thenSmpl` \ (floats, body) ->
+ returnSmpl (emptyFloats env, Case new_rhs new_bndr [(DEFAULT, [], wrapFloats floats body)])
- | otherwise
- = -- Here's the only difference from completeBindNonRec: we
- -- don't do simplBinder first, because we've already
- -- done simplBinder on the recursive binders
- simplPrags bndr bndr' etad_rhs `thenSmpl` \ bndr'' ->
- modifyInScope bndr'' $
- thing_inside `thenSmpl` \ (pairs, res) ->
- returnSmpl ((bndr'', etad_rhs) : pairs, res)
- where
- etad_rhs = etaCoreExpr rhs'
+ | otherwise
+ = completeLazyBind env NotTopLevel
+ old_bndr new_bndr new_rhs `thenSmpl` \ (floats, env) ->
+ addFloats env floats thing_inside
\end{code}
%************************************************************************
%* *
-\subsection{Right hand sides}
+\subsection{Lazy bindings}
%* *
%************************************************************************
-simplRhs basically just simplifies the RHS of a let(rec).
-It does two important optimisations though:
-
- * It floats let(rec)s out of the RHS, even if they
- are hidden by big lambdas
-
- * It does eta expansion
+simplRecBind is used for
+ * recursive bindings only
\begin{code}
-simplTopRhs :: InId -> InExpr
- -> SimplM ([OutBind], InScopeEnv, OutExpr, ArityInfo)
-simplTopRhs bndr rhs
- = getSubstEnv `thenSmpl` \ bndr_se ->
- simplRhs bndr bndr_se rhs
-
-simplRhs bndr bndr_se rhs
- | idWantsToBeINLINEd bndr -- Don't inline in the RHS of something that has an
- -- inline pragma. But be careful that the InScopeEnv that
- -- we return does still have inlinings on!
- = switchOffInlining (simplExpr rhs Stop) `thenSmpl` \ rhs' ->
- getInScope `thenSmpl` \ in_scope ->
- returnSmpl ([], in_scope, rhs', unknownArity)
-
- | otherwise
- = -- Swizzle the inner lets past the big lambda (if any)
- mkRhsTyLam rhs `thenSmpl` \ swizzled_rhs ->
-
- -- Simplify the swizzled RHS
- simplRhs2 bndr bndr_se swizzled_rhs `thenSmpl` \ (floats, (in_scope, rhs', arity)) ->
-
- if not (null floats) && exprIsWHNF rhs' then -- Do the float
- tick LetFloatFromLet `thenSmpl_`
- returnSmpl (floats, in_scope, rhs', arity)
- else -- Don't do it
- getInScope `thenSmpl` \ in_scope ->
- returnSmpl ([], in_scope, mkLetBinds floats rhs', arity)
+simplRecBind :: SimplEnv -> TopLevelFlag
+ -> [(InId, InExpr)] -> [OutId]
+ -> SimplM (FloatsWith SimplEnv)
+simplRecBind env top_lvl pairs bndrs'
+ = go env pairs bndrs' `thenSmpl` \ (floats, env) ->
+ returnSmpl (flattenFloats floats, env)
+ where
+ go env [] _ = returnSmpl (emptyFloats env, env)
+
+ go env ((bndr, rhs) : pairs) (bndr' : bndrs')
+ = simplRecOrTopPair env top_lvl bndr bndr' rhs `thenSmpl` \ (floats, env) ->
+ addFloats env floats (\env -> go env pairs bndrs')
\end{code}
----------------------------------------------------------
- Try eta expansion for RHSs
-We need to pass in the substitution environment for the RHS, because
-it might be different to the current one (see simplBeta, as called
-from simplExpr for an applied lambda). The binder needs to
+simplRecOrTopPair is used for
+ * recursive bindings (whether top level or not)
+ * top-level non-recursive bindings
+
+It assumes the binder has already been simplified, but not its IdInfo.
\begin{code}
-simplRhs2 bndr bndr_se (Let bind body)
- = simplBind bind (simplRhs2 bndr bndr_se body)
-
-simplRhs2 bndr bndr_se rhs
- | null ids -- Prevent eta expansion for both thunks
- -- (would lose sharing) and variables (nothing gained).
- -- To see why we ignore it for thunks, consider
- -- let f = lookup env key in (f 1, f 2)
- -- We'd better not eta expand f just because it is
- -- always applied!
- --
- -- Also if there isn't a lambda at the top we use
- -- simplExprB so that we can do (more) let-floating
- = simplExprB rhs Stop `thenSmpl` \ (binds, (in_scope, rhs')) ->
- returnSmpl (binds, (in_scope, rhs', unknownArity))
-
- | otherwise -- Consider eta expansion
- = getSwitchChecker `thenSmpl` \ sw_chkr ->
- getInScope `thenSmpl` \ in_scope ->
- simplBinders tyvars $ \ tyvars' ->
- simplBinders ids $ \ ids' ->
-
- if switchIsOn sw_chkr SimplDoLambdaEtaExpansion
- && not (null extra_arg_tys)
- then
- tick EtaExpansion `thenSmpl_`
- setSubstEnv bndr_se (mapSmpl simplType extra_arg_tys)
- `thenSmpl` \ extra_arg_tys' ->
- newIds extra_arg_tys' $ \ extra_bndrs' ->
- simplExpr body (mk_cont extra_bndrs') `thenSmpl` \ body' ->
- let
- expanded_rhs = mkLams tyvars'
- $ mkLams ids'
- $ mkLams extra_bndrs' body'
- expanded_arity = atLeastArity (no_of_ids + no_of_extras)
- in
- returnSmpl ([], (in_scope, expanded_rhs, expanded_arity))
+simplRecOrTopPair :: SimplEnv
+ -> TopLevelFlag
+ -> InId -> OutId -- Binder, both pre-and post simpl
+ -> InExpr -- The RHS and its environment
+ -> SimplM (FloatsWith SimplEnv)
- else
- simplExpr body Stop `thenSmpl` \ body' ->
- let
- unexpanded_rhs = mkLams tyvars'
- $ mkLams ids' body'
- unexpanded_arity = atLeastArity no_of_ids
- in
- returnSmpl ([], (in_scope, unexpanded_rhs, unexpanded_arity))
+simplRecOrTopPair env top_lvl bndr bndr' rhs
+ | preInlineUnconditionally env top_lvl bndr -- Check for unconditional inline
+ = tick (PreInlineUnconditionally bndr) `thenSmpl_`
+ returnSmpl (emptyFloats env, extendSubst env bndr (ContEx (getSubstEnv env) rhs))
- where
- (tyvars, ids, body) = collectTyAndValBinders rhs
- no_of_ids = length ids
+ | otherwise
+ = simplLazyBind env top_lvl Recursive bndr bndr' rhs env
+ -- May not actually be recursive, but it doesn't matter
+\end{code}
- potential_extra_arg_tys :: [InType] -- NB: InType
- potential_extra_arg_tys = case splitFunTys (applyTys (idType bndr) (mkTyVarTys tyvars)) of
- (arg_tys, _) -> drop no_of_ids arg_tys
- extra_arg_tys :: [InType]
- extra_arg_tys = take no_extras_wanted potential_extra_arg_tys
- no_of_extras = length extra_arg_tys
+simplLazyBind is used for
+ * recursive bindings (whether top level or not)
+ * top-level non-recursive bindings
+ * non-top-level *lazy* non-recursive bindings
- no_extras_wanted = -- Use information about how many args the fn is applied to
- (arity - no_of_ids) `max`
+[Thus it deals with the lazy cases from simplNonRecBind, and all cases
+from SimplRecOrTopBind]
- -- See if the body could obviously do with more args
- etaExpandCount body `max`
+Nota bene:
+ 1. It assumes that the binder is *already* simplified,
+ and is in scope, but not its IdInfo
- -- Finally, see if it's a state transformer, in which
- -- case we eta-expand on principle! This can waste work,
- -- but usually doesn't
- case potential_extra_arg_tys of
- [ty] | ty == realWorldStatePrimTy -> 1
- other -> 0
+ 2. It assumes that the binder type is lifted.
- arity = arityLowerBound (getIdArity bndr)
+ 3. It does not check for pre-inline-unconditionallly;
+ that should have been done already.
- mk_cont [] = Stop
- mk_cont (b:bs) = ApplyTo OkToDup (Var b) emptySubstEnv (mk_cont bs)
+\begin{code}
+simplLazyBind :: SimplEnv
+ -> TopLevelFlag -> RecFlag
+ -> InId -> OutId -- Binder, both pre-and post simpl
+ -> InExpr -> SimplEnv -- The RHS and its environment
+ -> SimplM (FloatsWith SimplEnv)
+
+simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se
+ = -- Substitute IdInfo on binder, in the light of earlier
+ -- substitutions in this very letrec, and extend the
+ -- in-scope env, so that the IdInfo for this binder extends
+ -- over the RHS for the binder itself.
+ --
+ -- This is important. Manuel found cases where he really, really
+ -- wanted a RULE for a recursive function to apply in that function's
+ -- own right-hand side.
+ --
+ -- NB: does no harm for non-recursive bindings
+ let
+ bndr_ty' = idType bndr'
+ bndr'' = simplIdInfo (getSubst rhs_se) (idInfo bndr) bndr'
+ env1 = modifyInScope env bndr'' bndr''
+ rhs_env = setInScope rhs_se env1
+ ok_float_unlifted = isNotTopLevel top_lvl && isNonRec is_rec
+ rhs_cont = mkStop bndr_ty' AnRhs
+ in
+ -- Simplify the RHS; note the mkStop, which tells
+ -- the simplifier that this is the RHS of a let.
+ simplExprF rhs_env rhs rhs_cont `thenSmpl` \ (floats, rhs1) ->
+
+ -- If any of the floats can't be floated, give up now
+ -- (The allLifted predicate says True for empty floats.)
+ if (not ok_float_unlifted && not (allLifted floats)) then
+ completeLazyBind env1 top_lvl bndr bndr''
+ (wrapFloats floats rhs1)
+ else
+
+ -- ANF-ise a constructor or PAP rhs
+ mkAtomicArgs False {- Not strict -}
+ ok_float_unlifted rhs1 `thenSmpl` \ (aux_binds, rhs2) ->
+
+ -- If the result is a PAP, float the floats out, else wrap them
+ -- By this time it's already been ANF-ised (if necessary)
+ if isEmptyFloats floats && null aux_binds then -- Shortcut a common case
+ completeLazyBind env1 top_lvl bndr bndr'' rhs2
+
+ -- We use exprIsTrivial here because we want to reveal lone variables.
+ -- E.g. let { x = letrec { y = E } in y } in ...
+ -- Here we definitely want to float the y=E defn.
+ -- exprIsValue definitely isn't right for that.
+ --
+ -- BUT we can't use "exprIsCheap", because that causes a strictness bug.
+ -- x = let y* = E in case (scc y) of { T -> F; F -> T}
+ -- The case expression is 'cheap', but it's wrong to transform to
+ -- y* = E; x = case (scc y) of {...}
+ -- Either we must be careful not to float demanded non-values, or
+ -- we must use exprIsValue for the test, which ensures that the
+ -- thing is non-strict. I think. The WARN below tests for this
+ else if exprIsTrivial rhs2 || exprIsValue rhs2 then
+ -- There's a subtlety here. There may be a binding (x* = e) in the
+ -- floats, where the '*' means 'will be demanded'. So is it safe
+ -- to float it out? Answer no, but it won't matter because
+ -- we only float if arg' is a WHNF,
+ -- and so there can't be any 'will be demanded' bindings in the floats.
+ -- Hence the assert
+ WARN( any demanded_float (floatBinds floats),
+ ppr (filter demanded_float (floatBinds floats)) )
+
+ tick LetFloatFromLet `thenSmpl_` (
+ addFloats env1 floats $ \ env2 ->
+ addAtomicBinds env2 aux_binds $ \ env3 ->
+ completeLazyBind env3 top_lvl bndr bndr'' rhs2)
+
+ else
+ completeLazyBind env1 top_lvl bndr bndr'' (wrapFloats floats rhs1)
+
+#ifdef DEBUG
+demanded_float (NonRec b r) = isStrictDmd (idNewDemandInfo b) && not (isUnLiftedType (idType b))
+ -- Unlifted-type (cheap-eagerness) lets may well have a demanded flag on them
+demanded_float (Rec _) = False
+#endif
\end{code}
%************************************************************************
%* *
-\subsection{Binding}
+\subsection{Completing a lazy binding}
%* *
%************************************************************************
-\begin{code}
-simplBeta :: InId -- Binder
- -> InExpr -> SubstEnv -- Arg, with its subst-env
- -> InExpr -> SimplCont -- Lambda body
- -> SimplM OutExprStuff
-#ifdef DEBUG
-simplBeta bndr rhs rhs_se body cont
- | isTyVar bndr
- = pprPanic "simplBeta" ((ppr bndr <+> ppr rhs) $$ ppr cont)
-#endif
+completeLazyBind
+ * deals only with Ids, not TyVars
+ * takes an already-simplified binder and RHS
+ * is used for both recursive and non-recursive bindings
+ * is used for both top-level and non-top-level bindings
-simplBeta bndr rhs rhs_se body cont
- | isUnLiftedType bndr_ty
- || (isStrict (getIdDemandInfo bndr) || is_dict bndr) && not (exprIsWHNF rhs)
- = tick Let2Case `thenSmpl_`
- getSubstEnv `thenSmpl` \ body_se ->
- setSubstEnv rhs_se $
- simplExprB rhs (Select NoDup bndr [(DEFAULT, [], body)] body_se cont)
+It does the following:
+ - tries discarding a dead binding
+ - tries PostInlineUnconditionally
+ - add unfolding [this is the only place we add an unfolding]
+ - add arity
- | preInlineUnconditionally bndr && not opt_NoPreInlining
- = tick PreInlineUnconditionally `thenSmpl_`
- case rhs_se of { (ty_subst, id_subst) ->
- extendIdSubst bndr (SubstMe rhs ty_subst id_subst) $
- simplExprB body cont }
+It does *not* attempt to do let-to-case. Why? Because it is used for
+ - top-level bindings (when let-to-case is impossible)
+ - many situations where the "rhs" is known to be a WHNF
+ (so let-to-case is inappropriate).
- | otherwise
- = getSubstEnv `thenSmpl` \ bndr_se ->
- setSubstEnv rhs_se (simplRhs bndr bndr_se rhs)
- `thenSmpl` \ (floats, in_scope, rhs', arity) ->
- setInScope in_scope $
- completeBindNonRec (bndr `setIdArity` arity) rhs' (
- simplExprB body cont
- ) `thenSmpl` \ stuff ->
- returnSmpl (addBinds floats stuff)
- where
- -- Return true only for dictionary types where the dictionary
- -- has more than one component (else we risk poking on the component
- -- of a newtype dictionary)
- is_dict bndr = opt_DictsStrict && isDictTy bndr_ty && isDataType bndr_ty
- bndr_ty = idType bndr
-\end{code}
+\begin{code}
+completeLazyBind :: SimplEnv
+ -> TopLevelFlag -- Flag stuck into unfolding
+ -> InId -- Old binder
+ -> OutId -- New binder
+ -> OutExpr -- Simplified RHS
+ -> SimplM (FloatsWith SimplEnv)
+-- We return a new SimplEnv, because completeLazyBind may choose to do its work
+-- by extending the substitution (e.g. let x = y in ...)
+-- The new binding (if any) is returned as part of the floats.
+-- NB: the returned SimplEnv has the right SubstEnv, but you should
+-- (as usual) use the in-scope-env from the floats
+
+completeLazyBind env top_lvl old_bndr new_bndr new_rhs
+ | postInlineUnconditionally env new_bndr loop_breaker new_rhs
+ = -- Drop the binding
+ tick (PostInlineUnconditionally old_bndr) `thenSmpl_`
+ returnSmpl (emptyFloats env, extendSubst env old_bndr (DoneEx new_rhs))
+ -- Use the substitution to make quite, quite sure that the substitution
+ -- will happen, since we are going to discard the binding
+ | otherwise
+ = let
+ -- Add arity info
+ new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs
+
+ -- Add the unfolding *only* for non-loop-breakers
+ -- Making loop breakers not have an unfolding at all
+ -- means that we can avoid tests in exprIsConApp, for example.
+ -- This is important: if exprIsConApp says 'yes' for a recursive
+ -- thing, then we can get into an infinite loop
+ info_w_unf | loop_breaker = new_bndr_info
+ | otherwise = new_bndr_info `setUnfoldingInfo` unfolding
+ unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs
+
+ final_id = new_bndr `setIdInfo` info_w_unf
+ in
+ -- These seqs forces the Id, and hence its IdInfo,
+ -- and hence any inner substitutions
+ final_id `seq`
+ returnSmpl (unitFloat env final_id new_rhs, env)
+
+ where
+ loop_breaker = isLoopBreaker occ_info
+ old_info = idInfo old_bndr
+ occ_info = occInfo old_info
+\end{code}
-completeBindNonRec
- - deals only with Ids, not TyVars
- - take an already-simplified RHS
- - always produce let bindings
-It does *not* attempt to do let-to-case. Why? Because they are used for
- - top-level bindings
- (when let-to-case is impossible)
+%************************************************************************
+%* *
+\subsection[Simplify-simplExpr]{The main function: simplExpr}
+%* *
+%************************************************************************
- - many situations where the "rhs" is known to be a WHNF
- (so let-to-case is inappropriate).
+The reason for this OutExprStuff stuff is that we want to float *after*
+simplifying a RHS, not before. If we do so naively we get quadratic
+behaviour as things float out.
-\begin{code}
-completeBindNonRec :: InId -- Binder
- -> OutExpr -- Simplified RHS
- -> SimplM (OutStuff a) -- Thing inside
- -> SimplM (OutStuff a)
-completeBindNonRec bndr rhs thing_inside
- | isDeadBinder bndr -- This happens; for example, the case_bndr during case of
- -- known constructor: case (a,b) of x { (p,q) -> ... }
- -- Here x isn't mentioned in the RHS, so we don't want to
- -- create the (dead) let-binding let x = (a,b) in ...
- = thing_inside
-
- | postInlineUnconditionally bndr etad_rhs
- = tick PostInlineUnconditionally `thenSmpl_`
- extendIdSubst bndr (Done etad_rhs)
- thing_inside
-
- | otherwise -- Note that we use etad_rhs here
- -- This gives maximum chance for a remaining binding
- -- to be zapped by the indirection zapper in OccurAnal
- = simplBinder bndr $ \ bndr' ->
- simplPrags bndr bndr' etad_rhs `thenSmpl` \ bndr'' ->
- modifyInScope bndr'' $
- thing_inside `thenSmpl` \ stuff ->
- returnSmpl (addBind (NonRec bndr' etad_rhs) stuff)
- where
- etad_rhs = etaCoreExpr rhs
+To see why it's important to do it after, consider this (real) example:
--- (simplPrags old_bndr new_bndr new_rhs) does two things
--- (a) it attaches the new unfolding to new_bndr
--- (b) it grabs the SpecEnv from old_bndr, applies the current
--- substitution to it, and attaches it to new_bndr
--- The assumption is that new_bndr, which is produced by simplBinder
--- has no unfolding or specenv.
+ let t = f x
+ in fst t
+==>
+ let t = let a = e1
+ b = e2
+ in (a,b)
+ in fst t
+==>
+ let a = e1
+ b = e2
+ t = (a,b)
+ in
+ a -- Can't inline a this round, cos it appears twice
+==>
+ e1
-simplPrags old_bndr new_bndr new_rhs
- | isEmptySpecEnv spec_env
- = returnSmpl (bndr_w_unfolding)
+Each of the ==> steps is a round of simplification. We'd save a
+whole round if we float first. This can cascade. Consider
- | otherwise
- = getSimplBinderStuff `thenSmpl` \ (ty_subst, id_subst, in_scope, us) ->
- let
- spec_env' = substSpecEnv ty_subst in_scope (subst_val id_subst) spec_env
- in
- returnSmpl (bndr_w_unfolding `setIdSpecialisation` spec_env')
- where
- bndr_w_unfolding = new_bndr `setIdUnfolding` mkUnfolding new_rhs
+ let f = g d
+ in \x -> ...f...
+==>
+ let f = let d1 = ..d.. in \y -> e
+ in \x -> ...f...
+==>
+ let d1 = ..d..
+ in \x -> ...(\y ->e)...
+
+Only in this second round can the \y be applied, and it
+might do the same again.
- spec_env = getIdSpecialisation old_bndr
- subst_val id_subst ty_subst in_scope expr
- = substExpr ty_subst id_subst in_scope expr
-\end{code}
\begin{code}
-preInlineUnconditionally :: InId -> Bool
- -- Examines a bndr to see if it is used just once in a
- -- completely safe way, so that it is safe to discard the binding
- -- inline its RHS at the (unique) usage site, REGARDLESS of how
- -- big the RHS might be. If this is the case we don't simplify
- -- the RHS first, but just inline it un-simplified.
- --
- -- This is much better than first simplifying a perhaps-huge RHS
- -- and then inlining and re-simplifying it.
- --
- -- NB: we don't even look at the RHS to see if it's trivial
- -- We might have
- -- x = y
- -- where x is used many times, but this is the unique occurrence
- -- of y. We should NOT inline x at all its uses, because then
- -- we'd do the same for y -- aargh! So we must base this
- -- pre-rhs-simplification decision solely on x's occurrences, not
- -- on its rhs.
-preInlineUnconditionally bndr
- = case getInlinePragma bndr of
- ICanSafelyBeINLINEd InsideLam _ -> False
- ICanSafelyBeINLINEd not_in_lam True -> True -- Not inside a lambda,
- -- one occurrence ==> safe!
- other -> False
-
-
-postInlineUnconditionally :: InId -> OutExpr -> Bool
- -- Examines a (bndr = rhs) binding, AFTER the rhs has been simplified
- -- It returns True if it's ok to discard the binding and inline the
- -- RHS at every use site.
-
- -- NOTE: This isn't our last opportunity to inline.
- -- We're at the binding site right now, and
- -- we'll get another opportunity when we get to the ocurrence(s)
-
-postInlineUnconditionally bndr rhs
- | isExported bndr
- = False
+simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
+simplExpr env expr = simplExprC env expr (mkBoringStop expr_ty')
+ where
+ expr_ty' = substTy (getSubst env) (exprType expr)
+ -- The type in the Stop continuation, expr_ty', is usually not used
+ -- It's only needed when discarding continuations after finding
+ -- a function that returns bottom.
+ -- Hence the lazy substitution
+
+
+simplExprC :: SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr
+ -- Simplify an expression, given a continuation
+simplExprC env expr cont
+ = simplExprF env expr cont `thenSmpl` \ (floats, expr) ->
+ returnSmpl (wrapFloats floats expr)
+
+simplExprF :: SimplEnv -> InExpr -> SimplCont -> SimplM FloatsWithExpr
+ -- Simplify an expression, returning floated binds
+
+simplExprF env (Var v) cont = simplVar env v cont
+simplExprF env (Lit lit) cont = rebuild env (Lit lit) cont
+simplExprF env expr@(Lam _ _) cont = simplLam env expr cont
+simplExprF env (Note note expr) cont = simplNote env note expr cont
+simplExprF env (App fun arg) cont = simplExprF env fun (ApplyTo NoDup arg env cont)
+
+simplExprF env (Type ty) cont
+ = ASSERT( contIsRhsOrArg cont )
+ simplType env ty `thenSmpl` \ ty' ->
+ rebuild env (Type ty') cont
+
+simplExprF env (Case scrut bndr alts) cont
+ | not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
+ = -- Simplify the scrutinee with a Select continuation
+ simplExprF env scrut (Select NoDup bndr alts env cont)
+
| otherwise
- = case getInlinePragma bndr of
- IAmALoopBreaker -> False
- IMustNotBeINLINEd -> False
- IAmASpecPragmaId -> False -- Don't discard SpecPrag Ids
-
- ICanSafelyBeINLINEd InsideLam one_branch -> exprIsTrivial rhs
- -- Don't inline even WHNFs inside lambdas; this
- -- isn't the last chance; see NOTE above.
-
- ICanSafelyBeINLINEd not_in_lam one_branch -> one_branch || exprIsDupable rhs
-
- other -> exprIsTrivial rhs -- Duplicating is *free*
- -- NB: Even IWantToBeINLINEd and IMustBeINLINEd are ignored here
- -- Why? Because we don't even want to inline them into the
- -- RHS of constructor arguments. See NOTE above
-
-inlineCase bndr scrut
- = case getInlinePragma bndr of
- -- Not expecting IAmALoopBreaker etc; this is a case binder!
-
- ICanSafelyBeINLINEd StrictOcc one_branch
- -> one_branch || exprIsDupable scrut
- -- This case is the entire reason we distinguish StrictOcc from LazyOcc
- -- We want eliminate the "case" only if we aren't going to
- -- build a thunk instead, and that's what StrictOcc finds
- -- For example:
- -- case (f x) of y { DEFAULT -> g y }
- -- Here we DO NOT WANT:
- -- g (f x)
- -- *even* if g is strict. We want to avoid constructing the
- -- thunk for (f x)! So y gets a LazyOcc.
-
- other -> exprIsTrivial scrut -- Duplication is free
- && ( isUnLiftedType (idType bndr)
- || scrut_is_evald_var -- So dropping the case won't change termination
- || isStrict (getIdDemandInfo bndr)) -- It's going to get evaluated later, so again
- -- termination doesn't change
+ = -- If case-of-case is off, simply simplify the case expression
+ -- in a vanilla Stop context, and rebuild the result around it
+ simplExprC env scrut case_cont `thenSmpl` \ case_expr' ->
+ rebuild env case_expr' cont
where
- -- Check whether or not scrut is known to be evaluted
- -- It's not going to be a visible value (else the previous
- -- blob would apply) so we just check the variable case
- scrut_is_evald_var = case scrut of
- Var v -> isEvaldUnfolding (getIdUnfolding v)
- other -> False
-\end{code}
+ case_cont = Select NoDup bndr alts env (mkBoringStop (contResultType cont))
-okToInline is used at call sites, so it is a bit more generous.
-It's a very important function that embodies lots of heuristics.
+simplExprF env (Let (Rec pairs) body) cont
+ = simplRecIds env (map fst pairs) `thenSmpl` \ (env, bndrs') ->
+ -- NB: bndrs' don't have unfoldings or spec-envs
+ -- We add them as we go down, using simplPrags
-\begin{code}
-okToInline :: SwitchChecker
- -> InScopeEnv
- -> Id -- The Id
- -> FormSummary -- The thing is WHNF or bottom;
- -> UnfoldingGuidance
- -> SimplCont
- -> Bool -- True <=> inline it
-
--- A non-WHNF can be inlined if it doesn't occur inside a lambda,
--- and occurs exactly once or
--- occurs once in each branch of a case and is small
---
--- If the thing is in WHNF, there's no danger of duplicating work,
--- so we can inline if it occurs once, or is small
+ simplRecBind env NotTopLevel pairs bndrs' `thenSmpl` \ (floats, env) ->
+ addFloats env floats $ \ env ->
+ simplExprF env body cont
-okToInline sw_chkr in_scope id form guidance cont
- | switchIsOn sw_chkr EssentialUnfoldingsOnly
- =
-#ifdef DEBUG
- if opt_D_dump_inlinings then
- pprTrace "Considering inlining"
- (ppr id <+> vcat [text "essential inlinings only",
- text "inline prag:" <+> ppr inline_prag,
- text "ANSWER =" <+> if result then text "YES" else text "NO"])
- result
- else
-#endif
- result
- where
- inline_prag = getInlinePragma id
- result = idMustBeINLINEd id
- -- If "essential_unfoldings_only" is true we do no inlinings at all,
- -- EXCEPT for things that absolutely have to be done
- -- (see comments with idMustBeINLINEd)
+-- A non-recursive let is dealt with by simplNonRecBind
+simplExprF env (Let (NonRec bndr rhs) body) cont
+ = simplNonRecBind env bndr rhs env (contResultType cont) $ \ env ->
+ simplExprF env body cont
-okToInline sw_chkr in_scope id form guidance cont
- -- Essential unfoldings only not on
- =
-#ifdef DEBUG
- if opt_D_dump_inlinings then
- pprTrace "Considering inlining"
- (ppr id <+> vcat [text "inline prag:" <+> ppr inline_prag,
- text "whnf" <+> ppr whnf,
- text "small enough" <+> ppr small_enough,
- text "some benefit" <+> ppr some_benefit,
- text "arg evals" <+> ppr arg_evals,
- text "result scrut" <+> ppr result_scrut,
- text "ANSWER =" <+> if result then text "YES" else text "NO"])
- result
- else
-#endif
- result
+---------------------------------
+simplType :: SimplEnv -> InType -> SimplM OutType
+ -- Kept monadic just so we can do the seqType
+simplType env ty
+ = seqType new_ty `seq` returnSmpl new_ty
where
- result = case inline_prag of
- IAmDead -> pprTrace "okToInline: dead" (ppr id) False
-
- IAmASpecPragmaId -> False
- IMustNotBeINLINEd -> False
- IAmALoopBreaker -> False
- IMustBeINLINEd -> True
- IWantToBeINLINEd -> True
-
- ICanSafelyBeINLINEd inside_lam one_branch
- -> (small_enough || one_branch) &&
- ((whnf && some_benefit) || not_inside_lam)
-
- where
- not_inside_lam = case inside_lam of {InsideLam -> False; other -> True}
-
- other -> whnf && small_enough && some_benefit
- -- We could consider using exprIsCheap here,
- -- as in postInlineUnconditionally, but unlike the latter we wouldn't
- -- necessarily eliminate a thunk; and the "form" doesn't tell
- -- us that.
-
- inline_prag = getInlinePragma id
- whnf = whnfOrBottom form
- small_enough = smallEnoughToInline id arg_evals result_scrut guidance
- (arg_evals, result_scrut) = get_evals cont
-
- -- some_benefit checks that *something* interesting happens to
- -- the variable after it's inlined.
- some_benefit = contIsInteresting cont
-
- -- Finding out whether the args are evaluated. This isn't completely easy
- -- because the args are not yet simplified, so we have to peek into them.
- get_evals (ApplyTo _ arg (te,ve) cont)
- | isValArg arg = case get_evals cont of
- (args, res) -> (get_arg_eval arg ve : args, res)
- | otherwise = get_evals cont
-
- get_evals (Select _ _ _ _ _) = ([], True)
- get_evals other = ([], False)
-
- get_arg_eval (Con con _) ve = isWHNFCon con
- get_arg_eval (Var v) ve = case lookupVarEnv ve v of
- Just (SubstMe e' _ ve') -> get_arg_eval e' ve'
- Just (Done (Con con _)) -> isWHNFCon con
- Just (Done (Var v')) -> get_var_eval v'
- Just (Done other) -> False
- Nothing -> get_var_eval v
- get_arg_eval other ve = False
-
- get_var_eval v = case lookupVarSet in_scope v of
- Just v' -> isEvaldUnfolding (getIdUnfolding v')
- Nothing -> isEvaldUnfolding (getIdUnfolding v)
-
-
-contIsInteresting :: SimplCont -> Bool
-contIsInteresting Stop = False
-contIsInteresting (ArgOf _ _ _) = False
-contIsInteresting (ApplyTo _ (Type _) _ cont) = contIsInteresting cont
-contIsInteresting (CoerceIt _ _ _ cont) = contIsInteresting cont
-
--- Even a case with only a default case is a bit interesting;
--- we may be able to eliminate it after inlining.
--- contIsInteresting (Select _ _ [(DEFAULT,_,_)] _ _) = False
-
-contIsInteresting _ = True
+ new_ty = substTy (getSubst env) ty
\end{code}
-Comment about some_benefit above
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-We want to avoid inlining an expression where there can't possibly be
-any gain, such as in an argument position. Hence, if the continuation
-is interesting (eg. a case scrutinee, application etc.) then we
-inline, otherwise we don't.
-
-Previously some_benefit used to return True only if the variable was
-applied to some value arguments. This didn't work:
- let x = _coerce_ (T Int) Int (I# 3) in
- case _coerce_ Int (T Int) x of
- I# y -> ....
+%************************************************************************
+%* *
+\subsection{Lambdas}
+%* *
+%************************************************************************
-we want to inline x, but can't see that it's a constructor in a case
-scrutinee position, and some_benefit is False.
+\begin{code}
+simplLam env fun cont
+ = go env fun cont
+ where
+ zap_it = mkLamBndrZapper fun cont
+ cont_ty = contResultType cont
+
+ -- Type-beta reduction
+ go env (Lam bndr body) (ApplyTo _ (Type ty_arg) arg_se body_cont)
+ = ASSERT( isTyVar bndr )
+ tick (BetaReduction bndr) `thenSmpl_`
+ simplType (setInScope arg_se env) ty_arg `thenSmpl` \ ty_arg' ->
+ go (extendSubst env bndr (DoneTy ty_arg')) body body_cont
+
+ -- Ordinary beta reduction
+ go env (Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont)
+ = tick (BetaReduction bndr) `thenSmpl_`
+ simplNonRecBind env zapped_bndr arg arg_se cont_ty $ \ env ->
+ go env body body_cont
+ where
+ zapped_bndr = zap_it bndr
+
+ -- Not enough args, so there are real lambdas left to put in the result
+ go env lam@(Lam _ _) cont
+ = simplLamBinders env bndrs `thenSmpl` \ (env, bndrs') ->
+ simplExpr env body `thenSmpl` \ body' ->
+ mkLam env bndrs' body' cont `thenSmpl` \ (floats, new_lam) ->
+ addFloats env floats $ \ env ->
+ rebuild env new_lam cont
+ where
+ (bndrs,body) = collectBinders lam
+
+ -- Exactly enough args
+ go env expr cont = simplExprF env expr cont
+
+mkLamBndrZapper :: CoreExpr -- Function
+ -> SimplCont -- The context
+ -> Id -> Id -- Use this to zap the binders
+mkLamBndrZapper fun cont
+ | n_args >= n_params fun = \b -> b -- Enough args
+ | otherwise = \b -> zapLamIdInfo b
+ where
+ -- NB: we count all the args incl type args
+ -- so we must count all the binders (incl type lambdas)
+ n_args = countArgs cont
-Another example:
+ n_params (Note _ e) = n_params e
+ n_params (Lam b e) = 1 + n_params e
+ n_params other = 0::Int
+\end{code}
-dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
-.... case dMonadST _@_ x0 of (a,b,c) -> ....
+%************************************************************************
+%* *
+\subsection{Notes}
+%* *
+%************************************************************************
-we'd really like to inline dMonadST here, but we *don't* want to
-inline if the case expression is just
+\begin{code}
+simplNote env (Coerce to from) body cont
+ = let
+ in_scope = getInScope env
+
+ addCoerce s1 k1 (CoerceIt t1 cont)
+ -- coerce T1 S1 (coerce S1 K1 e)
+ -- ==>
+ -- e, if T1=K1
+ -- coerce T1 K1 e, otherwise
+ --
+ -- For example, in the initial form of a worker
+ -- we may find (coerce T (coerce S (\x.e))) y
+ -- and we'd like it to simplify to e[y/x] in one round
+ -- of simplification
+ | t1 `eqType` k1 = cont -- The coerces cancel out
+ | otherwise = CoerceIt t1 cont -- They don't cancel, but
+ -- the inner one is redundant
+
+ addCoerce t1t2 s1s2 (ApplyTo dup arg arg_se cont)
+ | Just (s1, s2) <- splitFunTy_maybe s1s2
+ -- (coerce (T1->T2) (S1->S2) F) E
+ -- ===>
+ -- coerce T2 S2 (F (coerce S1 T1 E))
+ --
+ -- t1t2 must be a function type, T1->T2
+ -- but s1s2 might conceivably not be
+ --
+ -- When we build the ApplyTo we can't mix the out-types
+ -- with the InExpr in the argument, so we simply substitute
+ -- to make it all consistent. It's a bit messy.
+ -- But it isn't a common case.
+ = let
+ (t1,t2) = splitFunTy t1t2
+ new_arg = mkCoerce s1 t1 (substExpr (mkSubst in_scope (getSubstEnv arg_se)) arg)
+ in
+ ApplyTo dup new_arg (zapSubstEnv env) (addCoerce t2 s2 cont)
+
+ addCoerce to' _ cont = CoerceIt to' cont
+ in
+ simplType env to `thenSmpl` \ to' ->
+ simplType env from `thenSmpl` \ from' ->
+ simplExprF env body (addCoerce to' from' cont)
- case x of y { DEFAULT -> ... }
+
+-- Hack: we only distinguish subsumed cost centre stacks for the purposes of
+-- inlining. All other CCCSs are mapped to currentCCS.
+simplNote env (SCC cc) e cont
+ = simplExpr (setEnclosingCC env currentCCS) e `thenSmpl` \ e' ->
+ rebuild env (mkSCC cc e') cont
+
+simplNote env InlineCall e cont
+ = simplExprF env e (InlinePlease cont)
+
+-- See notes with SimplMonad.inlineMode
+simplNote env InlineMe e cont
+ | contIsRhsOrArg cont -- Totally boring continuation; see notes above
+ = -- Don't inline inside an INLINE expression
+ simplExpr (setMode inlineMode env ) e `thenSmpl` \ e' ->
+ rebuild env (mkInlineMe e') cont
+
+ | otherwise -- Dissolve the InlineMe note if there's
+ -- an interesting context of any kind to combine with
+ -- (even a type application -- anything except Stop)
+ = simplExprF env e cont
+\end{code}
-since we can just eliminate this case instead (x is in WHNF). Similar
-applies when x is bound to a lambda expression. Hence
-contIsInteresting looks for case expressions with just a single
-default case.
%************************************************************************
%* *
-\subsection{The main rebuilder}
+\subsection{Dealing with calls}
%* *
%************************************************************************
\begin{code}
--------------------------------------------------------------------
-rebuild :: OutExpr -> SimplCont -> SimplM OutExprStuff
-
-rebuild expr cont
- = tick LeavesExamined `thenSmpl_`
- do_rebuild expr cont
-
-rebuild_done expr
- = getInScope `thenSmpl` \ in_scope ->
- returnSmpl ([], (in_scope, expr))
+simplVar env var cont
+ = case lookupIdSubst (getSubst env) var of
+ DoneEx e -> simplExprF (zapSubstEnv env) e cont
+ ContEx se e -> simplExprF (setSubstEnv env se) e cont
+ DoneId var1 occ -> WARN( not (isInScope var1 (getSubst env)) && mustHaveLocalBinding var1,
+ text "simplVar:" <+> ppr var )
+ completeCall (zapSubstEnv env) var1 occ cont
+ -- The template is already simplified, so don't re-substitute.
+ -- This is VITAL. Consider
+ -- let x = e in
+ -- let y = \z -> ...x... in
+ -- \ x -> ...y...
+ -- We'll clone the inner \x, adding x->x' in the id_subst
+ -- Then when we inline y, we must *not* replace x by x' in
+ -- the inlined copy!!
---------------------------------------------------------
--- Stop continuation
-
-do_rebuild expr Stop = rebuild_done expr
+-- Dealing with a call
+completeCall env var occ_info cont
+ = getDOptsSmpl `thenSmpl` \ dflags ->
+ let
+ in_scope = getInScope env
+ chkr = getSwitchChecker env
----------------------------------------------------------
--- ArgOf continuation
+ (args, call_cont, inline_call) = getContArgs chkr var cont
-do_rebuild expr (ArgOf _ cont_fn _) = cont_fn expr
+ arg_infos = [ interestingArg in_scope arg (getSubstEnv arg_env)
+ | (arg, arg_env, _) <- args, isValArg arg]
----------------------------------------------------------
--- ApplyTo continuation
-
-do_rebuild expr cont@(ApplyTo _ arg se cont')
- = case expr of
- Var v -> case getIdStrictness v of
- NoStrictnessInfo -> non_strict_case
- StrictnessInfo demands result_bot _ -> ASSERT( not (null demands) || result_bot )
- -- If this happened we'd get an infinite loop
- rebuild_strict demands result_bot expr (idType v) cont
- other -> non_strict_case
- where
- non_strict_case = setSubstEnv se (simplArg arg) `thenSmpl` \ arg' ->
- do_rebuild (App expr arg') cont'
+ interesting_cont = interestingCallContext (not (null args))
+ (not (null arg_infos))
+ call_cont
+ inline_cont | inline_call = discardInline cont
+ | otherwise = cont
----------------------------------------------------------
--- Coerce continuation
-
-do_rebuild expr (CoerceIt _ to_ty se cont)
- = setSubstEnv se $
- simplType to_ty `thenSmpl` \ to_ty' ->
- do_rebuild (mk_coerce to_ty' expr) cont
- where
- mk_coerce to_ty' (Note (Coerce _ from_ty) expr) = Note (Coerce to_ty' from_ty) expr
- mk_coerce to_ty' expr = Note (Coerce to_ty' (coreExprType expr)) expr
+ active_inline = activeInline env var
+ maybe_inline = callSiteInline dflags active_inline inline_call occ_info
+ var arg_infos interesting_cont
+ in
+ -- First, look for an inlining
+ case maybe_inline of {
+ Just unfolding -- There is an inlining!
+ -> tick (UnfoldingDone var) `thenSmpl_`
+ simplExprF env unfolding inline_cont
+ ;
+ Nothing -> -- No inlining!
----------------------------------------------------------
--- Case of known constructor or literal
-do_rebuild expr@(Con con args) cont@(Select _ _ _ _ _)
- | conOkForAlt con -- Knocks out PrimOps and NoRepLits
- = knownCon expr con args cont
+ simplifyArgs env args (contResultType call_cont) $ \ env args' ->
+ -- Next, look for rules or specialisations that match
+ --
+ -- It's important to simplify the args first, because the rule-matcher
+ -- doesn't do substitution as it goes. We don't want to use subst_args
+ -- (defined in the 'where') because that throws away useful occurrence info,
+ -- and perhaps-very-important specialisations.
+ --
+ -- Some functions have specialisations *and* are strict; in this case,
+ -- we don't want to inline the wrapper of the non-specialised thing; better
+ -- to call the specialised thing instead.
+ -- But the black-listing mechanism means that inlining of the wrapper
+ -- won't occur for things that have specialisations till a later phase, so
+ -- it's ok to try for inlining first.
+ --
+ -- You might think that we shouldn't apply rules for a loop breaker:
+ -- doing so might give rise to an infinite loop, because a RULE is
+ -- rather like an extra equation for the function:
+ -- RULE: f (g x) y = x+y
+ -- Eqn: f a y = a-y
+ --
+ -- But it's too drastic to disable rules for loop breakers.
+ -- Even the foldr/build rule would be disabled, because foldr
+ -- is recursive, and hence a loop breaker:
+ -- foldr k z (build g) = g k z
+ -- So it's up to the programmer: rules can cause divergence
----------------------------------------------------------
+ let
+ maybe_rule = case activeRule env of
+ Nothing -> Nothing -- No rules apply
+ Just act_fn -> lookupRule act_fn in_scope var args'
+ in
+ case maybe_rule of {
+ Just (rule_name, rule_rhs) ->
+ tick (RuleFired rule_name) `thenSmpl_`
+ (if dopt Opt_D_dump_inlinings dflags then
+ pprTrace "Rule fired" (vcat [
+ text "Rule:" <+> ptext rule_name,
+ text "Before:" <+> ppr var <+> sep (map pprParendExpr args'),
+ text "After: " <+> pprCoreExpr rule_rhs])
+ else
+ id) $
+ simplExprF env rule_rhs call_cont ;
+
+ Nothing -> -- No rules
--- Case of other value (e.g. a partial application or lambda)
--- Turn it back into a let
+ -- Done
+ rebuild env (mkApps (Var var) args') call_cont
+ }}
+\end{code}
-do_rebuild expr (Select _ bndr ((DEFAULT, bs, rhs):alts) se cont)
- | case mkFormSummary expr of { ValueForm -> True; other -> False }
- = ASSERT( null bs && null alts )
- tick Case2Let `thenSmpl_`
- setSubstEnv se (
- completeBindNonRec bndr expr $
- simplExprB rhs cont
- )
+%************************************************************************
+%* *
+\subsection{Arguments}
+%* *
+%************************************************************************
+\begin{code}
---------------------------------------------------------
--- The other Select cases
-
-do_rebuild scrut (Select _ bndr alts se cont)
- = getSwitchChecker `thenSmpl` \ chkr ->
-
- if all (cheapEqExpr rhs1) other_rhss
- && inlineCase bndr scrut
- && all binders_unused alts
- && switchIsOn chkr SimplDoCaseElim
- then
- -- Get rid of the case altogether
- -- See the extensive notes on case-elimination below
- -- Remember to bind the binder though!
- tick CaseElim `thenSmpl_`
- setSubstEnv se (
- extendIdSubst bndr (Done scrut) $
- simplExprB rhs1 cont
- )
-
- else
- rebuild_case chkr scrut bndr alts se cont
+-- Simplifying the arguments of a call
+
+simplifyArgs :: SimplEnv
+ -> [(InExpr, SimplEnv, Bool)] -- Details of the arguments
+ -> OutType -- Type of the continuation
+ -> (SimplEnv -> [OutExpr] -> SimplM FloatsWithExpr)
+ -> SimplM FloatsWithExpr
+
+-- [CPS-like because of strict arguments]
+
+-- Simplify the arguments to a call.
+-- This part of the simplifier may break the no-shadowing invariant
+-- Consider
+-- f (...(\a -> e)...) (case y of (a,b) -> e')
+-- where f is strict in its second arg
+-- If we simplify the innermost one first we get (...(\a -> e)...)
+-- Simplifying the second arg makes us float the case out, so we end up with
+-- case y of (a,b) -> f (...(\a -> e)...) e'
+-- So the output does not have the no-shadowing invariant. However, there is
+-- no danger of getting name-capture, because when the first arg was simplified
+-- we used an in-scope set that at least mentioned all the variables free in its
+-- static environment, and that is enough.
+--
+-- We can't just do innermost first, or we'd end up with a dual problem:
+-- case x of (a,b) -> f e (...(\a -> e')...)
+--
+-- I spent hours trying to recover the no-shadowing invariant, but I just could
+-- not think of an elegant way to do it. The simplifier is already knee-deep in
+-- continuations. We have to keep the right in-scope set around; AND we have
+-- to get the effect that finding (error "foo") in a strict arg position will
+-- discard the entire application and replace it with (error "foo"). Getting
+-- all this at once is TOO HARD!
+
+simplifyArgs env args cont_ty thing_inside
+ = go env args thing_inside
where
- (rhs1:other_rhss) = [rhs | (_,_,rhs) <- alts]
- binders_unused (_, bndrs, _) = all isDeadBinder bndrs
-\end{code}
+ go env [] thing_inside = thing_inside env []
+ go env (arg:args) thing_inside = simplifyArg env arg cont_ty $ \ env arg' ->
+ go env args $ \ env args' ->
+ thing_inside env (arg':args')
-Case elimination [see the code above]
-~~~~~~~~~~~~~~~~
-Start with a simple situation:
-
- case x# of ===> e[x#/y#]
- y# -> e
-
-(when x#, y# are of primitive type, of course). We can't (in general)
-do this for algebraic cases, because we might turn bottom into
-non-bottom!
-
-Actually, we generalise this idea to look for a case where we're
-scrutinising a variable, and we know that only the default case can
-match. For example:
-\begin{verbatim}
- case x of
- 0# -> ...
- other -> ...(case x of
- 0# -> ...
- other -> ...) ...
-\end{code}
-Here the inner case can be eliminated. This really only shows up in
-eliminating error-checking code.
+simplifyArg env (Type ty_arg, se, _) cont_ty thing_inside
+ = simplType (setInScope se env) ty_arg `thenSmpl` \ new_ty_arg ->
+ thing_inside env (Type new_ty_arg)
-We also make sure that we deal with this very common case:
+simplifyArg env (val_arg, arg_se, is_strict) cont_ty thing_inside
+ | is_strict
+ = simplStrictArg env AnArg val_arg arg_se cont_ty thing_inside
- case e of
- x -> ...x...
-
-Here we are using the case as a strict let; if x is used only once
-then we want to inline it. We have to be careful that this doesn't
-make the program terminate when it would have diverged before, so we
-check that
- - x is used strictly, or
- - e is already evaluated (it may so if e is a variable)
+ | otherwise
+ = let
+ arg_env = setInScope arg_se env
+ in
+ simplType arg_env (exprType val_arg) `thenSmpl` \ arg_ty ->
+ simplExprF arg_env val_arg (mkStop arg_ty AnArg) `thenSmpl` \ (floats, arg1) ->
+ addFloats env floats $ \ env ->
+ thing_inside env arg1
+
+
+simplStrictArg :: SimplEnv -- The env of the call
+ -> LetRhsFlag
+ -> InExpr -> SimplEnv -- The arg plus its env
+ -> OutType -- cont_ty: Type of thing computed by the context
+ -> (SimplEnv -> OutExpr -> SimplM FloatsWithExpr)
+ -- Takes an expression of type rhs_ty,
+ -- returns an expression of type cont_ty
+ -- The env passed to this continuation is the
+ -- env of the call, plus any new in-scope variables
+ -> SimplM FloatsWithExpr -- An expression of type cont_ty
+
+simplStrictArg call_env is_rhs arg arg_env cont_ty thing_inside
+ = simplExprF (setInScope arg_env call_env) arg
+ (ArgOf NoDup is_rhs cont_ty (\ new_env -> thing_inside (setInScope call_env new_env)))
+ -- Notice the way we use arg_env (augmented with in-scope vars from call_env)
+ -- to simplify the argument
+ -- and call-env (augmented with in-scope vars from the arg) to pass to the continuation
+\end{code}
-Lastly, we generalise the transformation to handle this:
- case e of ===> r
- True -> r
- False -> r
+%************************************************************************
+%* *
+\subsection{mkAtomicArgs}
+%* *
+%************************************************************************
-We only do this for very cheaply compared r's (constructors, literals
-and variables). If pedantic bottoms is on, we only do it when the
-scrutinee is a PrimOp which can't fail.
+mkAtomicArgs takes a putative RHS, checks whether it's a PAP or
+constructor application and, if so, converts it to ANF, so that the
+resulting thing can be inlined more easily. Thus
+ x = (f a, g b)
+becomes
+ t1 = f a
+ t2 = g b
+ x = (t1,t2)
-We do it *here*, looking at un-simplified alternatives, because we
-have to check that r doesn't mention the variables bound by the
-pattern in each alternative, so the binder-info is rather useful.
+There are three sorts of binding context, specified by the two
+boolean arguments
-So the case-elimination algorithm is:
+Strict
+ OK-unlifted
- 1. Eliminate alternatives which can't match
+N N Top-level or recursive Only bind args of lifted type
- 2. Check whether all the remaining alternatives
- (a) do not mention in their rhs any of the variables bound in their pattern
- and (b) have equal rhss
+N Y Non-top-level and non-recursive, Bind args of lifted type, or
+ but lazy unlifted-and-ok-for-speculation
- 3. Check we can safely ditch the case:
- * PedanticBottoms is off,
- or * the scrutinee is an already-evaluated variable
- or * the scrutinee is a primop which is ok for speculation
- -- ie we want to preserve divide-by-zero errors, and
- -- calls to error itself!
+Y Y Non-top-level, non-recursive, Bind all args
+ and strict (demanded)
+
- or * [Prim cases] the scrutinee is a primitive variable
+For example, given
- or * [Alg cases] the scrutinee is a variable and
- either * the rhs is the same variable
- (eg case x of C a b -> x ===> x)
- or * there is only one alternative, the default alternative,
- and the binder is used strictly in its scope.
- [NB this is helped by the "use default binder where
- possible" transformation; see below.]
+ x = MkC (y div# z)
+there is no point in transforming to
-If so, then we can replace the case with one of the rhss.
+ x = case (y div# z) of r -> MkC r
+because the (y div# z) can't float out of the let. But if it was
+a *strict* let, then it would be a good thing to do. Hence the
+context information.
\begin{code}
----------------------------------------------------------
--- Rebuiling a function with strictness info
+mkAtomicArgs :: Bool -- A strict binding
+ -> Bool -- OK to float unlifted args
+ -> OutExpr
+ -> SimplM ([(OutId,OutExpr)], -- The floats (unusually) may include
+ OutExpr) -- things that need case-binding,
+ -- if the strict-binding flag is on
+
+mkAtomicArgs is_strict ok_float_unlifted rhs
+ = mk_atomic_args rhs `thenSmpl` \ maybe_stuff ->
+ case maybe_stuff of
+ Nothing -> returnSmpl ([], rhs)
+ Just (ol_binds, rhs') -> returnSmpl (fromOL ol_binds, rhs')
-rebuild_strict :: [Demand] -> Bool -- Stricness info
- -> OutExpr -> OutType -- Function and type
- -> SimplCont -- Continuation
- -> SimplM OutExprStuff
+ where
+ mk_atomic_args :: OutExpr -> SimplM (Maybe (OrdList (Id,OutExpr), OutExpr))
+ -- Nothing => no change
+ mk_atomic_args rhs
+ | (Var fun, args) <- collectArgs rhs, -- It's an application
+ isDataConId fun || valArgCount args < idArity fun -- And it's a constructor or PAP
+ = -- Worth a try
+ go nilOL [] args `thenSmpl` \ maybe_stuff ->
+ case maybe_stuff of
+ Nothing -> returnSmpl Nothing
+ Just (aux_binds, args') -> returnSmpl (Just (aux_binds, mkApps (Var fun) args'))
+
+ | otherwise
+ = returnSmpl Nothing
+
+ go binds rev_args []
+ = returnSmpl (Just (binds, reverse rev_args))
+ go binds rev_args (arg : args)
+ | exprIsTrivial arg -- Easy case
+ = go binds (arg:rev_args) args
+
+ | not can_float_arg -- Can't make this arg atomic
+ = returnSmpl Nothing -- ... so give up
+
+ | otherwise -- Don't forget to do it recursively
+ -- E.g. x = a:b:c:[]
+ = mk_atomic_args arg `thenSmpl` \ maybe_anf ->
+ case maybe_anf of {
+ Nothing -> returnSmpl Nothing ;
+ Just (arg_binds,arg') ->
+
+ newId SLIT("a") arg_ty `thenSmpl` \ arg_id ->
+ go ((arg_binds `snocOL` (arg_id,arg')) `appOL` binds)
+ (Var arg_id : rev_args) args
+ }
+ where
+ arg_ty = exprType arg
+ can_float_arg = is_strict
+ || not (isUnLiftedType arg_ty)
+ || (ok_float_unlifted && exprOkForSpeculation arg)
+
+addAtomicBinds :: SimplEnv -> [(OutId,OutExpr)]
+ -> (SimplEnv -> SimplM (FloatsWith a))
+ -> SimplM (FloatsWith a)
+addAtomicBinds env [] thing_inside = thing_inside env
+addAtomicBinds env ((v,r):bs) thing_inside = addAuxiliaryBind env (NonRec v r) $ \ env ->
+ addAtomicBinds env bs thing_inside
+
+addAtomicBindsE :: SimplEnv -> [(OutId,OutExpr)]
+ -> (SimplEnv -> SimplM FloatsWithExpr)
+ -> SimplM FloatsWithExpr
+-- Same again, but this time we're in an expression context,
+-- and may need to do some case bindings
+
+addAtomicBindsE env [] thing_inside
+ = thing_inside env
+addAtomicBindsE env ((v,r):bs) thing_inside
+ | needsCaseBinding (idType v) r
+ = addAtomicBindsE (addNewInScopeIds env [v]) bs thing_inside `thenSmpl` \ (floats, expr) ->
+ WARN( exprIsTrivial expr, ppr v <+> pprCoreExpr expr )
+ returnSmpl (emptyFloats env, Case r v [(DEFAULT,[], wrapFloats floats expr)])
-rebuild_strict [] True fun fun_ty cont = rebuild_bot fun fun_ty cont
-rebuild_strict [] False fun fun_ty cont = do_rebuild fun cont
+ | otherwise
+ = addAuxiliaryBind env (NonRec v r) $ \ env ->
+ addAtomicBindsE env bs thing_inside
+\end{code}
-rebuild_strict ds result_bot fun fun_ty (ApplyTo _ (Type ty_arg) se cont)
- -- Type arg; don't consume a demand
- = setSubstEnv se (simplType ty_arg) `thenSmpl` \ ty_arg' ->
- rebuild_strict ds result_bot (App fun (Type ty_arg'))
- (applyTy fun_ty ty_arg') cont
-rebuild_strict (d:ds) result_bot fun fun_ty (ApplyTo _ val_arg se cont)
- | isStrict d || isUnLiftedType arg_ty -- Strict value argument
- = getInScope `thenSmpl` \ in_scope ->
- let
- cont_ty = contResultType in_scope res_ty cont
- in
- setSubstEnv se (simplExprB val_arg (ArgOf NoDup cont_fn cont_ty))
+%************************************************************************
+%* *
+\subsection{The main rebuilder}
+%* *
+%************************************************************************
- | otherwise -- Lazy value argument
- = setSubstEnv se (simplArg val_arg) `thenSmpl` \ val_arg' ->
- cont_fn val_arg'
+\begin{code}
+rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM FloatsWithExpr
- where
- Just (arg_ty, res_ty) = splitFunTy_maybe fun_ty
- cont_fn arg' = rebuild_strict ds result_bot
- (App fun arg') res_ty
- cont
+rebuild env expr (Stop _ _ _) = rebuildDone env expr
+rebuild env expr (ArgOf _ _ _ cont_fn) = cont_fn env expr
+rebuild env expr (CoerceIt to_ty cont) = rebuild env (mkCoerce to_ty (exprType expr) expr) cont
+rebuild env expr (InlinePlease cont) = rebuild env (Note InlineCall expr) cont
+rebuild env expr (Select _ bndr alts se cont) = rebuildCase (setInScope se env) expr bndr alts cont
+rebuild env expr (ApplyTo _ arg se cont) = rebuildApp (setInScope se env) expr arg cont
-rebuild_strict ds result_bot fun fun_ty cont = do_rebuild fun cont
+rebuildApp env fun arg cont
+ = simplExpr env arg `thenSmpl` \ arg' ->
+ rebuild env (App fun arg') cont
----------------------------------------------------------
--- Dealing with
--- * case (error "hello") of { ... }
--- * (error "Hello") arg
--- etc
-
-rebuild_bot expr expr_ty Stop -- No coerce needed
- = rebuild_done expr
-
-rebuild_bot expr expr_ty (CoerceIt _ to_ty se Stop) -- Don't "tick" on this,
- -- else simplifier never stops
- = setSubstEnv se $
- simplType to_ty `thenSmpl` \ to_ty' ->
- rebuild_done (mkNote (Coerce to_ty' expr_ty) expr)
-
-rebuild_bot expr expr_ty cont
- = tick CaseOfError `thenSmpl_`
- getInScope `thenSmpl` \ in_scope ->
- let
- result_ty = contResultType in_scope expr_ty cont
- in
- rebuild_done (mkNote (Coerce result_ty expr_ty) expr)
+rebuildDone env expr = returnSmpl (emptyFloats env, expr)
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Functions dealing with a case}
+%* *
+%************************************************************************
+
Blob of helper functions for the "case-of-something-else" situation.
\begin{code}
---------------------------------------------------------
--- Case of something else
+-- Eliminate the case if possible
+
+rebuildCase :: SimplEnv
+ -> OutExpr -- Scrutinee
+ -> InId -- Case binder
+ -> [InAlt] -- Alternatives
+ -> SimplCont
+ -> SimplM FloatsWithExpr
-rebuild_case sw_chkr scrut case_bndr alts se cont
+rebuildCase env scrut case_bndr alts cont
+ | Just (con,args) <- exprIsConApp_maybe scrut
+ -- Works when the scrutinee is a variable with a known unfolding
+ -- as well as when it's an explicit constructor application
+ = knownCon env (DataAlt con) args case_bndr alts cont
+
+ | Lit lit <- scrut -- No need for same treatment as constructors
+ -- because literals are inlined more vigorously
+ = knownCon env (LitAlt lit) [] case_bndr alts cont
+
+ | otherwise
= -- Prepare case alternatives
- prepareCaseAlts (splitTyConApp_maybe (idType case_bndr))
- scrut_cons alts `thenSmpl` \ better_alts ->
-
- -- Set the new subst-env in place (before dealing with the case binder)
- setSubstEnv se $
+ -- Filter out alternatives that can't possibly match
+ let
+ impossible_cons = case scrut of
+ Var v -> otherCons (idUnfolding v)
+ other -> []
+ better_alts = case impossible_cons of
+ [] -> alts
+ other -> [alt | alt@(con,_,_) <- alts,
+ not (con `elem` impossible_cons)]
+ in
-- Deal with the case binder, and prepare the continuation;
-- The new subst_env is in place
- simplBinder case_bndr $ \ case_bndr' ->
- prepareCaseCont better_alts cont $ \ cont' ->
-
+ prepareCaseCont env better_alts cont `thenSmpl` \ (floats, cont') ->
+ addFloats env floats $ \ env ->
-- Deal with variable scrutinee
- substForVarScrut scrut case_bndr' $ \ zap_occ_info ->
- let
- case_bndr'' = zap_occ_info case_bndr'
- in
-
- -- Deal with the case alternaatives
- simplAlts zap_occ_info scrut_cons
- case_bndr'' better_alts cont' `thenSmpl` \ alts' ->
+ simplCaseBinder env scrut case_bndr `thenSmpl` \ (alt_env, case_bndr', zap_occ_info) ->
- mkCase sw_chkr scrut case_bndr'' alts' `thenSmpl` \ case_expr ->
- rebuild_done case_expr
- where
- -- scrut_cons tells what constructors the scrutinee can't possibly match
- scrut_cons = case scrut of
- Var v -> case getIdUnfolding v of
- OtherCon cons -> cons
- other -> []
- other -> []
+ -- Deal with the case alternatives
+ simplAlts alt_env zap_occ_info impossible_cons
+ case_bndr' better_alts cont' `thenSmpl` \ alts' ->
+ -- Put the case back together
+ mkCase scrut case_bndr' alts' `thenSmpl` \ case_expr ->
-knownCon expr con args (Select _ bndr alts se cont)
- = tick KnownBranch `thenSmpl_`
- setSubstEnv se (
- case findAlt con alts of
- (DEFAULT, bs, rhs) -> ASSERT( null bs )
- completeBindNonRec bndr expr $
- simplExprB rhs cont
-
- (Literal lit, bs, rhs) -> ASSERT( null bs )
- extendIdSubst bndr (Done expr) $
- -- Unconditionally substitute, because expr must
- -- be a variable or a literal. It can't be a
- -- NoRep literal because they don't occur in
- -- case patterns.
- simplExprB rhs cont
-
- (DataCon dc, bs, rhs) -> completeBindNonRec bndr expr $
- extend bs real_args $
- simplExprB rhs cont
- where
- real_args = drop (dataConNumInstArgs dc) args
- )
- where
- extend [] [] thing_inside = thing_inside
- extend (b:bs) (arg:args) thing_inside = extendIdSubst b (Done arg) $
- extend bs args thing_inside
+ -- Notice that rebuildDone returns the in-scope set from env, not alt_env
+ -- The case binder *not* scope over the whole returned case-expression
+ rebuildDone env case_expr
\end{code}
-\begin{code}
-prepareCaseCont :: [InAlt] -> SimplCont
- -> (SimplCont -> SimplM (OutStuff a))
- -> SimplM (OutStuff a)
- -- Polymorphic recursion here!
+simplCaseBinder checks whether the scrutinee is a variable, v. If so,
+try to eliminate uses of v in the RHSs in favour of case_bndr; that
+way, there's a chance that v will now only be used once, and hence
+inlined.
-prepareCaseCont [alt] cont thing_inside = thing_inside cont
-prepareCaseCont alts cont thing_inside = mkDupableCont (coreAltsType alts) cont thing_inside
-\end{code}
+Note 1
+~~~~~~
+There is a time we *don't* want to do that, namely when
+-fno-case-of-case is on. This happens in the first simplifier pass,
+and enhances full laziness. Here's the bad case:
+ f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )
+If we eliminate the inner case, we trap it inside the I# v -> arm,
+which might prevent some full laziness happening. I've seen this
+in action in spectral/cichelli/Prog.hs:
+ [(m,n) | m <- [1..max], n <- [1..max]]
+Hence the check for NoCaseOfCase.
+
+Note 2
+~~~~~~
+There is another situation when we don't want to do it. If we have
+
+ case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }
+ ...other cases .... }
+
+We'll perform the binder-swap for the outer case, giving
+
+ case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }
+ ...other cases .... }
+
+But there is no point in doing it for the inner case,
+because w1 can't be inlined anyway. Furthermore, doing the case-swapping
+involves zapping w2's occurrence info (see paragraphs that follow),
+and that forces us to bind w2 when doing case merging. So we get
+
+ case x of w1 { A -> let w2 = w1 in e1
+ B -> let w2 = w1 in e2
+ ...other cases .... }
+
+This is plain silly in the common case where w2 is dead.
-substForVarScrut checks whether the scrutinee is a variable, v.
-If so, try to eliminate uses of v in the RHSs in favour of case_bndr;
-that way, there's a chance that v will now only be used once, and hence inlined.
+Even so, I can't see a good way to implement this idea. I tried
+not doing the binder-swap if the scrutinee was already evaluated
+but that failed big-time:
-If we do this, then we have to nuke any occurrence info (eg IAmDead)
-in the case binder, because the case-binder now effectively occurs
-whenever v does. AND we have to do the same for the pattern-bound
-variables! Example:
+ data T = MkT !Int
+
+ case v of w { MkT x ->
+ case x of x1 { I# y1 ->
+ case x of x2 { I# y2 -> ...
+
+Notice that because MkT is strict, x is marked "evaluated". But to
+eliminate the last case, we must either make sure that x (as well as
+x1) has unfolding MkT y1. THe straightforward thing to do is to do
+the binder-swap. So this whole note is a no-op.
+
+Note 3
+~~~~~~
+If we replace the scrutinee, v, by tbe case binder, then we have to nuke
+any occurrence info (eg IAmDead) in the case binder, because the
+case-binder now effectively occurs whenever v does. AND we have to do
+the same for the pattern-bound variables! Example:
(case x of { (a,b) -> a }) (case x of { (p,q) -> q })
Here, b and p are dead. But when we move the argment inside the first
case RHS, and eliminate the second case, we get
- case x or { (a,b) -> a b
+ case x or { (a,b) -> a b }
Urk! b is alive! Reason: the scrutinee was a variable, and case elimination
-happened. Hence the zap_occ_info function returned by substForVarScrut
+happened. Hence the zap_occ_info function returned by simplCaseBinder
\begin{code}
-substForVarScrut (Var v) case_bndr' thing_inside
- | isLocallyDefined v -- No point for imported things
- = modifyInScope (v `setIdUnfolding` mkUnfolding (Var case_bndr')
- `setInlinePragma` IMustBeINLINEd) $
+simplCaseBinder env (Var v) case_bndr
+ | not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
+
+-- Failed try [see Note 2 above]
+-- not (isEvaldUnfolding (idUnfolding v))
+
+ = simplBinder env (zap case_bndr) `thenSmpl` \ (env, case_bndr') ->
+ returnSmpl (modifyInScope env v case_bndr', case_bndr', zap)
-- We could extend the substitution instead, but it would be
-- a hack because then the substitution wouldn't be idempotent
- -- any more.
- thing_inside (\ bndr -> bndr `setInlinePragma` NoInlinePragInfo)
+ -- any more (v is an OutId). And this just just as well.
+ where
+ zap b = b `setIdOccInfo` NoOccInfo
-substForVarScrut other_scrut case_bndr' thing_inside
- = thing_inside (\ bndr -> bndr) -- NoOp on bndr
+simplCaseBinder env other_scrut case_bndr
+ = simplBinder env case_bndr `thenSmpl` \ (env, case_bndr') ->
+ returnSmpl (env, case_bndr', \ bndr -> bndr) -- NoOp on bndr
\end{code}
-prepareCaseAlts does two things:
-1. Remove impossible alternatives
-
-2. If the DEFAULT alternative can match only one possible constructor,
- then make that constructor explicit.
- e.g.
- case e of x { DEFAULT -> rhs }
- ===>
- case e of x { (a,b) -> rhs }
- where the type is a single constructor type. This gives better code
- when rhs also scrutinises x or e.
\begin{code}
-prepareCaseAlts (Just (tycon, inst_tys)) scrut_cons alts
- | isDataTyCon tycon
- = case (findDefault filtered_alts, missing_cons) of
-
- ((alts_no_deflt, Just rhs), [data_con]) -- Just one missing constructor!
- -> tick FillInCaseDefault `thenSmpl_`
- let
- (_,_,ex_tyvars,_,_,_) = dataConSig data_con
- in
- getUniquesSmpl (length ex_tyvars) `thenSmpl` \ tv_uniqs ->
- let
- ex_tyvars' = zipWithEqual "simpl_alt" mk tv_uniqs ex_tyvars
- mk uniq tv = mkSysTyVar uniq (tyVarKind tv)
- in
- newIds (dataConArgTys
- data_con
- (inst_tys ++ mkTyVarTys ex_tyvars')) $ \ bndrs ->
- returnSmpl ((DataCon data_con, ex_tyvars' ++ bndrs, rhs) : alts_no_deflt)
-
- other -> returnSmpl filtered_alts
- where
- -- Filter out alternatives that can't possibly match
- filtered_alts = case scrut_cons of
- [] -> alts
- other -> [alt | alt@(con,_,_) <- alts, not (con `elem` scrut_cons)]
-
- missing_cons = [data_con | data_con <- tyConDataCons tycon,
- not (data_con `elem` handled_data_cons)]
- handled_data_cons = [data_con | DataCon data_con <- scrut_cons] ++
- [data_con | (DataCon data_con, _, _) <- filtered_alts]
-
--- The default case
-prepareCaseAlts _ scrut_cons alts
- = returnSmpl alts -- Functions
-
-
-----------------------
-simplAlts zap_occ_info scrut_cons case_bndr'' alts cont'
+simplAlts :: SimplEnv
+ -> (InId -> InId) -- Occ-info zapper
+ -> [AltCon] -- Alternatives the scrutinee can't be
+ -> OutId -- Case binder
+ -> [InAlt] -> SimplCont
+ -> SimplM [OutAlt] -- Includes the continuation
+
+simplAlts env zap_occ_info impossible_cons case_bndr' alts cont'
= mapSmpl simpl_alt alts
where
- inst_tys' = case splitTyConApp_maybe (idType case_bndr'') of
- Just (tycon, inst_tys) -> inst_tys
+ inst_tys' = tyConAppArgs (idType case_bndr')
-- handled_cons is all the constructors that are dealt
-- with, either by being impossible, or by there being an alternative
- handled_cons = scrut_cons ++ [con | (con,_,_) <- alts, con /= DEFAULT]
+ (con_alts,_) = findDefault alts
+ handled_cons = impossible_cons ++ [con | (con,_,_) <- con_alts]
simpl_alt (DEFAULT, _, rhs)
- = modifyInScope (case_bndr'' `setIdUnfolding` OtherCon handled_cons) $
- simplExpr rhs cont' `thenSmpl` \ rhs' ->
+ = let
+ -- In the default case we record the constructors that the
+ -- case-binder *can't* be.
+ -- We take advantage of any OtherCon info in the case scrutinee
+ case_bndr_w_unf = case_bndr' `setIdUnfolding` mkOtherCon handled_cons
+ env_with_unf = modifyInScope env case_bndr' case_bndr_w_unf
+ in
+ simplExprC env_with_unf rhs cont' `thenSmpl` \ rhs' ->
returnSmpl (DEFAULT, [], rhs')
simpl_alt (con, vs, rhs)
- = -- Deal with the case-bound variables
+ = -- Deal with the pattern-bound variables
-- Mark the ones that are in ! positions in the data constructor
- -- as certainly-evaluated
- simplBinders (add_evals con vs) $ \ vs' ->
+ -- as certainly-evaluated.
+ -- NB: it happens that simplBinders does *not* erase the OtherCon
+ -- form of unfolding, so it's ok to add this info before
+ -- doing simplBinders
+ simplBinders env (add_evals con vs) `thenSmpl` \ (env, vs') ->
- -- Bind the case-binder to (Con args)
- -- In the default case we record the constructors it *can't* be.
- -- We take advantage of any OtherCon info in the case scrutinee
+ -- Bind the case-binder to (con args)
let
- con_app = Con con (map Type inst_tys' ++ map varToCoreExpr vs')
+ unfolding = mkUnfolding False (mkAltExpr con vs' inst_tys')
+ env_with_unf = modifyInScope env case_bndr' (case_bndr' `setIdUnfolding` unfolding)
in
- modifyInScope (case_bndr'' `setIdUnfolding` mkUnfolding con_app) $
- simplExpr rhs cont' `thenSmpl` \ rhs' ->
+ simplExprC env_with_unf rhs cont' `thenSmpl` \ rhs' ->
returnSmpl (con, vs', rhs')
-- case x of { T a b -> T (a+1) b }
--
-- We really must record that b is already evaluated so that we don't
- -- go and re-evaluated it when constructing the result.
+ -- go and re-evaluate it when constructing the result.
- add_evals (DataCon dc) vs = stretchZipEqual add_eval vs (dataConStrictMarks dc)
+ add_evals (DataAlt dc) vs = cat_evals vs (dataConRepStrictness dc)
add_evals other_con vs = vs
- add_eval v m | isTyVar v = Nothing
- | otherwise = case m of
- MarkedStrict -> Just (zap_occ_info v `setIdUnfolding` OtherCon [])
- NotMarkedStrict -> Just (zap_occ_info v)
+ cat_evals [] [] = []
+ cat_evals (v:vs) (str:strs)
+ | isTyVar v = v : cat_evals vs (str:strs)
+ | isMarkedStrict str = evald_v : cat_evals vs strs
+ | otherwise = zapped_v : cat_evals vs strs
+ where
+ zapped_v = zap_occ_info v
+ evald_v = zapped_v `setIdUnfolding` mkOtherCon []
\end{code}
+%************************************************************************
+%* *
+\subsection{Known constructor}
+%* *
+%************************************************************************
+
+We are a bit careful with occurrence info. Here's an example
+
+ (\x* -> case x of (a*, b) -> f a) (h v, e)
+
+where the * means "occurs once". This effectively becomes
+ case (h v, e) of (a*, b) -> f a)
+and then
+ let a* = h v; b = e in f a
+and then
+ f (h v)
+
+All this should happen in one sweep.
+
+\begin{code}
+knownCon :: SimplEnv -> AltCon -> [OutExpr]
+ -> InId -> [InAlt] -> SimplCont
+ -> SimplM FloatsWithExpr
+
+knownCon env con args bndr alts cont
+ = tick (KnownBranch bndr) `thenSmpl_`
+ case findAlt con alts of
+ (DEFAULT, bs, rhs) -> ASSERT( null bs )
+ simplNonRecX env bndr scrut $ \ env ->
+ -- This might give rise to a binding with non-atomic args
+ -- like x = Node (f x) (g x)
+ -- but no harm will be done
+ simplExprF env rhs cont
+ where
+ scrut = case con of
+ LitAlt lit -> Lit lit
+ DataAlt dc -> mkConApp dc args
+
+ (LitAlt lit, bs, rhs) -> ASSERT( null bs )
+ simplNonRecX env bndr (Lit lit) $ \ env ->
+ simplExprF env rhs cont
+
+ (DataAlt dc, bs, rhs) -> ASSERT( length bs + n_tys == length args )
+ bind_args env bs (drop n_tys args) $ \ env ->
+ let
+ con_app = mkConApp dc (take n_tys args ++ con_args)
+ con_args = [substExpr (getSubst env) (varToCoreExpr b) | b <- bs]
+ -- args are aready OutExprs, but bs are InIds
+ in
+ simplNonRecX env bndr con_app $ \ env ->
+ simplExprF env rhs cont
+ where
+ n_tys = dataConNumInstArgs dc -- Non-existential type args
+-- Ugh!
+bind_args env [] _ thing_inside = thing_inside env
+
+bind_args env (b:bs) (Type ty : args) thing_inside
+ = bind_args (extendSubst env b (DoneTy ty)) bs args thing_inside
+
+bind_args env (b:bs) (arg : args) thing_inside
+ = simplNonRecX env b arg $ \ env ->
+ bind_args env bs args thing_inside
+\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-mkDupableCont :: InType -- Type of the thing to be given to the continuation
+prepareCaseCont :: SimplEnv
+ -> [InAlt] -> SimplCont
+ -> SimplM (FloatsWith SimplCont) -- Return a duplicatable continuation,
+ -- plus some extra bindings
+
+prepareCaseCont env [alt] cont = returnSmpl (emptyFloats env, cont)
+ -- No need to make it duplicatable if there's only one alternative
+
+prepareCaseCont env alts cont = simplType env (coreAltsType alts) `thenSmpl` \ alts_ty ->
+ mkDupableCont env alts_ty cont
+ -- At one time I passed in the un-simplified type, and simplified
+ -- it only if we needed to construct a join binder, but that
+ -- didn't work because we have to decompse function types
+ -- (using funResultTy) in mkDupableCont.
+\end{code}
+
+\begin{code}
+mkDupableCont :: SimplEnv
+ -> OutType -- Type of the thing to be given to the continuation
-> SimplCont
- -> (SimplCont -> SimplM (OutStuff a))
- -> SimplM (OutStuff a)
-mkDupableCont ty cont thing_inside
+ -> SimplM (FloatsWith SimplCont) -- Return a duplicatable continuation,
+ -- plus some extra bindings
+
+mkDupableCont env ty cont
| contIsDupable cont
- = thing_inside cont
-
-mkDupableCont _ (CoerceIt _ ty se cont) thing_inside
- = mkDupableCont ty cont $ \ cont' ->
- thing_inside (CoerceIt OkToDup ty se cont')
-
-mkDupableCont join_arg_ty (ArgOf _ cont_fn res_ty) thing_inside
- = -- Build the RHS of the join point
- simplType join_arg_ty `thenSmpl` \ join_arg_ty' ->
- newId join_arg_ty' ( \ arg_id ->
- getSwitchChecker `thenSmpl` \ chkr ->
- cont_fn (Var arg_id) `thenSmpl` \ (binds, (_, rhs)) ->
- returnSmpl (Lam arg_id (mkLetBinds binds rhs))
- ) `thenSmpl` \ join_rhs ->
-
+ = returnSmpl (emptyFloats env, cont)
+
+mkDupableCont env _ (CoerceIt ty cont)
+ = mkDupableCont env ty cont `thenSmpl` \ (floats, cont') ->
+ returnSmpl (floats, CoerceIt ty cont')
+
+mkDupableCont env ty (InlinePlease cont)
+ = mkDupableCont env ty cont `thenSmpl` \ (floats, cont') ->
+ returnSmpl (floats, InlinePlease cont')
+
+mkDupableCont env join_arg_ty (ArgOf _ is_rhs cont_ty cont_fn)
+ = -- e.g. (...strict-fn...) [...hole...]
+ -- ==>
+ -- let $j = \a -> ...strict-fn...
+ -- in $j [...hole...]
+
-- Build the join Id and continuation
- newId (coreExprType join_rhs) $ \ join_id ->
+ -- We give it a "$j" name just so that for later amusement
+ -- we can identify any join points that don't end up as let-no-escapes
+ -- [NOTE: the type used to be exprType join_rhs, but this seems more elegant.]
+ newId SLIT("$j") (mkFunTy join_arg_ty cont_ty) `thenSmpl` \ join_id ->
+ newId SLIT("a") join_arg_ty `thenSmpl` \ arg_id ->
+
+ cont_fn (addNewInScopeIds env [arg_id]) (Var arg_id) `thenSmpl` \ (floats, rhs) ->
let
- new_cont = ArgOf OkToDup
- (\arg' -> rebuild_done (App (Var join_id) arg'))
- res_ty
+ cont_fn env arg' = rebuildDone env (App (Var join_id) arg')
+ join_rhs = Lam (setOneShotLambda arg_id) (wrapFloats floats rhs)
in
-
- -- Do the thing inside
- thing_inside new_cont `thenSmpl` \ res ->
- returnSmpl (addBind (NonRec join_id join_rhs) res)
-mkDupableCont ty (ApplyTo _ arg se cont) thing_inside
- = mkDupableCont (funResultTy ty) cont $ \ cont' ->
- setSubstEnv se (simplArg arg) `thenSmpl` \ arg' ->
+ tick (CaseOfCase join_id) `thenSmpl_`
+ -- Want to tick here so that we go round again,
+ -- and maybe copy or inline the code;
+ -- not strictly CaseOf Case
+
+ returnSmpl (unitFloat env join_id join_rhs,
+ ArgOf OkToDup is_rhs cont_ty cont_fn)
+
+mkDupableCont env ty (ApplyTo _ arg se cont)
+ = -- e.g. [...hole...] (...arg...)
+ -- ==>
+ -- let a = ...arg...
+ -- in [...hole...] a
+ mkDupableCont env (funResultTy ty) cont `thenSmpl` \ (floats, cont') ->
+ addFloats env floats $ \ env ->
+
+ simplExpr (setInScope se env) arg `thenSmpl` \ arg' ->
if exprIsDupable arg' then
- thing_inside (ApplyTo OkToDup arg' emptySubstEnv cont')
+ returnSmpl (emptyFloats env, ApplyTo OkToDup arg' (zapSubstEnv se) cont')
else
- newId (coreExprType arg') $ \ bndr ->
- thing_inside (ApplyTo OkToDup (Var bndr) emptySubstEnv cont') `thenSmpl` \ res ->
- returnSmpl (addBind (NonRec bndr arg') res)
-
-mkDupableCont ty (Select _ case_bndr alts se cont) thing_inside
- = tick CaseOfCase `thenSmpl_` (
- setSubstEnv se (
- simplBinder case_bndr $ \ case_bndr' ->
- prepareCaseCont alts cont $ \ cont' ->
- mapAndUnzipSmpl (mkDupableAlt case_bndr' cont') alts `thenSmpl` \ (alt_binds_s, alts') ->
- returnSmpl (concat alt_binds_s, (case_bndr', alts'))
- ) `thenSmpl` \ (alt_binds, (case_bndr', alts')) ->
-
- extendInScopes [b | NonRec b _ <- alt_binds] $
- thing_inside (Select OkToDup case_bndr' alts' emptySubstEnv Stop) `thenSmpl` \ res ->
- returnSmpl (addBinds alt_binds res)
- )
-
-mkDupableAlt :: OutId -> SimplCont -> InAlt -> SimplM (OutStuff CoreAlt)
-mkDupableAlt case_bndr' cont alt@(con, bndrs, rhs)
- = simplBinders bndrs $ \ bndrs' ->
- simplExpr rhs cont `thenSmpl` \ rhs' ->
+ newId SLIT("a") (exprType arg') `thenSmpl` \ arg_id ->
+
+ tick (CaseOfCase arg_id) `thenSmpl_`
+ -- Want to tick here so that we go round again,
+ -- and maybe copy or inline the code.
+ -- Not strictly CaseOfCase, but never mind
+
+ returnSmpl (unitFloat env arg_id arg',
+ ApplyTo OkToDup (Var arg_id) (zapSubstEnv se) cont')
+ -- But what if the arg should be case-bound?
+ -- This has been this way for a long time, so I'll leave it,
+ -- but I can't convince myself that it's right.
+
+
+mkDupableCont env ty (Select _ case_bndr alts se cont)
+ = -- e.g. (case [...hole...] of { pi -> ei })
+ -- ===>
+ -- let ji = \xij -> ei
+ -- in case [...hole...] of { pi -> ji xij }
+ tick (CaseOfCase case_bndr) `thenSmpl_`
+ let
+ alt_env = setInScope se env
+ in
+ prepareCaseCont alt_env alts cont `thenSmpl` \ (floats1, dupable_cont) ->
+ addFloats alt_env floats1 $ \ alt_env ->
+
+ simplBinder alt_env case_bndr `thenSmpl` \ (alt_env, case_bndr') ->
+ -- NB: simplBinder does not zap deadness occ-info, so
+ -- a dead case_bndr' will still advertise its deadness
+ -- This is really important because in
+ -- case e of b { (# a,b #) -> ... }
+ -- b is always dead, and indeed we are not allowed to bind b to (# a,b #),
+ -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.
+ -- In the new alts we build, we have the new case binder, so it must retain
+ -- its deadness.
+
+ mkDupableAlts alt_env case_bndr' alts dupable_cont `thenSmpl` \ (floats2, alts') ->
+ addFloats alt_env floats2 $ \ alt_env ->
+ returnSmpl (emptyFloats alt_env, Select OkToDup case_bndr' alts' (zapSubstEnv se)
+ (mkBoringStop (contResultType cont)))
+
+mkDupableAlts :: SimplEnv -> OutId -> [InAlt] -> SimplCont
+ -> SimplM (FloatsWith [InAlt])
+-- Absorbs the continuation into the new alternatives
+
+mkDupableAlts env case_bndr' alts dupable_cont
+ = go env alts
+ where
+ go env [] = returnSmpl (emptyFloats env, [])
+ go env (alt:alts)
+ = mkDupableAlt env case_bndr' dupable_cont alt `thenSmpl` \ (floats1, alt') ->
+ addFloats env floats1 $ \ env ->
+ go env alts `thenSmpl` \ (floats2, alts') ->
+ returnSmpl (floats2, alt' : alts')
+
+mkDupableAlt env case_bndr' cont alt@(con, bndrs, rhs)
+ = simplBinders env bndrs `thenSmpl` \ (env, bndrs') ->
+ simplExprC env rhs cont `thenSmpl` \ rhs' ->
+
if exprIsDupable rhs' then
- -- It's small, so don't bother to let-bind it
- returnSmpl ([], (con, bndrs', rhs'))
+ returnSmpl (emptyFloats env, (con, bndrs', rhs'))
+ -- It is worth checking for a small RHS because otherwise we
+ -- get extra let bindings that may cause an extra iteration of the simplifier to
+ -- inline back in place. Quite often the rhs is just a variable or constructor.
+ -- The Ord instance of Maybe in PrelMaybe.lhs, for example, took several extra
+ -- iterations because the version with the let bindings looked big, and so wasn't
+ -- inlined, but after the join points had been inlined it looked smaller, and so
+ -- was inlined.
+ --
+ -- NB: we have to check the size of rhs', not rhs.
+ -- Duplicating a small InAlt might invalidate occurrence information
+ -- However, if it *is* dupable, we return the *un* simplified alternative,
+ -- because otherwise we'd need to pair it up with an empty subst-env....
+ -- but we only have one env shared between all the alts.
+ -- (Remember we must zap the subst-env before re-simplifying something).
+ -- Rather than do this we simply agree to re-simplify the original (small) thing later.
+
else
- -- It's big, so let-bind it
let
- rhs_ty' = coreExprType rhs'
+ rhs_ty' = exprType rhs'
used_bndrs' = filter (not . isDeadBinder) (case_bndr' : bndrs')
+ -- The deadness info on the new binders is unscathed
in
- ( if null used_bndrs' && isUnLiftedType rhs_ty'
- then newId realWorldStatePrimTy $ \ rw_id ->
- returnSmpl ([rw_id], [varToCoreExpr realWorldPrimId])
- else
- returnSmpl (used_bndrs', map varToCoreExpr used_bndrs')
- )
- `thenSmpl` \ (final_bndrs', final_args) ->
-
-- If we try to lift a primitive-typed something out
-- for let-binding-purposes, we will *caseify* it (!),
-- with potentially-disastrous strictness results. So
-- case_bndr to all the join points if it's used in *any* RHS,
-- because we don't know its usage in each RHS separately
- newId (foldr (mkFunTy . idType) rhs_ty' final_bndrs') $ \ join_bndr ->
- returnSmpl ([NonRec join_bndr (mkLams final_bndrs' rhs')],
- (con, bndrs', mkApps (Var join_bndr) final_args))
+ -- We used to say "&& isUnLiftedType rhs_ty'" here, but now
+ -- we make the join point into a function whenever used_bndrs'
+ -- is empty. This makes the join-point more CPR friendly.
+ -- Consider: let j = if .. then I# 3 else I# 4
+ -- in case .. of { A -> j; B -> j; C -> ... }
+ --
+ -- Now CPR doesn't w/w j because it's a thunk, so
+ -- that means that the enclosing function can't w/w either,
+ -- which is a lose. Here's the example that happened in practice:
+ -- kgmod :: Int -> Int -> Int
+ -- kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
+ -- then 78
+ -- else 5
+ --
+ -- I have seen a case alternative like this:
+ -- True -> \v -> ...
+ -- It's a bit silly to add the realWorld dummy arg in this case, making
+ -- $j = \s v -> ...
+ -- True -> $j s
+ -- (the \v alone is enough to make CPR happy) but I think it's rare
+
+ ( if null used_bndrs'
+ then newId SLIT("w") realWorldStatePrimTy `thenSmpl` \ rw_id ->
+ returnSmpl ([rw_id], [Var realWorldPrimId])
+ else
+ returnSmpl (used_bndrs', map varToCoreExpr used_bndrs')
+ ) `thenSmpl` \ (final_bndrs', final_args) ->
+
+ -- See comment about "$j" name above
+ newId SLIT("$j") (foldr mkPiType rhs_ty' final_bndrs') `thenSmpl` \ join_bndr ->
+ -- Notice the funky mkPiType. If the contructor has existentials
+ -- it's possible that the join point will be abstracted over
+ -- type varaibles as well as term variables.
+ -- Example: Suppose we have
+ -- data T = forall t. C [t]
+ -- Then faced with
+ -- case (case e of ...) of
+ -- C t xs::[t] -> rhs
+ -- We get the join point
+ -- let j :: forall t. [t] -> ...
+ -- j = /\t \xs::[t] -> rhs
+ -- in
+ -- case (case e of ...) of
+ -- C t xs::[t] -> j t xs
+
+ let
+ -- We make the lambdas into one-shot-lambdas. The
+ -- join point is sure to be applied at most once, and doing so
+ -- prevents the body of the join point being floated out by
+ -- the full laziness pass
+ really_final_bndrs = map one_shot final_bndrs'
+ one_shot v | isId v = setOneShotLambda v
+ | otherwise = v
+ join_rhs = mkLams really_final_bndrs rhs'
+ join_call = mkApps (Var join_bndr) final_args
+ in
+ returnSmpl (unitFloat env join_bndr join_rhs, (con, bndrs', join_call))
\end{code}