X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplify.lhs;h=2bc7b8ba80fde18fc1b093e28bd91b83e707592a;hb=6858f7c15fcf9efe9e6fdf22de34d0791b0f0c08;hp=6490d50a1d1633eb04a94312196ecc9a6dea8d17;hpb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 6490d50..2bc7b8b 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -4,907 +4,1145 @@ \section[Simplify]{The main module of the simplifier} \begin{code} -module Simplify ( simplExpr, simplBind ) where +module Simplify ( simplTopBinds, simplExpr ) where #include "HsVersions.h" -import CmdLineOpts ( switchIsOn, opt_SccProfilingOn, - 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, - setInlinePragma, getInlinePragma, idMustBeINLINEd, - idWantsToBeINLINEd +import Id ( Id, idType, idInfo, idArity, isDataConId, + idUnfolding, setIdUnfolding, isDeadBinder, + idNewDemandInfo, setIdInfo, + setIdOccInfo, + zapLamIdInfo, setOneShotLambda, ) -import IdInfo ( InlinePragInfo(..), OccInfo(..), - ArityInfo, atLeastArity, arityLowerBound, unknownArity +import IdInfo ( OccInfo(..), isLoopBreaker, + setArityInfo, + setUnfoldingInfo, + occInfo ) -import Demand ( Demand, isStrict, wwLazy ) -import Const ( isWHNFCon, conOkForAlt ) -import ConFold ( cleverMkPrimApp ) -import PrimOp ( PrimOp ) -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, 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 Subst ( mkSubst, substTy, substExpr, + isInScope, lookupIdSubst, simplIdInfo ) -import SpecEnv ( lookupSpecEnv, isEmptySpecEnv, substSpecEnv ) -import CostCentre ( isSubsumedCCS, currentCCS, isEmptyCC ) -import Type ( Type, mkTyVarTy, mkTyVarTys, isUnLiftedType, fullSubstTy, applyTys, - mkFunTy, splitFunTys, splitTyConApp_maybe, funResultTy ) -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} -simplExpr :: CoreExpr -> SimplCont -> SimplM CoreExpr -simplExpr (Note InlineCall (Var v)) cont - = simplVar True v cont +----------------------------------------- + *** 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. -simplExpr (Var v) cont - = simplVar False v cont +All "floats" are let-binds, not case-binds, but some non-rec lets may +be unlifted (with RHS ok-for-speculation). -simplExpr (Con (PrimOp op) args) cont - = mapSmpl simplArg args `thenSmpl` \ args' -> - rebuild (cleverMkPrimApp op args') cont -simplExpr (Con con@(DataCon _) args) cont - = simplConArgs args $ \ args' -> - rebuild (Con con args') cont -simplExpr expr@(Con con@(Literal _) args) cont - = ASSERT( null args ) - rebuild expr cont +----------------------------------------- + ORGANISATION OF FUNCTIONS +----------------------------------------- +simplTopBinds + - simplify all top-level binders + - for NonRec, call simplRecOrTopPair + - for Rec, call simplRecBind -simplExpr (App fun arg) cont - = getSubstEnv `thenSmpl` \ se -> - simplExpr fun (ApplyTo NoDup arg se cont) + + ------------------------------ +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) -simplExpr (Case scrut bndr alts) cont - = getSubstEnv `thenSmpl` \ se -> - simplExpr scrut (Select NoDup bndr alts se cont) +It's harder to make the rule match if we ANF-ise the constructor, +or eta-expand the PAP: -simplExpr (Note (Coerce to from) e) cont - | to == from = simplExpr e cont - | otherwise = getSubstEnv `thenSmpl` \ se -> - simplExpr e (CoerceIt NoDup to se cont) + f (let { a = g x; b = h x } in (a,b)) + g (\y. + x y) --- hack: we only distinguish subsumed cost centre stacks for the purposes of --- inlining. All other CCCSs are mapped to currentCCS. -simplExpr (Note (SCC cc) e) cont - = setEnclosingCC currentCCS $ - simplExpr e Stop `thenSmpl` \ e -> - rebuild (mkNote (SCC cc) e) cont - -simplExpr (Note note e) cont - = simplExpr e Stop `thenSmpl` \ e' -> - rebuild (mkNote note e') cont - --- Let to case, but only if the RHS isn't a WHNF -simplExpr (Let (NonRec bndr rhs) body) cont - = getSubstEnv `thenSmpl` \ se -> - simplBeta bndr rhs se body cont - -simplExpr (Let bind body) cont - = (simplBind bind $ - simplExpr body cont) `thenSmpl` \ (binds', e') -> - returnSmpl (mkLets binds' e') - --- Type-beta reduction -simplExpr 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' $ - simplExpr body body_cont - --- Ordinary beta reduction -simplExpr 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 +On the other hand if we see the let-defns -simplExpr (Lam bndr body) cont - = simplBinder bndr $ \ bndr' -> - simplExpr body Stop `thenSmpl` \ body' -> - rebuild (Lam bndr' body') cont + p = (g x, h x) + q = + x +then we *do* want to ANF-ise and eta-expand, so that p and q +can be safely inlined. -simplExpr (Type ty) cont - = ASSERT( case cont of { Stop -> True; other -> False } ) - simplType ty `thenSmpl` \ ty' -> - returnSmpl (Type ty') -\end{code} +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 + r = let x = e in (x,x) ---------------------------------- -\begin{code} -simplArg :: InArg -> SimplM OutArg -simplArg arg = simplExpr arg Stop -\end{code} +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. ---------------------------------- -simplConArgs makes sure that the arguments all end up being atomic. -That means it may generate some Lets, hence the +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. -\begin{code} -simplConArgs :: [InArg] -> ([OutArg] -> SimplM CoreExpr) -> SimplM CoreExpr -simplConArgs [] thing_inside - = thing_inside [] -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. +Eta expansion +~~~~~~~~~~~~~~ +For eta expansion, we want to catch things like - simplConArgs args $ \ args' -> + case e of (a,b) -> \x -> case a of (p,q) -> \y -> r - -- 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 (bindNonRec arg_id arg' res) -\end{code} +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. ---------------------------------- -\begin{code} -simplType :: InType -> SimplM OutType -simplType ty - = getTyEnv `thenSmpl` \ (ty_subst, in_scope) -> - returnSmpl (fullSubstTy ty_subst in_scope ty) -\end{code} +%************************************************************************ +%* * +\subsection{Bindings} +%* * +%************************************************************************ \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 - +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 - inline_prag = getInlinePragma bndr - demand = getIdDemandInfo bndr - - safe_info = is_safe_inline_prag && not (isStrict demand) - - is_safe_inline_prag = case inline_prag of - ICanSafelyBeINLINEd StrictOcc nalts -> False - ICanSafelyBeINLINEd LazyOcc nalts -> False - other -> True - - safe_inline_prag = case inline_prag of - ICanSafelyBeINLINEd _ nalts - -> ICanSafelyBeINLINEd InsideLam nalts - other -> inline_prag - - 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 + -- 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{Variables} +\subsection{simplNonRec} %* * %************************************************************************ -Coercions -~~~~~~~~~ +simplNonRecBind is used for + * non-top-level non-recursive lets in expressions + * beta reduction + +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 + +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...) + +It needs to turn unlifted bindings into a @case@. They can arise +from, say: (\x -> e) (4# + 3#) + \begin{code} -simplVar inline_call var cont - = getValEnv `thenSmpl` \ (id_subst, in_scope) -> - case lookupVarEnv id_subst var of - Just (Done e) - -> zapSubstEnv (simplExpr e cont) - - Just (SubstMe e ty_subst id_subst) - -> setSubstEnv (ty_subst, id_subst) (simplExpr e cont) - - Nothing -> let - var' = case lookupVarSet in_scope var of - Just v' -> v' - Nothing -> +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 - 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 - | 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 - - simplExpr 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 && 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) $ - simplExpr unf_template cont - else -#endif - simplExpr unf_template cont - ) - else -#ifdef DEBUG - pprTrace "Inlining disallowed due to CC:\n" (ppr encl_cc <+> ppr unf_template <+> ppr (coreExprCc unf_template)) $ +simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside + | isTyVar bndr + = pprPanic "simplNonRecBind" (ppr bndr <+> ppr rhs) #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 +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. + +\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 - = rebuild (Var var) cont + = simplBinder env bndr `thenSmpl` \ (env, bndr') -> + completeNonRecX env bndr bndr' new_rhs thing_inside - where - unfolding = getIdUnfolding var - - ---------- 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 - - -- overrides cost-centre business - must_be_unfolded = case getInlinePragma var of - IMustBeINLINEd -> True - _ -> False - - CoreUnfolding form guidance unf_template = unfolding - - 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 - ok_to_inline = okToInline essential_unfoldings_only is_case_scrutinee var form guidance cont - essential_unfoldings_only = switchIsOn sw_chkr EssentialUnfoldingsOnly - - 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} +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 + = completeLazyBind env NotTopLevel + old_bndr new_bndr new_rhs `thenSmpl` \ (floats, env) -> + addFloats env floats thing_inside +\end{code} %************************************************************************ %* * -\subsection{Bindings} +\subsection{Lazy bindings} %* * %************************************************************************ +simplRecBind is used for + * recursive bindings only + \begin{code} -simplBind :: CoreBind -> SimplM a -> SimplM ([CoreBind], a) +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} -simplBind (NonRec bndr rhs) thing_inside - = simplTopRhs bndr rhs `thenSmpl` \ (binds, rhs', arity, in_scope) -> - setInScope in_scope $ - completeBindNonRec (bndr `setIdArity` arity) rhs' thing_inside `thenSmpl` \ (maybe_bind, res) -> + +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} +simplRecOrTopPair :: SimplEnv + -> TopLevelFlag + -> InId -> OutId -- Binder, both pre-and post simpl + -> InExpr -- The RHS and its environment + -> SimplM (FloatsWith SimplEnv) + +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)) + + | otherwise + = simplLazyBind env top_lvl Recursive bndr bndr' rhs env + -- May not actually be recursive, but it doesn't matter +\end{code} + + +simplLazyBind is used for + * recursive bindings (whether top level or not) + * top-level non-recursive bindings + * non-top-level *lazy* non-recursive bindings + +[Thus it deals with the lazy cases from simplNonRecBind, and all cases +from SimplRecOrTopBind] + +Nota bene: + 1. It assumes that the binder is *already* simplified, + and is in scope, but not its IdInfo + + 2. It assumes that the binder type is lifted. + + 3. It does not check for pre-inline-unconditionallly; + that should have been done already. + +\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 - binds' = case maybe_bind of - Just (bndr,rhs) -> binds ++ [NonRec bndr rhs] - Nothing -> binds + 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 - returnSmpl (binds', res) + -- 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) -simplBind (Rec 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 + else + completeLazyBind env1 top_lvl bndr bndr'' (wrapFloats floats rhs1) - go (pairs `zip` bndrs') `thenSmpl` \ (pairs', thing') -> - returnSmpl ([Rec pairs'], thing') - where - go [] = thing_inside `thenSmpl` \ res -> - returnSmpl ([], res) +#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{Completing a lazy binding} +%* * +%************************************************************************ - go (((bndr, rhs), bndr') : pairs) - = simplTopRhs bndr rhs `thenSmpl` \ (rhs_binds, rhs', arity, in_scope) -> - setInScope in_scope $ - completeBindRec bndr (bndr' `setIdArity` arity) - rhs' (go pairs) `thenSmpl` \ (pairs', res) -> - returnSmpl (flatten rhs_binds pairs', res) +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 - flatten (NonRec b r : binds) prs = (b,r) : flatten binds prs - flatten (Rec prs1 : binds) prs2 = prs1 ++ flatten binds prs2 - flatten [] prs = prs +It does the following: + - tries discarding a dead binding + - tries PostInlineUnconditionally + - add unfolding [this is the only place we add an unfolding] + - add arity +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). -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 - = tick PostInlineUnconditionally `thenSmpl_` - extendIdSubst bndr (Done etad_rhs) thing_inside +\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 - = -- 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' -\end{code} + = 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} + %************************************************************************ %* * -\subsection{Right hand sides} +\subsection[Simplify-simplExpr]{The main function: simplExpr} %* * %************************************************************************ -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 +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. + +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 + + 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. - * It does eta expansion \begin{code} -simplTopRhs :: InId -> InExpr - -> SimplM ([OutBind], OutExpr, ArityInfo, InScopeEnv) -simplTopRhs bndr rhs - = getSubstEnv `thenSmpl` \ bndr_se -> - simplRhs bndr bndr_se rhs - -simplRhs :: InId -> SubstEnv -> InExpr - -> SimplM ([OutBind], OutExpr, ArityInfo, InScopeEnv) - -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 ([], rhs', unknownArity, in_scope) - - | float_exposes_hnf rhs - = mkRhsTyLam rhs `thenSmpl` \ rhs' -> - -- Swizzle the inner lets past the big lambda (if any) - float rhs' +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 - = finish rhs + = -- 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 - float (Let bind body) = tick LetFloatFromLet `thenSmpl_` - simplBind bind (float body) `thenSmpl` \ (binds1, (binds2, body', arity, in_scope)) -> - returnSmpl (binds1 ++ binds2, body', arity, in_scope) - float body = finish body + case_cont = Select NoDup bndr alts env (mkBoringStop (contResultType cont)) +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 - finish rhs = simplRhs2 bndr bndr_se rhs `thenSmpl` \ (rhs', arity) -> - getInScope `thenSmpl` \ in_scope -> - returnSmpl ([], rhs', arity, in_scope) + simplRecBind env NotTopLevel pairs bndrs' `thenSmpl` \ (floats, env) -> + addFloats env floats $ \ env -> + simplExprF env body cont - float_exposes_hnf (Lam b e) | isTyVar b - = float_exposes_hnf e -- Ignore leading big lambdas - float_exposes_hnf (Let _ e) = try e -- Now look for nested lets - float_exposes_hnf e = False -- Don't bother if no lets! +-- 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 - try (Let _ e) = try e - try e = exprIsWHNF e + +--------------------------------- +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 + new_ty = substTy (getSubst env) ty \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 +%************************************************************************ +%* * +\subsection{Lambdas} +%* * +%************************************************************************ \begin{code} -simplRhs2 bndr bndr_se rhs - = getSwitchChecker `thenSmpl` \ sw_chkr -> - simplBinders tyvars $ \ tyvars' -> - simplBinders ids $ \ ids' -> - - if switchIsOn sw_chkr SimplDoLambdaEtaExpansion - && not (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! - && 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' -> - returnSmpl ( mkLams tyvars' - $ mkLams ids' - $ mkLams extra_bndrs' body', - atLeastArity (no_of_ids + no_of_extras)) - else - simplExpr body Stop `thenSmpl` \ body' -> - returnSmpl ( mkLams tyvars' - $ mkLams ids' body', - atLeastArity no_of_ids) - +simplLam env fun cont + = go env fun cont where - (tyvars, ids, body) = collectTyAndValBinders rhs - no_of_ids = length ids - - 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 + 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 - no_extras_wanted = -- Use information about how many args the fn is applied to - (arity - no_of_ids) `max` + n_params (Note _ e) = n_params e + n_params (Lam b e) = 1 + n_params e + n_params other = 0::Int +\end{code} - -- See if the body could obviously do with more args - etaExpandCount body `max` - -- 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 +%************************************************************************ +%* * +\subsection{Notes} +%* * +%************************************************************************ - arity = arityLowerBound (getIdArity bndr) +\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) - mk_cont [] = Stop - mk_cont (b:bs) = ApplyTo OkToDup (Var b) emptySubstEnv (mk_cont bs) + +-- 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} %************************************************************************ %* * -\subsection{Binding} +\subsection{Dealing with calls} %* * %************************************************************************ \begin{code} -simplBeta :: InId -- Binder - -> InExpr -> SubstEnv -- Arg, with its subst-env - -> InExpr -> SimplCont -- Lambda body - -> SimplM OutExpr -#ifdef DEBUG -simplBeta bndr rhs rhs_se body cont - | isTyVar bndr - = pprPanic "simplBeta" ((ppr bndr <+> ppr rhs) $$ ppr cont) -#endif - -simplBeta bndr rhs rhs_se body cont - | (isStrict (getIdDemandInfo bndr) || is_dict bndr) - && not (exprIsWHNF rhs) - = tick Let2Case `thenSmpl_` - getSubstEnv `thenSmpl` \ body_se -> - setSubstEnv rhs_se $ - simplExpr rhs (Select NoDup bndr [(DEFAULT, [], body)] body_se cont) +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!! - | preInlineUnconditionally bndr && not opt_NoPreInlining - = tick PreInlineUnconditionally `thenSmpl_` - case rhs_se of { (ty_subst, id_subst) -> - extendIdSubst bndr (SubstMe rhs ty_subst id_subst) $ - simplExpr body cont } +--------------------------------------------------------- +-- Dealing with a call - | otherwise - = getSubstEnv `thenSmpl` \ bndr_se -> - setSubstEnv rhs_se (simplRhs bndr bndr_se rhs) - `thenSmpl` \ (floats, rhs', arity, in_scope) -> - setInScope in_scope $ - completeBindNonRecE (bndr `setIdArity` arity) rhs' ( - simplExpr body cont - ) `thenSmpl` \ body' -> - returnSmpl (mkLets floats body') - 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 - | not opt_DictsStrict = False - | otherwise - = case splitTyConApp_maybe (idType bndr) of - Nothing -> False - Just (tycon,tys) -> maybeToBool (tyConClass_maybe tycon) && - length tys == tyConArity tycon && - isDataTyCon tycon -\end{code} +completeCall env var occ_info cont + = getDOptsSmpl `thenSmpl` \ dflags -> + let + in_scope = getInScope env + chkr = getSwitchChecker env + (args, call_cont, inline_call) = getContArgs chkr var cont -The completeBindNonRec family - - deals only with Ids, not TyVars - - take an already-simplified RHS - - always produce let bindings + arg_infos = [ interestingArg in_scope arg (getSubstEnv arg_env) + | (arg, arg_env, _) <- args, isValArg arg] -They do *not* attempt to do let-to-case. Why? Because -they are used for top-level bindings, and in many situations where -the "rhs" is known to be a WHNF (so let-to-case is inappropriate). + interesting_cont = interestingCallContext (not (null args)) + (not (null arg_infos)) + call_cont -\begin{code} -completeBindNonRec :: InId -- Binder - -> OutExpr -- Simplified RHS - -> SimplM a -- Thing inside - -> SimplM (Maybe (OutId, OutExpr), 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 `thenSmpl` \ res -> - returnSmpl (Nothing,res) - - | postInlineUnconditionally bndr etad_rhs - = tick PostInlineUnconditionally `thenSmpl_` - extendIdSubst bndr (Done etad_rhs) ( - thing_inside `thenSmpl` \ res -> - returnSmpl (Nothing,res) - ) - - | 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` \ res -> - returnSmpl (Just (bndr'', etad_rhs), res) - where - etad_rhs = etaCoreExpr rhs - -completeBindNonRecE :: InId -> OutExpr -> SimplM OutExpr -> SimplM OutExpr -completeBindNonRecE bndr rhs thing_inside - = completeBindNonRec bndr rhs thing_inside `thenSmpl` \ (maybe_bind, body) -> - returnSmpl (case maybe_bind of - Nothing -> body - Just (bndr, rhs) -> bindNonRec bndr rhs body) - --- (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. - -simplPrags old_bndr new_bndr new_rhs - | isEmptySpecEnv spec_env - = returnSmpl (bndr_w_unfolding) + inline_cont | inline_call = discardInline cont + | otherwise = cont - | otherwise - = getSimplBinderStuff `thenSmpl` \ (ty_subst, id_subst, in_scope, us) -> - let - spec_env' = substSpecEnv ty_subst in_scope (subst_val id_subst) spec_env + active_inline = activeInline env var + maybe_inline = callSiteInline dflags active_inline inline_call occ_info + var arg_infos interesting_cont in - returnSmpl (bndr_w_unfolding `setIdSpecialisation` spec_env') - where - bndr_w_unfolding = new_bndr `setIdUnfolding` mkUnfolding new_rhs + -- First, look for an inlining + case maybe_inline of { + Just unfolding -- There is an inlining! + -> tick (UnfoldingDone var) `thenSmpl_` + simplExprF env unfolding inline_cont - spec_env = getIdSpecialisation old_bndr - subst_val id_subst ty_subst in_scope expr - = substExpr ty_subst id_subst in_scope expr -\end{code} + ; + Nothing -> -- No inlining! -\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. + + simplifyArgs env args (contResultType call_cont) $ \ env args' -> + + -- Next, look for rules or specialisations that match -- - -- This is much better than first simplifying a perhaps-huge RHS - -- and then inlining and re-simplifying it. + -- 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. -- - -- 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 - | 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 - 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} + -- 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 -okToInline is used at call sites, so it is a bit more generous. -It's a very important function that embodies lots of heuristics. + -- Done + rebuild env (mkApps (Var var) args') call_cont + }} +\end{code} + + +%************************************************************************ +%* * +\subsection{Arguments} +%* * +%************************************************************************ \begin{code} -okToInline :: Bool -- True <-> essential unfoldings only - -> Bool -- Case scrutinee - -> 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 +--------------------------------------------------------- +-- 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. -- --- If the thing is in WHNF, there's no danger of duplicating work, --- so we can inline if it occurs once, or is small +-- 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 + 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') -okToInline essential_unfoldings_only is_case_scrutinee id form guidance cont - | essential_unfoldings_only - = 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) +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) + +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 | otherwise - = case getInlinePragma id of - IAmDead -> pprTrace "okToInline: dead" (ppr id) False - - IAmASpecPragmaId -> False - IMustNotBeINLINEd -> False - IAmALoopBreaker -> False - - IMustBeINLINEd -> True - - IWantToBeINLINEd -> True --some_benefit -- Even INLINE pragmas don't *always* - -- cause inlining - - ICanSafelyBeINLINEd inside_lam one_branch - -> --pprTrace "inline (occurs once): " (ppr id <+> ppr small_enough <+> ppr one_branch <+> ppr whnf <+> ppr some_benefit <+> ppr not_inside_lam) $ - (small_enough || one_branch) && - ((whnf && some_benefit) || not_inside_lam) - - where - not_inside_lam = case inside_lam of {InsideLam -> False; other -> True} - - other -> --pprTrace "inline: " (ppr id <+> ppr small_enough <+> ppr whnf <+> ppr some_benefit) $ - 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. - where - whnf = whnfOrBottom form - small_enough = smallEnoughToInline id arg_evals is_case_scrutinee guidance - val_args = get_val_args cont - arg_evals = map is_evald val_args - - some_benefit = contIsInteresting cont - - is_evald (Var v) = isEvaldUnfolding (getIdUnfolding v) - is_evald (Con con _) = isWHNFCon con - is_evald other = False - - get_val_args (ApplyTo _ arg _ cont) - | isValArg arg = arg : get_val_args cont - | otherwise = get_val_args cont - get_val_args other = [] - -contIsInteresting :: SimplCont -> Bool -contIsInteresting Stop = False -contIsInteresting (Select _ _ [(DEFAULT,_,_)] _ _) = False -contIsInteresting (ApplyTo _ (Type _) _ cont) = contIsInteresting cont -contIsInteresting _ = True + = 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} -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. +%************************************************************************ +%* * +\subsection{mkAtomicArgs} +%* * +%************************************************************************ + +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) + +There are three sorts of binding context, specified by the two +boolean arguments -Previously some_benefit used to return True only if the variable was -applied to some value arguments. This didn't work: +Strict + OK-unlifted - let x = _coerce_ (T Int) Int (I# 3) in - case _coerce_ Int (T Int) x of - I# y -> .... +N N Top-level or recursive Only bind args of lifted type -we want to inline x, but can't see that it's a constructor in a case -scrutinee position, and some_benefit is False. +N Y Non-top-level and non-recursive, Bind args of lifted type, or + but lazy unlifted-and-ok-for-speculation -Another example: +Y Y Non-top-level, non-recursive, Bind all args + and strict (demanded) + + +For example, given + + x = MkC (y div# z) + +there is no point in transforming to + + x = case (y div# z) of r -> MkC r -dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t) +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. -.... case dMonadST _@_ x0 of (a,b,c) -> .... +\begin{code} +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') -we'd really like to inline dMonadST here, but we *don't* want to -inline if the case expression is just + 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)]) - case x of y { DEFAULT -> ... } + | otherwise + = addAuxiliaryBind env (NonRec v r) $ \ env -> + addAtomicBindsE env bs thing_inside +\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. %************************************************************************ %* * @@ -913,293 +1151,223 @@ default case. %************************************************************************ \begin{code} -------------------------------------------------------------------- -rebuild :: OutExpr -> SimplCont -> SimplM OutExpr +rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM FloatsWithExpr -rebuild expr cont - = tick LeavesExamined `thenSmpl_` - getSwitchChecker `thenSmpl` \ chkr -> - do_rebuild chkr expr (mkFormSummary expr) 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 ---------------------------------------------------------- --- Stop continuation +rebuildApp env fun arg cont + = simplExpr env arg `thenSmpl` \ arg' -> + rebuild env (App fun arg') cont -do_rebuild sw_chkr expr form Stop = returnSmpl expr +rebuildDone env expr = returnSmpl (emptyFloats env, expr) +\end{code} ---------------------------------------------------------- --- Coerce continuation - -do_rebuild sw_chkr expr form (CoerceIt _ to_ty se cont) - = setSubstEnv se $ - simplType to_ty `thenSmpl` \ to_ty' -> - do_rebuild sw_chkr (mk_coerce to_ty' expr) form 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 +%************************************************************************ +%* * +\subsection{Functions dealing with a case} +%* * +%************************************************************************ +Blob of helper functions for the "case-of-something-else" situation. +\begin{code} --------------------------------------------------------- --- Dealing with --- * case (error "hello") of { ... } +-- Eliminate the case if possible + +rebuildCase :: SimplEnv + -> OutExpr -- Scrutinee + -> InId -- Case binder + -> [InAlt] -- Alternatives + -> SimplCont + -> SimplM FloatsWithExpr --- ToDo: deal with --- * (error "Hello") arg +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 -do_rebuild sw_chkr expr BottomForm cont@(Select _ _ _ _ _) - = tick CaseOfError `thenSmpl_` - getInScope `thenSmpl` \ in_scope -> + | 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 + -- Filter out alternatives that can't possibly match let - (cont', result_ty) = find_result_ty in_scope cont + 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 - do_rebuild sw_chkr (mkNote (Coerce result_ty expr_ty) expr) BottomForm cont' - where - expr_ty = coreExprType expr - find_result_ty in_scope (ApplyTo _ _ _ cont) - = (cont, funResultTy expr_ty) - find_result_ty in_scope (Select _ _ ((_,_,rhs1):_) (ty_subst,_) cont) - = (cont, fullSubstTy ty_subst in_scope (coreExprType rhs1)) - ---------------------------------------------------------- --- Ordinary application + -- Deal with the case binder, and prepare the continuation; + -- The new subst_env is in place + prepareCaseCont env better_alts cont `thenSmpl` \ (floats, cont') -> + addFloats env floats $ \ env -> -do_rebuild sw_chkr expr form cont@(ApplyTo _ _ _ _) - = go expr cont - where -- This loop just saves repeated calculation of mkFormSummary - go e (ApplyTo _ arg se cont) = setSubstEnv se (simplArg arg) `thenSmpl` \ arg' -> - go (App e arg') cont - go e cont = do_rebuild sw_chkr e (mkFormSummary e) cont + -- Deal with variable scrutinee + simplCaseBinder env scrut case_bndr `thenSmpl` \ (alt_env, case_bndr', zap_occ_info) -> + -- Deal with the case alternatives + simplAlts alt_env zap_occ_info impossible_cons + case_bndr' better_alts cont' `thenSmpl` \ alts' -> ---------------------------------------------------------- --- Case of known constructor or literal + -- Put the case back together + mkCase scrut case_bndr' alts' `thenSmpl` \ case_expr -> -do_rebuild sw_chkr expr@(Con con args) form cont@(Select _ _ _ _ _) - | conOkForAlt con -- Knocks out PrimOps and NoRepLits - = knownCon expr con args cont + -- 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} ---------------------------------------------------------- --- Case of other value (e.g. a partial application or lambda) --- Turn it back into a let +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. -do_rebuild sw_chkr expr ValueForm (Select _ bndr ((DEFAULT, bs, rhs):alts) se cont) - = ASSERT( null bs && null alts ) - tick Case2Let `thenSmpl_` - setSubstEnv se ( - completeBindNonRecE bndr expr $ - simplExpr rhs cont - ) +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 of something else; eliminating the case altogether --- See the extensive notes on case-elimination below - -do_rebuild sw_chkr scrut form (Select _ bndr alts se cont) - | switchIsOn sw_chkr SimplDoCaseElim - && all (cheapEqExpr rhs1) other_rhss - && inlineCase bndr scrut - && all binders_unused alts - - = -- Get rid of the case altogether - -- Remember to bind the binder though! - tick CaseElim `thenSmpl_` - setSubstEnv se ( - extendIdSubst bndr (Done scrut) $ - simplExpr rhs1 cont - ) - where - (rhs1:other_rhss) = [rhs | (_,_,rhs) <- alts] + case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 } + ...other cases .... } - binders_unused (_, bndrs, _) = all isDeadBinder bndrs +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 of something else + case x of w1 { A -> let w2 = w1 in e1 + B -> let w2 = w1 in e2 + ...other cases .... } -do_rebuild sw_chkr scrut form (Select _ case_bndr alts se cont) - = -- Prepare the continuation and case alternatives - prepareCaseAlts (splitTyConApp_maybe (idType case_bndr)) - scrut_cons alts `thenSmpl` \ better_alts -> - prepareCaseCont better_alts cont $ \ cont' -> - - -- Set the new subst-env in place (before dealing with the case binder) - setSubstEnv se $ - - -- Deal with the case binder - simplBinder case_bndr $ \ case_bndr' -> +This is plain silly in the common case where w2 is dead. - -- Deal with variable scrutinee - substForVarScrut scrut case_bndr' $ \ zap_occ_info -> - let - case_bndr'' = zap_occ_info case_bndr' - in +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: - -- Deal with the case alternaatives - simplAlts zap_occ_info scrut_cons case_bndr'' better_alts cont' `thenSmpl` \ alts' -> + data T = MkT !Int - getSwitchChecker `thenSmpl` \ sw_chkr -> - mkCase sw_chkr scrut case_bndr'' alts' - 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 -> [] -\end{code} + case v of w { MkT x -> + case x of x1 { I# y1 -> + case x of x2 { I# y2 -> ... -Blob of helper functions for the "case-of-something-else" situation. +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. -\begin{code} -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 ) - completeBindNonRecE bndr expr $ - simplExpr 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. - simplExpr rhs cont - - (DataCon dc, bs, rhs) -> completeBindNonRecE bndr expr $ - extend bs real_args $ - simplExpr 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 -\end{code} - -\begin{code} -prepareCaseCont [alt] cont thing_inside = thing_inside cont -prepareCaseCont alts cont thing_inside = mkDupableCont cont thing_inside -\end{code} - -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. - -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: +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') @@ -1210,95 +1378,85 @@ simplAlts zap_occ_info scrut_cons case_bndr'' alts cont' -- 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} -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. - -We also make sure that we deal with this very common case: - - 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) - -Lastly, we generalise the transformation to handle this: - - case e of ===> r - True -> r - False -> r - -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. - -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. - -So the case-elimination algorithm is: +%************************************************************************ +%* * +\subsection{Known constructor} +%* * +%************************************************************************ - 1. Eliminate alternatives which can't match +We are a bit careful with occurrence info. Here's an example - 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 + (\x* -> case x of (a*, b) -> f a) (h v, e) - 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! +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) - or * [Prim cases] the scrutinee is a primitive variable +All this should happen in one sweep. - 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.] +\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 -If so, then we can replace the case with one of the rhss. +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} %************************************************************************ @@ -1308,63 +1466,163 @@ If so, then we can replace the case with one of the rhss. %************************************************************************ \begin{code} -mkDupableCont :: SimplCont - -> (SimplCont -> SimplM CoreExpr) - -> SimplM CoreExpr -mkDupableCont cont thing_inside +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 + -> SimplM (FloatsWith SimplCont) -- Return a duplicatable continuation, + -- plus some extra bindings + +mkDupableCont env ty cont | contIsDupable cont - = thing_inside cont + = 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 + -- 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 + cont_fn env arg' = rebuildDone env (App (Var join_id) arg') + join_rhs = Lam (setOneShotLambda arg_id) (wrapFloats floats rhs) + in + + 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 -mkDupableCont (CoerceIt _ ty se cont) thing_inside - = mkDupableCont cont $ \ cont' -> - thing_inside (CoerceIt OkToDup ty se cont') + returnSmpl (unitFloat env join_id join_rhs, + ArgOf OkToDup is_rhs cont_ty cont_fn) -mkDupableCont (ApplyTo _ arg se cont) thing_inside - = mkDupableCont cont $ \ cont' -> - setSubstEnv se (simplExpr arg Stop) `thenSmpl` \ arg' -> +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 (bindNonRec bndr arg' res) - -mkDupableCont (Select _ case_bndr alts se cont) thing_inside - = tick CaseOfCase `thenSmpl_` ( - mkDupableCont cont $ \ cont' -> - - setSubstEnv se ( - simplBinder case_bndr $ \ case_bndr' -> - 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 (mkLets alt_binds res) - ) - -mkDupableAlt :: OutId -> SimplCont -> InAlt -> SimplM ([CoreBind], 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 @@ -1376,7 +1634,61 @@ mkDupableAlt case_bndr' cont alt@(con, bndrs, rhs) -- 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}