X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplify.lhs;h=17a7969e74da1ddc0a3c19c9803d514786a983da;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=473b03ba4b8e0016a1f76ce6ec65989d331110d6;hpb=202fc4bc65a98ee3d06ca89fe3c61e9db340285b;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 473b03b..17a7969 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -1,4 +1,4 @@ - +% % (c) The AQUA Project, Glasgow University, 1993-1998 % \section[Simplify]{The main module of the simplifier} @@ -8,69 +8,215 @@ module Simplify ( simplTopBinds, simplExpr ) where #include "HsVersions.h" -import CmdLineOpts ( intSwitchSet, - opt_SccProfilingOn, opt_PprStyle_Debug, opt_SimplDoEtaReduction, - opt_SimplNoPreInlining, opt_DictsStrict, opt_SimplPedanticBottoms, +import DynFlags ( dopt, DynFlag(Opt_D_dump_inlinings), SimplifierSwitch(..) ) import SimplMonad -import SimplUtils ( mkCase, transformRhs, findAlt, - simplBinder, simplBinders, simplIds, findDefault, mkCoerce +import SimplEnv +import SimplUtils ( mkCase, mkLam, prepareAlts, + SimplCont(..), DupFlag(..), LetRhsFlag(..), + mkRhsStop, mkBoringStop, pushContArgs, + contResultType, countArgs, contIsDupable, contIsRhsOrArg, + getContArgs, interestingCallContext, interestingArg, isStrictType, + preInlineUnconditionally, postInlineUnconditionally, + inlineMode, activeInline, activeRule ) -import Var ( TyVar, mkSysTyVar, tyVarKind, maybeModifyIdInfo ) -import VarEnv -import VarSet -import Id ( Id, idType, idInfo, idUnique, - getIdUnfolding, setIdUnfolding, isExportedId, - getIdSpecialisation, setIdSpecialisation, - getIdDemandInfo, setIdDemandInfo, - getIdArity, setIdArity, setIdInfo, - getIdStrictness, - setInlinePragma, getInlinePragma, idMustBeINLINEd, - setOneShotLambda, maybeModifyIdInfo +import Id ( Id, idType, idInfo, idArity, isDataConWorkId, + setIdUnfolding, isDeadBinder, + idNewDemandInfo, setIdInfo, + setIdOccInfo, zapLamIdInfo, setOneShotLambda ) -import IdInfo ( InlinePragInfo(..), OccInfo(..), StrictnessInfo(..), - ArityInfo(..), atLeastArity, arityLowerBound, unknownArity, zapFragileIdInfo, - specInfo, inlinePragInfo, zapLamIdInfo, setArityInfo, setInlinePragInfo, setUnfoldingInfo +import MkId ( eRROR_ID ) +import Literal ( mkStringLit ) +import IdInfo ( OccInfo(..), isLoopBreaker, + setArityInfo, zapDemandInfo, + setUnfoldingInfo, + occInfo ) -import Demand ( Demand, isStrict, wwLazy ) -import Const ( isWHNFCon, conOkForAlt ) -import ConFold ( tryPrimOp ) -import PrimOp ( PrimOp, primOpStrictness, primOpType ) -import DataCon ( DataCon, dataConNumInstArgs, dataConRepStrictness, dataConSig, dataConArgTys ) -import Const ( Con(..) ) -import Name ( isLocallyDefined ) +import NewDemand ( isStrictDmd ) +import Unify ( coreRefineTys ) +import DataCon ( dataConTyCon, dataConRepStrictness, isVanillaDataCon ) +import TyCon ( tyConArity ) import CoreSyn -import CoreFVs ( exprFreeVars ) -import CoreUnfold ( Unfolding, mkOtherCon, mkUnfolding, otherCons, - callSiteInline, hasSomeUnfolding - ) -import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsCheap, exprIsTrivial, - coreExprType, coreAltsType, exprArity, exprIsValue, - exprOkForSpeculation +import PprCore ( pprParendExpr, pprCoreExpr ) +import CoreUnfold ( mkUnfolding, callSiteInline ) +import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding, + exprIsConApp_maybe, mkPiTypes, findAlt, + exprType, exprIsHNF, + exprOkForSpeculation, exprArity, + mkCoerce, mkCoerce2, mkSCC, mkInlineMe, applyTypeToArg ) import Rules ( lookupRule ) -import CostCentre ( isSubsumedCCS, currentCCS, isEmptyCC ) -import Type ( Type, mkTyVarTy, mkTyVarTys, isUnLiftedType, seqType, - mkFunTy, splitFunTys, splitTyConApp_maybe, splitFunTy_maybe, - funResultTy, isDictTy, isDataType, applyTy, applyTys, mkFunTys - ) -import Subst ( Subst, mkSubst, emptySubst, substExpr, substTy, - substEnv, lookupInScope, lookupSubst, substIdInfo +import BasicTypes ( isMarkedStrict ) +import CostCentre ( currentCCS ) +import Type ( TvSubstEnv, isUnLiftedType, seqType, tyConAppArgs, funArgTy, + splitFunTy_maybe, splitFunTy, coreEqType ) -import TyCon ( isDataTyCon, tyConDataCons, tyConClass_maybe, tyConArity, isDataTyCon ) +import VarEnv ( elemVarEnv, emptyVarEnv ) import TysPrim ( realWorldStatePrimTy ) import PrelInfo ( realWorldPrimId ) -import BasicTypes ( TopLevelFlag(..), isTopLevel ) -import Maybes ( maybeToBool ) -import Util ( zipWithEqual, stretchZipEqual, lengthExceeds ) -import PprCore +import BasicTypes ( TopLevelFlag(..), isTopLevel, + RecFlag(..), isNonRec + ) +import StaticFlags ( opt_PprStyle_Debug ) +import OrdList +import Maybes ( orElse ) import Outputable +import Util ( notNull ) \end{code} -The guts of the simplifier is in this module, but the driver -loop for the simplifier is in SimplCore.lhs. +The guts of the simplifier is in this module, but the driver loop for +the simplifier is in SimplCore.lhs. + + +----------------------------------------- + *** 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. + + +----------------------------------------- + *** 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. + +All "floats" are let-binds, not case-binds, but some non-rec lets may +be unlifted (with RHS ok-for-speculation). + + + +----------------------------------------- + ORGANISATION OF FUNCTIONS +----------------------------------------- +simplTopBinds + - simplify all top-level binders + - for NonRec, call simplRecOrTopPair + - for Rec, call simplRecBind + + + ------------------------------ +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) + +It's harder to make the rule match if we ANF-ise the constructor, +or eta-expand the PAP: + + f (let { a = g x; b = h x } in (a,b)) + g (\y. + x y) + +On the other hand if we see the let-defns + + 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. + +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) + +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. + +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. + + +Eta expansion +~~~~~~~~~~~~~~ +For eta expansion, we want to catch things like + + case e of (a,b) -> \x -> case a of (p,q) -> \y -> r + +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. %************************************************************************ @@ -80,59 +226,452 @@ loop for the simplifier is in SimplCore.lhs. %************************************************************************ \begin{code} -simplTopBinds :: [InBind] -> SimplM [OutBind] +simplTopBinds :: SimplEnv -> [InBind] -> SimplM [OutBind] -simplTopBinds binds +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. - extendInScopes top_binders $ - simpl_binds binds `thenSmpl` \ (binds', _) -> - freeTick SimplifierDone `thenSmpl_` - returnSmpl binds' + simplLetBndrs env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') -> + simpl_binds env binds bndrs' `thenSmpl` \ (floats, _) -> + freeTick SimplifierDone `thenSmpl_` + returnSmpl (floatBinds floats) where - top_binders = bindersOfBinds binds + -- 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 bind bs + = getDOptsSmpl `thenSmpl` \ dflags -> + if dopt Opt_D_dump_inlinings dflags then + pprTrace "SimplBind" (ppr (bindersOf bind)) $ simpl_bind1 env bind bs + else + simpl_bind1 env bind bs + + simpl_bind1 env (NonRec b r) (b':_) = simplRecOrTopPair env TopLevel b b' r + simpl_bind1 env (Rec pairs) bs' = simplRecBind env TopLevel pairs bs' +\end{code} + + +%************************************************************************ +%* * +\subsection{simplNonRec} +%* * +%************************************************************************ + +simplNonRecBind is used for + * non-top-level non-recursive lets in expressions + * beta reduction - simpl_binds [] = returnSmpl ([], panic "simplTopBinds corner") - simpl_binds (NonRec bndr rhs : binds) = simplLazyBind TopLevel bndr (zap bndr) rhs (simpl_binds binds) - simpl_binds (Rec pairs : binds) = simplRecBind TopLevel pairs (map (zap . fst) pairs) (simpl_binds binds) +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 - zap id = maybeModifyIdInfo zapFragileIdInfo id --- TEMP +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} +simplNonRecBind :: SimplEnv + -> InId -- Binder + -> InExpr -> SimplEnv -- Arg, with its subst-env + -> OutType -- Type of thing computed by the context + -> (SimplEnv -> SimplM FloatsWithExpr) -- The body + -> SimplM FloatsWithExpr +#ifdef DEBUG +simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside + | isTyVar bndr + = pprPanic "simplNonRecBind" (ppr bndr <+> ppr rhs) +#endif + +simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside + = simplNonRecBind' env bndr rhs rhs_se cont_ty thing_inside + +simplNonRecBind' env bndr rhs rhs_se cont_ty thing_inside + | preInlineUnconditionally env NotTopLevel bndr rhs + = tick (PreInlineUnconditionally bndr) `thenSmpl_` + thing_inside (extendIdSubst env bndr (mkContEx rhs_se rhs)) + + | isStrictDmd (idNewDemandInfo bndr) || isStrictType bndr_ty -- A strict let + = -- Don't use simplBinder because that doesn't keep + -- fragile occurrence info in the substitution + simplLetBndr env bndr `thenSmpl` \ (env, bndr1) -> + simplStrictArg AnRhs env rhs rhs_se (idType bndr1) cont_ty $ \ env1 rhs1 -> + + -- Now complete the binding and simplify the body + let + -- simplLetBndr doesn't deal with the IdInfo, so we must + -- do so here (c.f. simplLazyBind) + bndr2 = bndr1 `setIdInfo` simplIdInfo env (idInfo bndr) + env2 = modifyInScope env1 bndr2 bndr2 + in + if needsCaseBinding bndr_ty rhs1 + then + thing_inside env2 `thenSmpl` \ (floats, body) -> + returnSmpl (emptyFloats env2, Case rhs1 bndr2 (exprType body) + [(DEFAULT, [], wrapFloats floats body)]) + else + completeNonRecX env2 True {- strict -} bndr bndr2 rhs1 thing_inside + + | otherwise -- Normal, lazy case + = -- Don't use simplBinder because that doesn't keep + -- fragile occurrence info in the substitution + simplLetBndr env bndr `thenSmpl` \ (env, bndr') -> + simplLazyBind env NotTopLevel NonRecursive + bndr bndr' rhs rhs_se `thenSmpl` \ (floats, env) -> + addFloats env floats thing_inside -simplRecBind :: TopLevelFlag -> [(InId, InExpr)] -> [OutId] - -> SimplM (OutStuff a) -> SimplM (OutStuff a) -simplRecBind top_lvl pairs bndrs' thing_inside - = go pairs bndrs' `thenSmpl` \ (binds', stuff) -> - returnSmpl (addBind (Rec (flattenBinds binds')) stuff) where - go [] _ = thing_inside `thenSmpl` \ stuff -> - returnSmpl ([], stuff) - - go ((bndr, rhs) : pairs) (bndr' : bndrs') - = simplLazyBind top_lvl bndr bndr' rhs (go pairs bndrs') - -- Don't float unboxed bindings out, - -- because we can't "rec" them + bndr_ty = idType bndr +\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 + | needsCaseBinding (idType bndr) new_rhs + -- Make this test *before* the preInlineUnconditionally + -- Consider case I# (quotInt# x y) of + -- I# v -> let w = J# v in ... + -- If we gaily inline (quotInt# x y) for v, we end up building an + -- extra thunk: + -- let w = J# (quotInt# x y) in ... + -- because quotInt# can fail. + = simplBinder env bndr `thenSmpl` \ (env, bndr') -> + thing_inside env `thenSmpl` \ (floats, body) -> + let body' = wrapFloats floats body in + returnSmpl (emptyFloats env, Case new_rhs bndr' (exprType body') [(DEFAULT, [], body')]) + + | preInlineUnconditionally env NotTopLevel bndr new_rhs + -- 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 (extendIdSubst env bndr (DoneEx new_rhs)) + + | otherwise + = simplBinder env bndr `thenSmpl` \ (env, bndr') -> + completeNonRecX env False {- Non-strict; pessimistic -} + bndr bndr' new_rhs thing_inside + +completeNonRecX env is_strict old_bndr new_bndr new_rhs thing_inside + = mkAtomicArgs is_strict + True {- OK to float unlifted -} + new_rhs `thenSmpl` \ (aux_binds, rhs2) -> + + -- Make the arguments atomic if necessary, + -- adding suitable bindings + addAtomicBindsE env (fromOL aux_binds) $ \ env -> + completeLazyBind env NotTopLevel + old_bndr new_bndr rhs2 `thenSmpl` \ (floats, env) -> + addFloats env floats thing_inside \end{code} %************************************************************************ %* * -\subsection[Simplify-simplExpr]{The main function: simplExpr} +\subsection{Lazy bindings} %* * %************************************************************************ +simplRecBind is used for + * recursive bindings only + \begin{code} -addBind :: CoreBind -> OutStuff a -> OutStuff a -addBind bind (binds, res) = (bind:binds, res) +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} + -addBinds :: [CoreBind] -> OutStuff a -> OutStuff a -addBinds [] stuff = stuff -addBinds binds1 (binds2, res) = (binds1++binds2, 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 rhs -- Check for unconditional inline + = tick (PreInlineUnconditionally bndr) `thenSmpl_` + returnSmpl (emptyFloats env, extendIdSubst env bndr (mkContEx 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 bndr1 rhs rhs_se + = let -- Transfer the IdInfo of the original binder to the new binder + -- This is crucial: we must preserve + -- strictness + -- rules + -- worker info + -- etc. To do this we must apply the current substitution, + -- which incorporates earlier substitutions in this very letrec group. + -- + -- NB 1. We do this *before* processing the RHS of the binder, so that + -- its substituted rules are visible in its own RHS. + -- 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 2: We do not transfer the arity (see Subst.substIdInfo) + -- The arity of an Id should not be visible + -- in its own RHS, else we eta-reduce + -- f = \x -> f x + -- to + -- f = f + -- which isn't sound. And it makes the arity in f's IdInfo greater than + -- the manifest arity, which isn't good. + -- The arity will get added later. + -- + -- NB 3: It's important that we *do* transer the loop-breaker OccInfo, + -- because that's what stops the Id getting inlined infinitely, in the body + -- of the letrec. + + -- NB 4: does no harm for non-recursive bindings + + bndr2 = bndr1 `setIdInfo` simplIdInfo env (idInfo bndr) + env1 = modifyInScope env bndr2 bndr2 + rhs_env = setInScope rhs_se env1 + is_top_level = isTopLevel top_lvl + ok_float_unlifted = not is_top_level && isNonRec is_rec + rhs_cont = mkRhsStop (idType bndr1) + in + -- Simplify the RHS; note the mkRhsStop, 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 bndr2 + (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 && isNilOL aux_binds then -- Shortcut a common case + completeLazyBind env1 top_lvl bndr bndr2 rhs2 + + else if is_top_level || exprIsTrivial rhs2 || exprIsHNF rhs2 then + -- WARNING: long dodgy argument coming up + -- WANTED: a better way to do this + -- + -- We can't use "exprIsCheap" instead of exprIsHNF, + -- 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 exprIsHNF for the test, which ensures that the + -- thing is non-strict. So exprIsHNF => bindings are non-strict + -- I think. The WARN below tests for this. + -- + -- 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. + -- exprIsHNF definitely isn't right for that. + -- + -- Again, the floated binding can't be strict; if it's recursive it'll + -- be non-strict; if it's non-recursive it'd be inlined. + -- + -- Note [SCC-and-exprIsTrivial] + -- If we have + -- y = let { x* = E } in scc "foo" x + -- then we do *not* want to float out the x binding, because + -- it's strict! Fortunately, exprIsTrivial replies False to + -- (scc "foo" x). + + -- 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 (a) arg' is a WHNF, or (b) it's going to top level + -- and so there can't be any 'will be demanded' bindings in the floats. + -- Hence the warning + ASSERT2( is_top_level || not (any demanded_float (floatBinds floats)), + ppr (filter demanded_float (floatBinds floats)) ) + + tick LetFloatFromLet `thenSmpl_` ( + addFloats env1 floats $ \ env2 -> + addAtomicBinds env2 (fromOL aux_binds) $ \ env3 -> + completeLazyBind env3 top_lvl bndr bndr2 rhs2) + + else + completeLazyBind env1 top_lvl bndr bndr2 (wrapFloats floats rhs1) + +#ifdef DEBUG +demanded_float (NonRec b r) = isStrictDmd (idNewDemandInfo b) && not (isUnLiftedType (idType b)) + -- Unlifted-type (cheap-eagerness) lets may well have a demanded flag on them +demanded_float (Rec _) = False +#endif +\end{code} + + +%************************************************************************ +%* * +\subsection{Completing a lazy binding} +%* * +%************************************************************************ + +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 + +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). + +\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 top_lvl new_bndr occ_info new_rhs unfolding + = -- Drop the binding + tick (PostInlineUnconditionally old_bndr) `thenSmpl_` + returnSmpl (emptyFloats env, extendIdSubst env old_bndr (DoneEx new_rhs)) + -- Use the substitution to make quite, quite sure that the substitution + -- will happen, since we are going to discard the binding + + | otherwise + = let + -- Add arity info + new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs + + -- Add the unfolding *only* for non-loop-breakers + -- Making loop breakers not have an unfolding at all + -- means that we can avoid tests in exprIsConApp, for example. + -- This is important: if exprIsConApp says 'yes' for a recursive + -- thing, then we can get into an infinite loop + + -- If the unfolding is a value, the demand info may + -- go pear-shaped, so we nuke it. Example: + -- let x = (a,b) in + -- case x of (p,q) -> h p q x + -- Here x is certainly demanded. But after we've nuked + -- the case, we'll get just + -- let x = (a,b) in h a b x + -- and now x is not demanded (I'm assuming h is lazy) + -- This really happens. Similarly + -- let f = \x -> e in ...f..f... + -- After inling f at some of its call sites the original binding may + -- (for example) be no longer strictly demanded. + -- The solution here is a bit ad hoc... + info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding + final_info | loop_breaker = new_bndr_info + | isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf + | otherwise = info_w_unf + + final_id = new_bndr `setIdInfo` final_info + 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 + unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs + loop_breaker = isLoopBreaker occ_info + old_info = idInfo old_bndr + occ_info = occInfo old_info +\end{code} + + + +%************************************************************************ +%* * +\subsection[Simplify-simplExpr]{The main function: simplExpr} +%* * +%************************************************************************ + 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. @@ -172,796 +711,566 @@ might do the same again. \begin{code} -simplExpr :: CoreExpr -> SimplM CoreExpr -simplExpr expr = getSubst `thenSmpl` \ subst -> - simplExprC expr (Stop (substTy subst (coreExprType expr))) - -- The type in the Stop continuation is usually not used +simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr +simplExpr env expr = simplExprC env expr (mkBoringStop expr_ty') + where + expr_ty' = substTy 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 :: CoreExpr -> SimplCont -> SimplM CoreExpr - -- Simplify an expression, given a continuation -simplExprC expr cont = simplExprF expr cont `thenSmpl` \ (floats, (_, body)) -> - returnSmpl (mkLets floats body) +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 :: InExpr -> SimplCont -> SimplM OutExprStuff +simplExprF :: SimplEnv -> InExpr -> SimplCont -> SimplM FloatsWithExpr -- Simplify an expression, returning floated binds -simplExprF (Var v) cont - = simplVar v cont +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 expr@(Con (PrimOp op) args) cont - = getSubstEnv `thenSmpl` \ se -> - prepareArgs (ppr op) - (primOpType op) - (primOpStrictness op) - (pushArgs se args cont) $ \ args1 cont1 -> +simplExprF env (Type ty) cont + = ASSERT( contIsRhsOrArg cont ) + simplType env ty `thenSmpl` \ ty' -> + rebuild env (Type ty') cont - let - -- Boring... we may have too many arguments now, so we push them back - n_args = length args - args2 = ASSERT( length args1 >= n_args ) - take n_args args1 - cont2 = pushArgs emptySubstEnv (drop n_args args1) cont1 - in - -- Try the prim op simplification - -- It's really worth trying simplExpr again if it succeeds, - -- because you can find - -- case (eqChar# x 'a') of ... - -- ==> - -- case (case x of 'a' -> True; other -> False) of ... - case tryPrimOp op args2 of - Just e' -> zapSubstEnv (simplExprF e' cont2) - Nothing -> rebuild (Con (PrimOp op) args2) cont2 - -simplExprF (Con con@(DataCon _) args) cont - = simplConArgs args ( \ args' -> - rebuild (Con con args') cont) - -simplExprF expr@(Con con@(Literal _) args) cont - = ASSERT( null args ) - rebuild expr cont - -simplExprF (App fun arg) cont - = getSubstEnv `thenSmpl` \ se -> - simplExprF fun (ApplyTo NoDup arg se cont) - -simplExprF (Case scrut bndr alts) cont - = getSubstEnv `thenSmpl` \ se -> - simplExprF scrut (Select NoDup bndr alts se cont) - - -simplExprF (Let (Rec pairs) body) cont - = simplIds (map fst pairs) $ \ bndrs' -> - -- NB: bndrs' don't have unfoldings or spec-envs - -- We add them as we go down, using simplPrags - - simplRecBind NotTopLevel pairs bndrs' (simplExprF body cont) - -simplExprF expr@(Lam _ _) cont = simplLam expr cont - -simplExprF (Type ty) cont - = ASSERT( case cont of { Stop _ -> True; ArgOf _ _ _ -> True; other -> False } ) - simplType ty `thenSmpl` \ ty' -> - rebuild (Type ty') cont - -simplExprF (Note (Coerce to from) e) cont - | to == from = simplExprF e cont - | otherwise = simplType to `thenSmpl` \ to' -> - simplExprF e (CoerceIt to' cont) - --- hack: we only distinguish subsumed cost centre stacks for the purposes of --- inlining. All other CCCSs are mapped to currentCCS. -simplExprF (Note (SCC cc) e) cont - = setEnclosingCC currentCCS $ - simplExpr e `thenSmpl` \ e -> - rebuild (mkNote (SCC cc) e) cont - -simplExprF (Note InlineCall e) cont - = simplExprF e (InlinePlease cont) - --- Comments about the InlineMe case --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- 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! --- --- It really is important to switch off inlinings. This function --- may be inlinined in other modules, so we don't want to remove --- (by inlining) calls to functions that have specialisations, or --- that may have transformation rules in an importing scope. --- E.g. {-# INLINE f #-} --- f x = ...g... --- and suppose that g is strict *and* has specialisations. --- If we inline g's wrapper, we deny f the chance of getting --- the specialised version of g when f is inlined at some call site --- (perhaps in some other module). - -simplExprF (Note InlineMe e) cont - = case cont of - Stop _ -> -- Totally boring continuation - -- Don't inline inside an INLINE expression - switchOffInlining (simplExpr e) `thenSmpl` \ e' -> - rebuild (mkNote InlineMe e') cont - - other -> -- Dissolve the InlineMe note if there's - -- an interesting context of any kind to combine with - -- (even a type application -- anything except Stop) - simplExprF e cont - --- A non-recursive let is dealt with by simplBeta -simplExprF (Let (NonRec bndr rhs) body) cont - = getSubstEnv `thenSmpl` \ se -> - simplBeta bndr rhs se (contResultType cont) $ - simplExprF body cont -\end{code} +simplExprF env (Case scrut bndr case_ty alts) cont + | not (switchIsOn (getSwitchChecker env) NoCaseOfCase) + = -- Simplify the scrutinee with a Select continuation + simplExprF env scrut (Select NoDup bndr alts env cont) + + | otherwise + = -- 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 + case_cont = Select NoDup bndr alts env (mkBoringStop case_ty') + case_ty' = substTy env case_ty -- c.f. defn of simplExpr + +simplExprF env (Let (Rec pairs) body) cont + = simplLetBndrs env (map fst pairs) `thenSmpl` \ (env, bndrs') -> + -- NB: bndrs' don't have unfoldings or rules + -- We add them as we go down + + simplRecBind env NotTopLevel pairs bndrs' `thenSmpl` \ (floats, env) -> + addFloats env floats $ \ env -> + simplExprF env body cont + +-- 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 --------------------------------- +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 env ty +\end{code} + + +%************************************************************************ +%* * +\subsection{Lambdas} +%* * +%************************************************************************ \begin{code} -simplLam fun cont - = go fun cont +simplLam env fun cont + = go env fun cont where - zap_it = mkLamBndrZapper fun (countArgs cont) + zap_it = mkLamBndrZapper fun (countArgs cont) cont_ty = contResultType cont -- Type-beta reduction - go (Lam bndr body) (ApplyTo _ (Type ty_arg) arg_se body_cont) + go env (Lam bndr body) (ApplyTo _ (Type ty_arg) arg_se body_cont) = ASSERT( isTyVar bndr ) - tick (BetaReduction bndr) `thenSmpl_` - getInScope `thenSmpl` \ in_scope -> - let - ty' = substTy (mkSubst in_scope arg_se) ty_arg - in - seqType ty' `seq` - extendSubst bndr (DoneTy ty') - (go body body_cont) + tick (BetaReduction bndr) `thenSmpl_` + simplType (setInScope arg_se env) ty_arg `thenSmpl` \ ty_arg' -> + go (extendTvSubst env bndr ty_arg') body body_cont -- Ordinary beta reduction - go (Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont) - = tick (BetaReduction bndr) `thenSmpl_` - simplBeta zapped_bndr arg arg_se cont_ty - (go body body_cont) + go env (Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont) + = tick (BetaReduction bndr) `thenSmpl_` + simplNonRecBind env (zap_it bndr) arg arg_se cont_ty $ \ env -> + go env body body_cont + + -- Not enough args, so there are real lambdas left to put in the result + go env lam@(Lam _ _) cont + = simplLamBndrs 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 - zapped_bndr = zap_it bndr - - -- Not enough args - go lam@(Lam _ _) cont = completeLam [] lam cont + (bndrs,body) = collectBinders lam -- Exactly enough args - go expr cont = simplExprF expr cont - - --- completeLam deals with the case where a lambda doesn't have an ApplyTo --- continuation. Try for eta reduction, but *only* if we get all --- the way to an exprIsTrivial expression. --- 'acc' holds the simplified binders, in reverse order - -completeLam acc (Lam bndr body) cont - = simplBinder bndr $ \ bndr' -> - completeLam (bndr':acc) body cont - -completeLam acc body cont - = simplExpr body `thenSmpl` \ body' -> - - case (opt_SimplDoEtaReduction, check_eta acc body') of - (True, Just body'') -- Eta reduce! - -> tick (EtaReduction (head acc)) `thenSmpl_` - rebuild body'' cont - - other -> -- No eta reduction - rebuild (foldl (flip Lam) body' acc) cont - -- Remember, acc is the reversed binders - where - -- NB: the binders are reversed - check_eta (b : bs) (App fun arg) - | (varToCoreExpr b `cheapEqExpr` arg) - = check_eta bs fun - - check_eta [] body - | exprIsTrivial body && -- ONLY if the body is trivial - not (any (`elemVarSet` body_fvs) acc) - = Just body -- Success! - where - body_fvs = exprFreeVars body - - check_eta _ _ = Nothing -- Bale out + go env expr cont = simplExprF env expr cont mkLamBndrZapper :: CoreExpr -- Function - -> Int -- Number of args + -> Int -- Number of args supplied, *including* type args -> Id -> Id -- Use this to zap the binders mkLamBndrZapper fun n_args | n_args >= n_params fun = \b -> b -- Enough args - | otherwise = \b -> maybeModifyIdInfo zapLamIdInfo b + | otherwise = \b -> zapLamIdInfo b where - n_params (Lam b e) | isId b = 1 + n_params e - | otherwise = n_params e - n_params other = 0::Int + -- NB: we count all the args incl type args + -- so we must count all the binders (incl type lambdas) + n_params (Note _ e) = n_params e + n_params (Lam b e) = 1 + n_params e + n_params other = 0::Int \end{code} ---------------------------------- -simplConArgs makes sure that the arguments all end up being atomic. -That means it may generate some Lets, hence the strange type - -\begin{code} -simplConArgs :: [InArg] -> ([OutArg] -> SimplM OutExprStuff) -> SimplM OutExprStuff -simplConArgs [] thing_inside - = thing_inside [] - -simplConArgs (arg:args) thing_inside - = switchOffInlining (simplExpr arg) `thenSmpl` \ arg' -> - -- Simplify the RHS with inlining switched off, so that - -- only absolutely essential things will happen. - - simplConArgs args $ \ args' -> - - -- If the argument ain't trivial, then let-bind it - if exprIsTrivial arg' then - thing_inside (arg' : args') - else - newId (coreExprType arg') $ \ arg_id -> - thing_inside (Var arg_id : args') `thenSmpl` \ res -> - returnSmpl (addBind (NonRec arg_id arg') res) -\end{code} - +%************************************************************************ +%* * +\subsection{Notes} +%* * +%************************************************************************ ---------------------------------- \begin{code} -simplType :: InType -> SimplM OutType -simplType ty - = getSubst `thenSmpl` \ subst -> - let - new_ty = substTy subst ty +simplNote env (Coerce to from) body cont + = let + addCoerce s1 k1 cont -- Drop redundant coerces. This can happen if a polymoprhic + -- (coerce a b e) is instantiated with a=ty1 b=ty2 and the + -- two are the same. This happens a lot in Happy-generated parsers + | s1 `coreEqType` k1 = cont + + 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 `coreEqType` 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) + | not (isTypeArg arg), -- This whole case only works for value args + -- Could upgrade to have equiv thing for type apps too + 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, because it's applied to something + -- 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 = mkCoerce2 s1 t1 (substExpr arg_env arg) + arg_env = setInScope arg_se env + in + ApplyTo dup new_arg (zapSubstEnv env) (addCoerce t2 s2 cont) + + addCoerce to' _ cont = CoerceIt to' cont in - seqType new_ty `seq` - returnSmpl new_ty + simplType env to `thenSmpl` \ to' -> + simplType env from `thenSmpl` \ from' -> + simplExprF env body (addCoerce to' from' cont) + + +-- 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 + +simplNote env (CoreNote s) e cont + = simplExpr env e `thenSmpl` \ e' -> + rebuild env (Note (CoreNote s) e') cont \end{code} %************************************************************************ %* * -\subsection{Binding} +\subsection{Dealing with calls} %* * %************************************************************************ -@simplBeta@ is used for non-recursive lets in expressions, -as well as true beta reduction. - -Very similar to @simplLazyBind@, but not quite the same. - \begin{code} -simplBeta :: InId -- Binder - -> InExpr -> SubstEnv -- Arg, with its subst-env - -> OutType -- Type of thing computed by the context - -> SimplM OutExprStuff -- The body - -> SimplM OutExprStuff -#ifdef DEBUG -simplBeta bndr rhs rhs_se cont_ty thing_inside - | isTyVar bndr - = pprPanic "simplBeta" (ppr bndr <+> ppr rhs) -#endif - -simplBeta bndr rhs rhs_se cont_ty thing_inside - | preInlineUnconditionally bndr && not opt_SimplNoPreInlining - = tick (PreInlineUnconditionally bndr) `thenSmpl_` - extendSubst bndr (ContEx rhs_se rhs) thing_inside - - | otherwise - = -- Simplify the RHS - simplBinder bndr $ \ bndr' -> - simplArg (idType bndr') (getIdDemandInfo bndr) - rhs rhs_se cont_ty $ \ rhs' -> +simplVar env var cont + = case substId env var of + DoneEx e -> simplExprF (zapSubstEnv env) e cont + ContEx tvs ids e -> simplExprF (setSubstEnv env tvs ids) e cont + DoneId var1 occ -> completeCall (zapSubstEnv env) var1 occ cont + -- Note [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!! - -- Now complete the binding and simplify the body - completeBeta bndr bndr' rhs' thing_inside +--------------------------------------------------------- +-- Dealing with a call site -completeBeta bndr bndr' rhs' thing_inside - | isUnLiftedType (idType bndr') && not (exprOkForSpeculation rhs') - -- Make a case expression instead of a let - -- These can arise either from the desugarer, - -- or from beta reductions: (\x.e) (x +# y) - = getInScope `thenSmpl` \ in_scope -> - thing_inside `thenSmpl` \ (floats, (_, body)) -> - returnSmpl ([], (in_scope, Case rhs' bndr' [(DEFAULT, [], mkLets floats body)])) +completeCall env var occ_info cont + = -- Simplify the arguments + getDOptsSmpl `thenSmpl` \ dflags -> + let + chkr = getSwitchChecker env + (args, call_cont, inline_call) = getContArgs chkr var cont + fn_ty = idType var + in + simplifyArgs env fn_ty args (contResultType call_cont) $ \ env args -> - | otherwise - = completeBinding bndr bndr' False rhs' thing_inside -\end{code} + -- Next, look for rules or specialisations that match + -- + -- It's important to simplify the args first, because the rule-matcher + -- doesn't do substitution as it goes. We don't want to use subst_args + -- (defined in the 'where') because that throws away useful occurrence info, + -- and perhaps-very-important specialisations. + -- + -- Some functions have specialisations *and* are strict; in this case, + -- we don't want to inline the wrapper of the non-specialised thing; better + -- to call the specialised thing instead. + -- We used to use the black-listing mechanism to ensure that inlining of + -- the wrapper didn't occur for things that have specialisations till a + -- later phase, so but now we just try RULES 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 + in_scope = getInScope env + rules = getRules env + maybe_rule = case activeRule env of + Nothing -> Nothing -- No rules apply + Just act_fn -> lookupRule act_fn in_scope rules 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:" <+> ftext rule_name, + text "Before:" <+> ppr var <+> sep (map pprParendExpr args), + text "After: " <+> pprCoreExpr rule_rhs, + text "Cont: " <+> ppr call_cont]) + else + id) $ + simplExprF env rule_rhs call_cont ; + + Nothing -> -- No rules -\begin{code} -simplArg :: OutType -> Demand - -> InExpr -> SubstEnv - -> OutType -- Type of thing computed by the context - -> (OutExpr -> SimplM OutExprStuff) - -> SimplM OutExprStuff -simplArg arg_ty demand arg arg_se cont_ty thing_inside - | isStrict demand || - isUnLiftedType arg_ty || - (opt_DictsStrict && isDictTy arg_ty && isDataType arg_ty) - -- 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) - = getSubstEnv `thenSmpl` \ body_se -> - transformRhs arg `thenSmpl` \ t_arg -> - setSubstEnv arg_se (simplExprF t_arg (ArgOf NoDup cont_ty $ \ arg' -> - setSubstEnv body_se (thing_inside arg') - )) -- NB: we must restore body_se before carrying on with thing_inside!! + -- Next, look for an inlining + let + arg_infos = [ interestingArg arg | arg <- args, isValArg arg] - | otherwise - = simplRhs NotTopLevel True arg_ty arg arg_se thing_inside -\end{code} + interesting_cont = interestingCallContext (notNull args) + (notNull arg_infos) + call_cont + active_inline = activeInline env var occ_info + maybe_inline = callSiteInline dflags active_inline inline_call occ_info + var arg_infos interesting_cont + in + case maybe_inline of { + Just unfolding -- There is an inlining! + -> tick (UnfoldingDone var) `thenSmpl_` + (if dopt Opt_D_dump_inlinings dflags then + pprTrace "Inlining done" (vcat [ + text "Before:" <+> ppr var <+> sep (map pprParendExpr args), + text "Inlined fn: " <+> ppr unfolding, + text "Cont: " <+> ppr call_cont]) + else + id) $ + makeThatCall env var unfolding args call_cont + + ; + Nothing -> -- No inlining! + + -- Done + rebuild env (mkApps (Var var) args) call_cont + }} + +makeThatCall :: SimplEnv + -> Id + -> InExpr -- Inlined function rhs + -> [OutExpr] -- Arguments, already simplified + -> SimplCont -- After the call + -> SimplM FloatsWithExpr +-- Similar to simplLam, but this time +-- the arguments are already simplified +makeThatCall orig_env var fun@(Lam _ _) args cont + = go orig_env fun args + where + zap_it = mkLamBndrZapper fun (length args) -completeBinding - - deals only with Ids, not TyVars - - take an already-simplified RHS + -- Type-beta reduction + go env (Lam bndr body) (Type ty_arg : args) + = ASSERT( isTyVar bndr ) + tick (BetaReduction bndr) `thenSmpl_` + go (extendTvSubst env bndr ty_arg) body args -It does *not* attempt to do let-to-case. Why? Because they are used for + -- Ordinary beta reduction + go env (Lam bndr body) (arg : args) + = tick (BetaReduction bndr) `thenSmpl_` + simplNonRecX env (zap_it bndr) arg $ \ env -> + go env body args + + -- Not enough args, so there are real lambdas left to put in the result + go env fun args + = simplExprF env fun (pushContArgs orig_env args cont) + -- NB: orig_env; the correct environment to capture with + -- the arguments.... env has been augmented with substitutions + -- from the beta reductions. + +makeThatCall env var fun args cont + = simplExprF env fun (pushContArgs env args cont) +\end{code} - - 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). +%************************************************************************ +%* * +\subsection{Arguments} +%* * +%************************************************************************ \begin{code} -completeBinding :: InId -- Binder - -> OutId -- New binder - -> Bool -- True <=> black-listed; don't inline - -> OutExpr -- Simplified RHS - -> SimplM (OutStuff a) -- Thing inside - -> SimplM (OutStuff a) - -completeBinding old_bndr new_bndr black_listed new_rhs thing_inside - | isDeadBinder old_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 - - | not black_listed && postInlineUnconditionally old_bndr new_rhs - -- Maybe we don't need a let-binding! Maybe we can just - -- inline it right away. Unlike the preInlineUnconditionally case - -- we are allowed to look at the RHS. - -- - -- NB: a loop breaker never has postInlineUnconditionally True - -- and non-loop-breakers only have *forward* references - -- Hence, it's safe to discard the binding - = tick (PostInlineUnconditionally old_bndr) `thenSmpl_` - extendSubst old_bndr (DoneEx new_rhs) - thing_inside - - | otherwise - = getSubst `thenSmpl` \ subst -> - let - -- We make new IdInfo for the new binder by starting from the old binder, - -- doing appropriate substitutions, - new_bndr_info = substIdInfo subst (idInfo old_bndr) (idInfo new_bndr) - `setArityInfo` ArityAtLeast (exprArity new_rhs) - - -- At the *binding* site we use the new binder info - binding_site_id = new_bndr `setIdInfo` new_bndr_info - - -- At the *occurrence* sites we want to know the unfolding - -- We also want the occurrence info of the *original* - occ_site_id = new_bndr `setIdInfo` - (new_bndr_info `setUnfoldingInfo` mkUnfolding new_rhs - `setInlinePragInfo` getInlinePragma old_bndr) - in - -- These seqs force the Ids, and hence the IdInfos, and hence any - -- inner substitutions - binding_site_id `seq` - occ_site_id `seq` - - (modifyInScope occ_site_id thing_inside `thenSmpl` \ stuff -> - returnSmpl (addBind (NonRec binding_site_id new_rhs) stuff)) -\end{code} +--------------------------------------------------------- +-- Simplifying the arguments of a call + +simplifyArgs :: SimplEnv + -> OutType -- Type of the function + -> [(InExpr, SimplEnv, Bool)] -- Details of the arguments + -> OutType -- Type of the continuation + -> (SimplEnv -> [OutExpr] -> SimplM FloatsWithExpr) + -> SimplM FloatsWithExpr + +-- [CPS-like because of strict arguments] + +-- Simplify the arguments to a call. +-- This part of the simplifier may break the no-shadowing invariant +-- Consider +-- f (...(\a -> e)...) (case y of (a,b) -> e') +-- where f is strict in its second arg +-- If we simplify the innermost one first we get (...(\a -> e)...) +-- Simplifying the second arg makes us float the case out, so we end up with +-- case y of (a,b) -> f (...(\a -> e)...) e' +-- So the output does not have the no-shadowing invariant. However, there is +-- no danger of getting name-capture, because when the first arg was simplified +-- we used an in-scope set that at least mentioned all the variables free in its +-- static environment, and that is enough. +-- +-- We can't just do innermost first, or we'd end up with a dual problem: +-- case x of (a,b) -> f e (...(\a -> e')...) +-- +-- I spent hours trying to recover the no-shadowing invariant, but I just could +-- not think of an elegant way to do it. The simplifier is already knee-deep in +-- continuations. We have to keep the right in-scope set around; AND we have +-- to get the effect that finding (error "foo") in a strict arg position will +-- discard the entire application and replace it with (error "foo"). Getting +-- all this at once is TOO HARD! + +simplifyArgs env fn_ty args cont_ty thing_inside + = go env fn_ty args thing_inside + where + go env fn_ty [] thing_inside = thing_inside env [] + go env fn_ty (arg:args) thing_inside = simplifyArg env fn_ty arg cont_ty $ \ env arg' -> + go env (applyTypeToArg fn_ty arg') args $ \ env args' -> + thing_inside env (arg':args') + +simplifyArg env fn_ty (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 fn_ty (val_arg, arg_se, is_strict) cont_ty thing_inside + | is_strict + = simplStrictArg AnArg env val_arg arg_se arg_ty cont_ty thing_inside + + | otherwise -- Lazy argument + -- DO NOT float anything outside, hence simplExprC + -- There is no benefit (unlike in a let-binding), and we'd + -- have to be very careful about bogus strictness through + -- floating a demanded let. + = simplExprC (setInScope arg_se env) val_arg + (mkBoringStop arg_ty) `thenSmpl` \ arg1 -> + thing_inside env arg1 + where + arg_ty = funArgTy fn_ty + + +simplStrictArg :: LetRhsFlag + -> SimplEnv -- The env of the call + -> InExpr -> SimplEnv -- The arg plus its env + -> OutType -- arg_ty: type of the argument + -> 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 is_rhs call_env arg arg_env arg_ty cont_ty thing_inside + = simplExprF (setInScope arg_env call_env) arg + (ArgOf is_rhs arg_ty 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} %************************************************************************ %* * -\subsection{simplLazyBind} +\subsection{mkAtomicArgs} %* * %************************************************************************ -simplLazyBind basically just simplifies the RHS of a let(rec). -It does two important optimisations though: +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) - * It floats let(rec)s out of the RHS, even if they - are hidden by big lambdas - - * It does eta expansion - -\begin{code} -simplLazyBind :: TopLevelFlag - -> InId -> OutId - -> InExpr -- The RHS - -> SimplM (OutStuff a) -- The body of the binding - -> SimplM (OutStuff a) --- When called, the subst env is correct for the entire let-binding --- and hence right for the RHS. --- Also the binder has already been simplified, and hence is in scope - -simplLazyBind top_lvl bndr bndr' rhs thing_inside - = getBlackList `thenSmpl` \ black_list_fn -> - let - black_listed = isTopLevel top_lvl && black_list_fn bndr - -- Only top level things can be black listed, so the - -- first test gets us 'False' without having to call - -- the function, in the common case. - in - if not black_listed && - preInlineUnconditionally bndr && - not opt_SimplNoPreInlining - then - tick (PreInlineUnconditionally bndr) `thenSmpl_` - getSubstEnv `thenSmpl` \ rhs_se -> - (extendSubst bndr (ContEx rhs_se rhs) thing_inside) - - else -- Simplify the RHS - getSubstEnv `thenSmpl` \ rhs_se -> - simplRhs top_lvl False {- Not ok to float unboxed -} - (idType bndr') - rhs rhs_se $ \ rhs' -> - - -- Now compete the binding and simplify the body - completeBinding bndr bndr' black_listed rhs' thing_inside -\end{code} +There are three sorts of binding context, specified by the two +boolean arguments +Strict + OK-unlifted +N N Top-level or recursive Only bind args of lifted type -\begin{code} -simplRhs :: TopLevelFlag - -> Bool -- True <=> OK to float unboxed (speculative) bindings - -> OutType -> InExpr -> SubstEnv - -> (OutExpr -> SimplM (OutStuff a)) - -> SimplM (OutStuff a) -simplRhs top_lvl float_ubx rhs_ty rhs rhs_se thing_inside - = -- Swizzle the inner lets past the big lambda (if any) - -- and try eta expansion - transformRhs rhs `thenSmpl` \ t_rhs -> - - -- Simplify it - setSubstEnv rhs_se (simplExprF t_rhs (Stop rhs_ty)) `thenSmpl` \ (floats, (in_scope', rhs')) -> - - -- Float lets out of RHS - let - (floats_out, rhs'') | float_ubx = (floats, rhs') - | otherwise = splitFloats floats rhs' - in - if (isTopLevel top_lvl || exprIsCheap rhs') && -- Float lets if (a) we're at the top level - not (null floats_out) -- or (b) it exposes a cheap (i.e. duplicatable) expression - then - tickLetFloat floats_out `thenSmpl_` - -- Do the float - -- - -- 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 floats_out, ppr floats_out ) - setInScope in_scope' (thing_inside rhs'') `thenSmpl` \ stuff -> - -- in_scope' may be excessive, but that's OK; - -- it's a superset of what's in scope - returnSmpl (addBinds floats_out stuff) - else - -- Don't do the float - thing_inside (mkLets floats rhs') +N Y Non-top-level and non-recursive, Bind args of lifted type, or + but lazy unlifted-and-ok-for-speculation --- In a let-from-let float, we just tick once, arbitrarily --- choosing the first floated binder to identify it -tickLetFloat (NonRec b r : fs) = tick (LetFloatFromLet b) -tickLetFloat (Rec ((b,r):prs) : fs) = tick (LetFloatFromLet b) +Y Y Non-top-level, non-recursive, Bind all args + and strict (demanded) -demanded_float (NonRec b r) = isStrict (getIdDemandInfo b) && not (isUnLiftedType (idType b)) - -- Unlifted-type (cheap-eagerness) lets may well have a demanded flag on them -demanded_float (Rec _) = False --- Don't float any unlifted bindings out, because the context --- is either a Rec group, or the top level, neither of which --- can tolerate them. -splitFloats floats rhs - = go floats - where - go [] = ([], rhs) - go (f:fs) | must_stay f = ([], mkLets (f:fs) rhs) - | otherwise = case go fs of - (out, rhs') -> (f:out, rhs') +For example, given - must_stay (Rec prs) = False -- No unlifted bindings in here - must_stay (NonRec b r) = isUnLiftedType (idType b) -\end{code} + x = MkC (y div# z) +there is no point in transforming to + x = case (y div# z) of r -> MkC r -%************************************************************************ -%* * -\subsection{Variables} -%* * -%************************************************************************ +because the (y div# z) can't float out of the let. But if it was +a *strict* let, then it would be a good thing to do. Hence the +context information. \begin{code} -simplVar var cont - = getSubst `thenSmpl` \ subst -> - case lookupSubst subst var of - Just (DoneEx (Var v)) -> zapSubstEnv (simplVar v cont) - Just (DoneEx e) -> zapSubstEnv (simplExprF e cont) - Just (ContEx env' e) -> setSubstEnv env' (simplExprF e cont) - - Nothing -> let - var' = case lookupInScope subst var of - Just v' -> v' - Nothing -> -#ifdef DEBUG - if isLocallyDefined var && not (idMustBeINLINEd var) - -- The idMustBeINLINEd test accouunts for the fact - -- that class dictionary constructors don't have top level - -- bindings and hence aren't in scope. - then - -- Not in scope - pprTrace "simplVar:" (ppr var) var - else -#endif - var - in - getBlackList `thenSmpl` \ black_list -> - getInScope `thenSmpl` \ in_scope -> - completeCall black_list in_scope var var' cont +mkAtomicArgs :: Bool -- A strict binding + -> Bool -- OK to float unlifted args + -> OutExpr + -> SimplM (OrdList (OutId,OutExpr), -- The floats (unusually) may include + OutExpr) -- things that need case-binding, + -- if the strict-binding flag is on ---------------------------------------------------------- --- Dealing with a call - -completeCall black_list_fn in_scope orig_var var cont --- For reasons I'm not very clear about, it's important *not* to plug 'var', --- which is replete with an inlining in its IdInfo, into the resulting expression --- Doing so results in a significant space leak. --- Instead we pass orig_var, which has no inlinings etc. - - -- Look for rules or specialisations that match - -- Do this *before* trying inlining because some functions - -- have specialisations *and* are strict; we don't want to - -- inline the wrapper of the non-specialised thing... better - -- to call the specialised thing instead. - | maybeToBool maybe_rule_match - = tick (RuleFired rule_name) `thenSmpl_` - zapSubstEnv (simplExprF rule_rhs (pushArgs emptySubstEnv rule_args result_cont)) - -- See note below about zapping the substitution here - - -- Look for an unfolding. There's a binding for the - -- thing, but perhaps we want to inline it anyway - | maybeToBool maybe_inline - = tick (UnfoldingDone var) `thenSmpl_` - zapSubstEnv (completeInlining orig_var unf_template discard_inline_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!! - - | otherwise -- Neither rule nor inlining - -- Use prepareArgs to use function strictness - = prepareArgs (ppr var) (idType var) (get_str var) cont $ \ args' cont' -> - rebuild (mkApps (Var orig_var) args') cont' +mkAtomicArgs is_strict ok_float_unlifted rhs + | (Var fun, args) <- collectArgs rhs, -- It's an application + isDataConWorkId fun || valArgCount args < idArity fun -- And it's a constructor or PAP + = go fun nilOL [] args -- Have a go + + | otherwise = bale_out -- Give up where - get_str var = case getIdStrictness var of - NoStrictnessInfo -> (repeat wwLazy, False) - StrictnessInfo demands result_bot -> (demands, result_bot) - - - (args', result_cont) = contArgs in_scope cont - val_args = filter isValArg args' - arg_infos = map (interestingArg in_scope) val_args - inline_call = contIsInline result_cont - interesting_cont = contIsInteresting result_cont - discard_inline_cont | inline_call = discardInline cont - | otherwise = cont - - ---------- Unfolding stuff - maybe_inline = callSiteInline black_listed inline_call - var arg_infos interesting_cont - Just unf_template = maybe_inline - black_listed = black_list_fn var - - ---------- Specialisation stuff - maybe_rule_match = lookupRule in_scope var args' - Just (rule_name, rule_rhs, rule_args) = maybe_rule_match - - - --- An argument is interesting if it has *some* structure --- We are here trying to avoid unfolding a function that --- is applied only to variables that have no unfolding --- (i.e. they are probably lambda bound): f x y z --- There is little point in inlining f here. -interestingArg in_scope (Type _) = False -interestingArg in_scope (App fn (Type _)) = interestingArg in_scope fn -interestingArg in_scope (Var v) = hasSomeUnfolding (getIdUnfolding v') - where - v' = case lookupVarSet in_scope v of - Just v' -> v' - other -> v -interestingArg in_scope other = True - - --- First a special case --- 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. -completeInlining var (Con con con_args) (Select _ bndr alts se cont) - | conOkForAlt con - = knownCon (Var var) con con_args bndr alts se cont - --- Now the normal case -completeInlining var unfolding cont - = simplExprF unfolding cont - ------------ 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} + bale_out = returnSmpl (nilOL, rhs) + go fun binds rev_args [] + = returnSmpl (binds, mkApps (Var fun) (reverse rev_args)) -\begin{code} ---------------------------------------------------------- --- Preparing arguments for a call + go fun binds rev_args (arg : args) + | exprIsTrivial arg -- Easy case + = go fun binds (arg:rev_args) args -prepareArgs :: SDoc -- Error message info - -> OutType -> ([Demand],Bool) -> SimplCont - -> ([OutExpr] -> SimplCont -> SimplM OutExprStuff) - -> SimplM OutExprStuff + | not can_float_arg -- Can't make this arg atomic + = bale_out -- ... so give up -prepareArgs pp_fun orig_fun_ty (fun_demands, result_bot) orig_cont thing_inside - = go [] demands orig_fun_ty orig_cont - where - not_enough_args = fun_demands `lengthExceeds` countValArgs orig_cont - -- "No strictness info" is signalled by an infinite list of wwLazy - - demands | not_enough_args = repeat wwLazy -- Not enough args, or no strictness - | result_bot = fun_demands -- Enough args, and function returns bottom - | otherwise = fun_demands ++ repeat wwLazy -- Enough args and function does not return bottom - -- NB: demands is finite iff enough args and result_bot is True - - -- Main game plan: loop through the arguments, simplifying - -- each of them in turn. We carry with us a list of demands, - -- and the type of the function-applied-to-earlier-args - - -- Type argument - go acc ds fun_ty (ApplyTo _ arg@(Type ty_arg) se cont) - = getInScope `thenSmpl` \ in_scope -> - let - ty_arg' = substTy (mkSubst in_scope se) ty_arg - res_ty = applyTy fun_ty ty_arg' - in - seqType ty_arg' `seq` - go (Type ty_arg' : acc) ds res_ty cont - - -- Value argument - go acc (d:ds) fun_ty (ApplyTo _ val_arg se cont) - = case splitFunTy_maybe fun_ty of { - Nothing -> pprTrace "prepareArgs" (pp_fun $$ ppr orig_fun_ty $$ ppr orig_cont) - (thing_inside (reverse acc) cont) ; - Just (arg_ty, res_ty) -> - simplArg arg_ty d val_arg se (contResultType cont) $ \ arg' -> - go (arg':acc) ds res_ty cont } - - -- We've run out of demands, which only happens for functions - -- we *know* now return bottom - -- This deals with - -- * case (error "hello") of { ... } - -- * (error "Hello") arg - -- * f (error "Hello") where f is strict - -- etc - go acc [] fun_ty cont = tick_case_of_error cont `thenSmpl_` - thing_inside (reverse acc) (discardCont cont) - - -- We're run out of arguments - go acc ds fun_ty cont = thing_inside (reverse acc) cont - --- Boring: we must only record a tick if there was an interesting --- continuation to discard. If not, we tick forever. -tick_case_of_error (Stop _) = returnSmpl () -tick_case_of_error (CoerceIt _ (Stop _)) = returnSmpl () -tick_case_of_error other = tick BottomFound -\end{code} - -%************************************************************************ -%* * -\subsection{Decisions about inlining} -%* * -%************************************************************************ + | otherwise -- Don't forget to do it recursively + -- E.g. x = a:b:c:[] + = mkAtomicArgs is_strict ok_float_unlifted arg `thenSmpl` \ (arg_binds, arg') -> + newId FSLIT("a") arg_ty `thenSmpl` \ arg_id -> + go fun ((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 ) + (let body = wrapFloats floats expr in + returnSmpl (emptyFloats env, Case r v (exprType body) [(DEFAULT,[],body)])) -\begin{code} -preInlineUnconditionally :: InId -> Bool - -- Examines a bndr to see if it is used just once in a - -- completely safe way, so that it is safe to discard the binding - -- inline its RHS at the (unique) usage site, REGARDLESS of how - -- big the RHS might be. If this is the case we don't simplify - -- the RHS first, but just inline it un-simplified. - -- - -- This is much better than first simplifying a perhaps-huge RHS - -- and then inlining and re-simplifying it. - -- - -- NB: we don't even look at the RHS to see if it's trivial - -- We might have - -- x = y - -- where x is used many times, but this is the unique occurrence - -- of y. We should NOT inline x at all its uses, because then - -- we'd do the same for y -- aargh! So we must base this - -- pre-rhs-simplification decision solely on x's occurrences, not - -- on its rhs. - -- - -- Evne RHSs labelled InlineMe aren't caught here, because - -- there might be no benefit from inlining at the call site. - -- But things labelled 'IMustBeINLINEd' *are* caught. We use this - -- for the trivial bindings introduced by SimplUtils.mkRhsTyLam -preInlineUnconditionally bndr - = case getInlinePragma bndr of - IMustBeINLINEd -> True - ICanSafelyBeINLINEd NotInsideLam 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 - | isExportedId bndr - = False | otherwise - = case getInlinePragma bndr of - IAmALoopBreaker -> False - - ICanSafelyBeINLINEd InsideLam one_branch -> exprIsTrivial rhs - -- Don't inline even WHNFs inside lambdas; doing so may - -- simply increase allocation when the function is called - -- This isn't the last chance; see NOTE above. - - ICanSafelyBeINLINEd not_in_lam one_branch -> one_branch || exprIsTrivial rhs - -- Was 'exprIsDupable' instead of 'exprIsTrivial' but the - -- decision about duplicating code is best left to callSiteInline - - other -> exprIsTrivial rhs -- Duplicating is *free* - -- NB: Even InlineMe and IMustBeINLINEd are ignored here - -- Why? Because we don't even want to inline them into the - -- RHS of constructor arguments. See NOTE above - -- NB: Even IMustBeINLINEd is ignored here: if the rhs is trivial - -- it's best to inline it anyway. We often get a=E; b=a - -- from desugaring, with both a and b marked NOINLINE. + = addAuxiliaryBind env (NonRec v r) $ \ env -> + addAtomicBindsE env bs thing_inside \end{code} - %************************************************************************ %* * \subsection{The main rebuilder} @@ -969,380 +1278,285 @@ postInlineUnconditionally bndr rhs %************************************************************************ \begin{code} -------------------------------------------------------------------- --- Finish rebuilding -rebuild_done expr - = getInScope `thenSmpl` \ in_scope -> - returnSmpl ([], (in_scope, expr)) +rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM FloatsWithExpr ---------------------------------------------------------- -rebuild :: OutExpr -> SimplCont -> SimplM OutExprStuff - --- Stop continuation -rebuild expr (Stop _) = rebuild_done expr - --- ArgOf continuation -rebuild expr (ArgOf _ _ cont_fn) = cont_fn expr - --- ApplyTo continuation -rebuild expr cont@(ApplyTo _ arg se cont') - = setSubstEnv se (simplExpr arg) `thenSmpl` \ arg' -> - rebuild (App expr arg') cont' - --- Coerce continuation -rebuild expr (CoerceIt to_ty cont) - = rebuild (mkCoerce to_ty expr) cont - --- Inline continuation -rebuild expr (InlinePlease cont) - = rebuild (Note InlineCall 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 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 --- Case of known constructor or literal -rebuild expr@(Con con args) (Select _ bndr alts se cont) - | conOkForAlt con -- Knocks out PrimOps and NoRepLits - = knownCon expr con args bndr alts se cont - - ---------------------------------------------------------- --- The other Select cases - -rebuild scrut (Select _ bndr alts se cont) - | -- Check that the RHSs are all the same, and - -- don't use the binders in the alternatives - -- This test succeeds rapidly in the common case of - -- a single DEFAULT alternative - all (cheapEqExpr rhs1) other_rhss && all binders_unused alts - - -- Check that the scrutinee can be let-bound instead of case-bound - && ( exprOkForSpeculation scrut - -- OK not to evaluate it - -- This includes things like (==# a# b#)::Bool - -- so that we simplify - -- case ==# a# b# of { True -> x; False -> x } - -- to just - -- x - -- This particular example shows up in default methods for - -- comparision operations (e.g. in (>=) for Int.Int32) - || exprIsValue scrut -- It's already evaluated - || var_demanded_later scrut -- It'll be demanded later - --- || not opt_SimplPedanticBottoms) -- Or we don't care! --- We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on, --- but that breaks badly for the dataToTag# primop, which relies on a case to evaluate --- its argument: case x of { y -> dataToTag# y } --- Here we must *not* discard the case, because dataToTag# just fetches the tag from --- the info pointer. So we'll be pedantic all the time, and see if that gives any --- other problems - ) - --- && opt_SimplDoCaseElim --- [June 99; don't test this flag. The code generator dies if it sees --- case (\x.e) of f -> ... --- so better to always do it - - -- Get rid of the case altogether - -- See the extensive notes on case-elimination below - -- Remember to bind the binder though! - = tick (CaseElim bndr) `thenSmpl_` ( - setSubstEnv se $ - simplBinder bndr $ \ bndr' -> - completeBinding bndr bndr' False scrut $ - simplExprF rhs1 cont) - - | otherwise - = rebuild_case scrut bndr alts se cont - where - (rhs1:other_rhss) = [rhs | (_,_,rhs) <- alts] - binders_unused (_, bndrs, _) = all isDeadBinder bndrs +rebuildApp env fun arg cont + = simplExpr env arg `thenSmpl` \ arg' -> + rebuild env (App fun arg') cont - var_demanded_later (Var v) = isStrict (getIdDemandInfo bndr) -- It's going to be evaluated later - var_demanded_later other = False +rebuildDone env expr = returnSmpl (emptyFloats env, expr) \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: +%************************************************************************ +%* * +\subsection{Functions dealing with a case} +%* * +%************************************************************************ - case e of - x -> ...x... +Blob of helper functions for the "case-of-something-else" situation. -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) +\begin{code} +--------------------------------------------------------- +-- Eliminate the case if possible -Lastly, we generalise the transformation to handle this: +rebuildCase :: SimplEnv + -> OutExpr -- Scrutinee + -> InId -- Case binder + -> [InAlt] -- Alternatives (inceasing order) + -> SimplCont + -> SimplM FloatsWithExpr - case e of ===> r - True -> r - False -> r +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 -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. + | Lit lit <- scrut -- No need for same treatment as constructors + -- because literals are inlined more vigorously + = knownCon env (LitAlt lit) [] case_bndr alts cont -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. + | otherwise + = -- Prepare the alternatives. + prepareAlts scrut case_bndr alts `thenSmpl` \ (better_alts, handled_cons) -> + + -- Prepare the continuation; + -- The new subst_env is in place + prepareCaseCont env better_alts cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) -> + addFloats env floats $ \ env -> -So the case-elimination algorithm is: + let + -- The case expression is annotated with the result type of the continuation + -- This may differ from the type originally on the case. For example + -- case(T) (case(Int#) a of { True -> 1#; False -> 0# }) of + -- a# -> + -- ===> + -- let j a# = + -- in case(T) a of { True -> j 1#; False -> j 0# } + -- Note that the case that scrutinises a now returns a T not an Int# + res_ty' = contResultType dup_cont + in - 1. Eliminate alternatives which can't match + -- Deal with case binder + simplCaseBinder env scrut case_bndr `thenSmpl` \ (alt_env, case_bndr') -> - 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 + -- Deal with the case alternatives + simplAlts alt_env handled_cons + case_bndr' better_alts dup_cont `thenSmpl` \ alts' -> - 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! + -- Put the case back together + mkCase scrut case_bndr' res_ty' alts' `thenSmpl` \ case_expr -> - or * [Prim cases] the scrutinee is a primitive variable + -- Notice that rebuildDone returns the in-scope set from env, not alt_env + -- The case binder *not* scope over the whole returned case-expression + rebuild env case_expr nondup_cont +\end{code} - 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.] +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. +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. -If so, then we can replace the case with one of the rhss. +Note 2 +~~~~~~ +There is another situation when we don't want to do it. If we have + case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 } + ...other cases .... } -Blob of helper functions for the "case-of-something-else" situation. +We'll perform the binder-swap for the outer case, giving -\begin{code} ---------------------------------------------------------- --- Case of something else + case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 } + ...other cases .... } -rebuild_case scrut case_bndr alts se cont - = -- Prepare case alternatives - prepareCaseAlts case_bndr (splitTyConApp_maybe (idType case_bndr)) - scrut_cons alts `thenSmpl` \ better_alts -> - - -- Set the new subst-env in place (before dealing with the case binder) - setSubstEnv se $ +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 - -- Deal with the case binder, and prepare the continuation; - -- The new subst_env is in place - prepareCaseCont better_alts cont $ \ cont' -> - + case x of w1 { A -> let w2 = w1 in e1 + B -> let w2 = w1 in e2 + ...other cases .... } - -- Deal with variable scrutinee - ( simplBinder case_bndr $ \ case_bndr' -> - substForVarScrut scrut case_bndr' $ \ zap_occ_info -> - let - case_bndr'' = zap_occ_info case_bndr' - in +This is plain silly in the common case where w2 is dead. - -- Deal with the case alternaatives - simplAlts zap_occ_info scrut_cons - case_bndr'' better_alts cont' `thenSmpl` \ alts' -> +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: - mkCase scrut case_bndr'' alts' - ) `thenSmpl` \ case_expr -> + data T = MkT !Int - -- Notice that the simplBinder, prepareCaseCont, etc, do *not* scope - -- over the rebuild_done; rebuild_done returns the in-scope set, and - -- that should not include these chaps! - rebuild_done case_expr - where - -- scrut_cons tells what constructors the scrutinee can't possibly match - scrut_cons = case scrut of - Var v -> otherCons (getIdUnfolding v) - other -> [] + case v of w { MkT x -> + case x of x1 { I# y1 -> + case x of x2 { I# y2 -> ... +Notice that because MkT is strict, x is marked "evaluated". But to +eliminate the last case, we must either make sure that x (as well as +x1) has unfolding MkT y1. THe straightforward thing to do is to do +the binder-swap. So this whole note is a no-op. -knownCon expr con args bndr alts se cont - = tick (KnownBranch bndr) `thenSmpl_` - setSubstEnv se ( - simplBinder bndr $ \ bndr' -> - case findAlt con alts of - (DEFAULT, bs, rhs) -> ASSERT( null bs ) - completeBinding bndr bndr' False expr $ - -- Don't use completeBeta here. The expr might be - -- an unboxed literal, like 3, or a variable - -- whose unfolding is an unboxed literal... and - -- completeBeta will just construct another case - -- expression! - simplExprF rhs cont - - (Literal lit, bs, rhs) -> ASSERT( null bs ) - extendSubst bndr (DoneEx 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. - simplExprF rhs cont - - (DataCon dc, bs, rhs) -> ASSERT( length bs == length real_args ) - completeBinding bndr bndr' False expr $ - -- See note above - extendSubstList bs (map mk real_args) $ - simplExprF rhs cont - where - real_args = drop (dataConNumInstArgs dc) args - mk (Type ty) = DoneTy ty - mk other = DoneEx other - ) -\end{code} - -\begin{code} -prepareCaseCont :: [InAlt] -> SimplCont - -> (SimplCont -> SimplM (OutStuff a)) - -> SimplM (OutStuff a) - -- Polymorphic recursion here! - -prepareCaseCont [alt] cont thing_inside = thing_inside cont -prepareCaseCont alts cont thing_inside = mkDupableCont (coreAltsType alts) 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 of { (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. + +Indeed, this can happen anytime the case binder isn't dead: + case of x { (a,b) -> + case x of { (p,q) -> p } } +Here (a,b) both look dead, but come alive after the inner case is eliminated. +The point is that we bring into the envt a binding + let x = (a,b) +after the outer case, and that makes (a,b) alive. At least we do unless +the case binder is guaranteed dead. \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') -- 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 does 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') \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 bndr (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 bndr) `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 +simplAlts :: SimplEnv + -> [AltCon] -- Alternatives the scrutinee can't be + -- in the default case + -> OutId -- Case binder + -> [InAlt] -> SimplCont + -> SimplM [OutAlt] -- Includes the continuation + +simplAlts env handled_cons case_bndr' alts cont' + = do { mb_alts <- mapSmpl simpl_alt alts + ; return [alt' | Just (_, alt') <- mb_alts] } + -- Filter out the alternatives that are inaccessible + where + simpl_alt alt = simplAlt env handled_cons case_bndr' alt cont' + +simplAlt :: SimplEnv -> [AltCon] -> OutId -> InAlt -> SimplCont + -> SimplM (Maybe (TvSubstEnv, OutAlt)) +-- Simplify an alternative, returning the type refinement for the +-- alternative, if the alternative does any refinement at all +-- Nothing => the alternative is inaccessible + +simplAlt env handled_cons case_bndr' (DEFAULT, bndrs, rhs) cont' + = ASSERT( null bndrs ) + simplExprC env' rhs cont' `thenSmpl` \ rhs' -> + returnSmpl (Just (emptyVarEnv, (DEFAULT, [], rhs'))) 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)] + env' = mk_rhs_env env case_bndr' (mkOtherCon handled_cons) + -- Record the constructors that the case-binder *can't* be. - 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] +simplAlt env handled_cons case_bndr' (LitAlt lit, bndrs, rhs) cont' + = ASSERT( null bndrs ) + simplExprC env' rhs cont' `thenSmpl` \ rhs' -> + returnSmpl (Just (emptyVarEnv, (LitAlt lit, [], rhs'))) + where + env' = mk_rhs_env env case_bndr' (mkUnfolding False (Lit lit)) + +simplAlt env handled_cons case_bndr' (DataAlt con, vs, rhs) cont' + | isVanillaDataCon con + = -- Deal with the pattern-bound variables + -- Mark the ones that are in ! positions in the data constructor + -- 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) + let unf = mkUnfolding False (mkConApp con con_args) + inst_tys' = tyConAppArgs (idType case_bndr') + con_args = map Type inst_tys' ++ map varToCoreExpr vs' + env' = mk_rhs_env env case_bndr' unf + in + simplExprC env' rhs cont' `thenSmpl` \ rhs' -> + returnSmpl (Just (emptyVarEnv, (DataAlt con, vs', rhs'))) --- The default case -prepareCaseAlts _ _ scrut_cons alts - = returnSmpl alts -- Functions + | otherwise -- GADT case + = let + (tvs,ids) = span isTyVar vs + in + simplBinders env tvs `thenSmpl` \ (env1, tvs') -> + case coreRefineTys (getInScope env1) con tvs' (idType case_bndr') of { + Nothing -- Inaccessible + | opt_PprStyle_Debug -- Hack: if debugging is on, generate an error case + -- so we can see it + -> let rhs' = mkApps (Var eRROR_ID) + [Type (substTy env (exprType rhs)), + Lit (mkStringLit "Impossible alternative (GADT)")] + in + simplBinders env1 ids `thenSmpl` \ (env2, ids') -> + returnSmpl (Just (emptyVarEnv, (DataAlt con, tvs' ++ ids', rhs'))) + + | otherwise -- Filter out the inaccessible branch + -> return Nothing ; + + Just refine@(tv_subst_env, _) -> -- The normal case + let + env2 = refineSimplEnv env1 refine + -- Simplify the Ids in the refined environment, so their types + -- reflect the refinement. Usually this doesn't matter, but it helps + -- in mkDupableAlt, when we want to float a lambda that uses these binders + -- Furthermore, it means the binders contain maximal type information + in + simplBinders env2 (add_evals con ids) `thenSmpl` \ (env3, ids') -> + let unf = mkUnfolding False con_app + con_app = mkConApp con con_args + con_args = map varToCoreExpr vs' -- NB: no inst_tys' + env_w_unf = mk_rhs_env env3 case_bndr' unf + vs' = tvs' ++ ids' + in + simplExprC env_w_unf rhs cont' `thenSmpl` \ rhs' -> + returnSmpl (Just (tv_subst_env, (DataAlt con, vs', rhs'))) } ----------------------- -simplAlts zap_occ_info scrut_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 - - -- 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] - - simpl_alt (DEFAULT, _, rhs) - = -- 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 - modifyInScope (case_bndr'' `setIdUnfolding` mkOtherCon handled_cons) $ - simplExprC rhs cont' `thenSmpl` \ rhs' -> - returnSmpl (DEFAULT, [], rhs') - - simpl_alt (con, vs, rhs) - = -- 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' -> - - -- Bind the case-binder to (Con args) - let - con_app = Con con (map Type inst_tys' ++ map varToCoreExpr vs') - in - modifyInScope (case_bndr'' `setIdUnfolding` mkUnfolding con_app) $ - simplExprC rhs cont' `thenSmpl` \ rhs' -> - returnSmpl (con, vs', rhs') - - -- add_evals records the evaluated-ness of the bound variables of -- a case pattern. This is *important*. Consider -- data T = T !Int !Int @@ -1351,17 +1565,100 @@ simplAlts zap_occ_info scrut_cons case_bndr'' alts cont' -- -- We really must record that b is already evaluated so that we don't -- go and re-evaluate it when constructing the result. + add_evals dc vs = cat_evals dc vs (dataConRepStrictness dc) - add_evals (DataCon dc) vs = cat_evals vs (dataConRepStrictness dc) - add_evals other_con vs = vs - - cat_evals [] [] = [] - cat_evals (v:vs) (str:strs) - | isTyVar v = v : cat_evals vs (str:strs) - | isStrict str = (v' `setIdUnfolding` mkOtherCon []) : cat_evals vs strs - | otherwise = v' : cat_evals vs strs + cat_evals dc vs strs + = go vs strs where - v' = zap_occ_info v + go [] [] = [] + go (v:vs) strs | isTyVar v = v : go vs strs + go (v:vs) (str:strs) + | isMarkedStrict str = evald_v : go vs strs + | otherwise = zapped_v : go vs strs + where + zapped_v = zap_occ_info v + evald_v = zapped_v `setIdUnfolding` evaldUnfolding + go _ _ = pprPanic "cat_evals" (ppr dc $$ ppr vs $$ ppr strs) + + -- If the case binder is alive, then we add the unfolding + -- case_bndr = C vs + -- to the envt; so vs are now very much alive + zap_occ_info | isDeadBinder case_bndr' = \id -> id + | otherwise = \id -> id `setIdOccInfo` NoOccInfo + +mk_rhs_env env case_bndr' case_bndr_unf + = modifyInScope env case_bndr' (case_bndr' `setIdUnfolding` case_bndr_unf) +\end{code} + + +%************************************************************************ +%* * +\subsection{Known constructor} +%* * +%************************************************************************ + +We are a bit careful with occurrence info. Here's an example + + (\x* -> case x of (a*, b) -> f a) (h v, e) + +where the * means "occurs once". This effectively becomes + case (h v, e) of (a*, b) -> f a) +and then + let a* = h v; b = e in f a +and then + f (h v) + +All this should happen in one sweep. + +\begin{code} +knownCon :: SimplEnv -> AltCon -> [OutExpr] + -> InId -> [InAlt] -> SimplCont + -> SimplM FloatsWithExpr + +knownCon env con args bndr alts cont + = tick (KnownBranch bndr) `thenSmpl_` + case findAlt con alts of + (DEFAULT, bs, rhs) -> ASSERT( null bs ) + simplNonRecX env bndr scrut $ \ env -> + -- This might give rise to a binding with non-atomic args + -- like x = Node (f x) (g x) + -- but no harm will be done + simplExprF env rhs cont + where + scrut = case con of + LitAlt lit -> Lit lit + DataAlt dc -> mkConApp dc args + + (LitAlt lit, bs, rhs) -> ASSERT( null bs ) + simplNonRecX env bndr (Lit lit) $ \ env -> + simplExprF env rhs cont + + (DataAlt dc, bs, rhs) + -> ASSERT( n_drop_tys + length bs == length args ) + bind_args env bs (drop n_drop_tys args) $ \ env -> + let + con_app = mkConApp dc (take n_drop_tys args ++ con_args) + con_args = [substExpr 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_drop_tys | isVanillaDataCon dc = tyConArity (dataConTyCon dc) + | otherwise = 0 + -- Vanilla data constructors lack type arguments in the pattern + +-- Ugh! +bind_args env [] _ thing_inside = thing_inside env + +bind_args env (b:bs) (Type ty : args) thing_inside + = ASSERT( isTyVar b ) + bind_args (extendTvSubst env b ty) bs args thing_inside + +bind_args env (b:bs) (arg : args) thing_inside + = ASSERT( isId b ) + simplNonRecX env b arg $ \ env -> + bind_args env bs args thing_inside \end{code} @@ -1372,79 +1669,145 @@ simplAlts zap_occ_info scrut_cons case_bndr'' alts cont' %************************************************************************ \begin{code} -mkDupableCont :: InType -- Type of the thing to be given to the continuation - -> SimplCont - -> (SimplCont -> SimplM (OutStuff a)) - -> SimplM (OutStuff a) -mkDupableCont ty cont thing_inside +prepareCaseCont :: SimplEnv + -> [InAlt] -> SimplCont + -> SimplM (FloatsWith (SimplCont,SimplCont)) + -- Return a duplicatable continuation, a non-duplicable part + -- plus some extra bindings + + -- No need to make it duplicatable if there's only one alternative +prepareCaseCont env [alt] cont = returnSmpl (emptyFloats env, (cont, mkBoringStop (contResultType cont))) +prepareCaseCont env alts cont = mkDupableCont env cont +\end{code} + +\begin{code} +mkDupableCont :: SimplEnv -> SimplCont + -> SimplM (FloatsWith (SimplCont, SimplCont)) + +mkDupableCont env cont | contIsDupable cont - = thing_inside cont - -mkDupableCont _ (CoerceIt ty cont) thing_inside - = mkDupableCont ty cont $ \ cont' -> - thing_inside (CoerceIt ty cont') - -mkDupableCont ty (InlinePlease cont) thing_inside - = mkDupableCont ty cont $ \ cont' -> - thing_inside (InlinePlease cont') - -mkDupableCont join_arg_ty (ArgOf _ cont_ty cont_fn) thing_inside - = -- Build the RHS of the join point - simplType join_arg_ty `thenSmpl` \ join_arg_ty' -> - newId join_arg_ty' ( \ arg_id -> - getSwitchChecker `thenSmpl` \ chkr -> - cont_fn (Var arg_id) `thenSmpl` \ (binds, (_, rhs)) -> - returnSmpl (Lam (setOneShotLambda arg_id) (mkLets binds rhs)) - ) `thenSmpl` \ join_rhs -> - - -- Build the join Id and continuation - newId (coreExprType join_rhs) $ \ join_id -> - let - new_cont = ArgOf OkToDup cont_ty - (\arg' -> rebuild_done (App (Var join_id) arg')) - in - - -- Do the thing inside - thing_inside new_cont `thenSmpl` \ res -> - returnSmpl (addBind (NonRec join_id join_rhs) res) + = returnSmpl (emptyFloats env, (cont, mkBoringStop (contResultType cont))) + +mkDupableCont env (CoerceIt ty cont) + = mkDupableCont env cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) -> + returnSmpl (floats, (CoerceIt ty dup_cont, nondup_cont)) + +mkDupableCont env (InlinePlease cont) + = mkDupableCont env cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) -> + returnSmpl (floats, (InlinePlease dup_cont, nondup_cont)) + +mkDupableCont env cont@(ArgOf _ arg_ty _ _) + = returnSmpl (emptyFloats env, (mkBoringStop arg_ty, cont)) + -- Do *not* duplicate an ArgOf continuation + -- Because ArgOf continuations are opaque, we gain nothing by + -- propagating them into the expressions, and we do lose a lot. + -- Here's an example: + -- && (case x of { T -> F; F -> T }) E + -- Now, && is strict so we end up simplifying the case with + -- an ArgOf continuation. If we let-bind it, we get + -- + -- let $j = \v -> && v E + -- in simplExpr (case x of { T -> F; F -> T }) + -- (ArgOf (\r -> $j r) + -- And after simplifying more we get + -- + -- let $j = \v -> && v E + -- in case of { T -> $j F; F -> $j T } + -- Which is a Very Bad Thing + -- + -- The desire not to duplicate is the entire reason that + -- mkDupableCont returns a pair of continuations. + -- + -- The original plan had: + -- e.g. (...strict-fn...) [...hole...] + -- ==> + -- let $j = \a -> ...strict-fn... + -- in $j [...hole...] + +mkDupableCont env (ApplyTo _ arg se cont) + = -- e.g. [...hole...] (...arg...) + -- ==> + -- let a = ...arg... + -- in [...hole...] a + simplExpr (setInScope se env) arg `thenSmpl` \ arg' -> + + mkDupableCont env cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) -> + addFloats env floats $ \ env -> -mkDupableCont ty (ApplyTo _ arg se cont) thing_inside - = mkDupableCont (funResultTy ty) cont $ \ cont' -> - setSubstEnv se (simplExpr arg) `thenSmpl` \ arg' -> if exprIsDupable arg' then - thing_inside (ApplyTo OkToDup arg' emptySubstEnv cont') + returnSmpl (emptyFloats env, (ApplyTo OkToDup arg' (zapSubstEnv se) dup_cont, nondup_cont)) else - newId (coreExprType arg') $ \ bndr -> - thing_inside (ApplyTo OkToDup (Var bndr) emptySubstEnv cont') `thenSmpl` \ res -> - returnSmpl (addBind (NonRec bndr arg') res) - -mkDupableCont ty (Select _ case_bndr alts se cont) thing_inside - = tick (CaseOfCase case_bndr) `thenSmpl_` - setSubstEnv se ( - simplBinder case_bndr $ \ case_bndr' -> - prepareCaseCont alts cont $ \ cont' -> - mapAndUnzipSmpl (mkDupableAlt case_bndr case_bndr' cont') alts `thenSmpl` \ (alt_binds_s, alts') -> - returnSmpl (concat alt_binds_s, alts') - ) `thenSmpl` \ (alt_binds, alts') -> - - extendInScopes [b | NonRec b _ <- alt_binds] $ - - -- NB that the new alternatives, alts', are still InAlts, using the original - -- binders. That means we can keep the case_bndr intact. This is important - -- because another case-of-case might strike, and so we want to keep the - -- info that the case_bndr is dead (if it is, which is often the case). - -- This is VITAL when the type of case_bndr is an unboxed pair (often the - -- case in I/O rich code. We aren't allowed a lambda bound - -- arg of unboxed tuple type, and indeed such a case_bndr is always dead - thing_inside (Select OkToDup case_bndr alts' se (Stop (contResultType cont))) `thenSmpl` \ res -> - - returnSmpl (addBinds alt_binds res) - - -mkDupableAlt :: InId -> OutId -> SimplCont -> InAlt -> SimplM (OutStuff InAlt) -mkDupableAlt case_bndr case_bndr' (Stop _) alt@(con, bndrs, rhs) - | exprIsDupable rhs - = -- It is worth checking for a small RHS because otherwise we + newId FSLIT("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) dup_cont, + nondup_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 (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, (dup_cont, nondup_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 dup_cont `thenSmpl` \ (floats2, alts') -> + addFloats alt_env floats2 $ \ alt_env -> + returnSmpl (emptyFloats alt_env, + (Select OkToDup case_bndr' alts' (zapSubstEnv se) + (mkBoringStop (contResultType dup_cont)), + nondup_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) + = do { (floats1, mb_alt') <- mkDupableAlt env case_bndr' dupable_cont alt + ; addFloats env floats1 $ \ env -> do + { (floats2, alts') <- go env alts + ; returnSmpl (floats2, case mb_alt' of + Just alt' -> alt' : alts' + Nothing -> alts' + )}} + +mkDupableAlt env case_bndr' cont alt + = simplAlt env [] case_bndr' alt cont `thenSmpl` \ mb_stuff -> + case mb_stuff of { + Nothing -> returnSmpl (emptyFloats env, Nothing) ; + + Just (reft, (con, bndrs', rhs')) -> + -- Safe to say that there are no handled-cons for the DEFAULT case + + if exprIsDupable rhs' then + returnSmpl (emptyFloats env, Just (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 @@ -1452,26 +1815,25 @@ mkDupableAlt case_bndr case_bndr' (Stop _) alt@(con, bndrs, rhs) -- inlined, but after the join points had been inlined it looked smaller, and so -- was inlined. -- - -- But since the continuation is absorbed into the rhs, we only do this - -- for a Stop continuation. - returnSmpl ([], alt) + -- 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. -mkDupableAlt case_bndr case_bndr' cont alt@(con, bndrs, rhs) - | otherwise - = -- Not worth checking whether the rhs is small; the - -- inliner will inline it if so. - simplBinders bndrs $ \ bndrs' -> - simplExprC rhs cont `thenSmpl` \ rhs' -> + else let - rhs_ty' = coreExprType rhs' - (used_bndrs, used_bndrs') - = unzip [pr | pr@(bndr,bndr') <- zip (case_bndr : bndrs) - (case_bndr' : bndrs'), - not (isDeadBinder bndr)] - -- The new binders have lost their occurrence info, - -- so we have to extract it from the old ones + rhs_ty' = exprType rhs' + used_bndrs' = filter abstract_over (case_bndr' : bndrs') + abstract_over bndr + | isTyVar bndr = not (bndr `elemVarEnv` reft) + -- Don't abstract over tyvar binders which are refined away + -- See Note [Refinement] below + | otherwise = not (isDeadBinder bndr) + -- The deadness info on the new Ids is preserved by simplBinders in - ( if null used_bndrs' -- If we try to lift a primitive-typed something out -- for let-binding-purposes, we will *caseify* it (!), -- with potentially-disastrous strictness results. So @@ -1489,27 +1851,77 @@ mkDupableAlt case_bndr case_bndr' cont alt@(con, bndrs, rhs) -- Consider: let j = if .. then I# 3 else I# 4 -- in case .. of { A -> j; B -> j; C -> ... } -- - -- Now CPR should not w/w j because it's a thunk, so + -- 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 - - then newId realWorldStatePrimTy $ \ rw_id -> + -- + -- 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 not (any isId used_bndrs') + then newId FSLIT("w") realWorldStatePrimTy `thenSmpl` \ rw_id -> returnSmpl ([rw_id], [Var realWorldPrimId]) else - returnSmpl (used_bndrs', map varToCoreExpr used_bndrs) - ) - `thenSmpl` \ (final_bndrs', final_args) -> - - newId (foldr (mkFunTy . idType) rhs_ty' final_bndrs') $ \ join_bndr -> - - -- Notice that we make the lambdas into one-shot-lambdas. The + returnSmpl (used_bndrs', map varToCoreExpr used_bndrs') + ) `thenSmpl` \ (final_bndrs', final_args) -> + + -- See comment about "$j" name above + newId FSLIT("$j") (mkPiTypes final_bndrs' rhs_ty') `thenSmpl` \ join_bndr -> + -- Notice the funky mkPiTypes. 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 - returnSmpl ([NonRec join_bndr (mkLams (map setOneShotLambda final_bndrs') rhs')], - (con, bndrs, mkApps (Var join_bndr) final_args)) + 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, Just (con, bndrs', join_call)) } \end{code} + +Note [Refinement] +~~~~~~~~~~~~~~~~~ +Consider + data T a where + MkT :: a -> b -> T a + + f = /\a. \(w::a). + case (case ...) of + MkT a' b (p::a') (q::b) -> [p,w] + +The danger is that we'll make a join point + + j a' p = [p,w] + +and that's ill-typed, because (p::a') but (w::a). + +Solution so far: don't abstract over a', because the type refinement +maps [a' -> a] . Ultimately that won't work when real refinement goes on. + +Then we must abstract over any refined free variables. Hmm. Maybe we +could just abstract over *all* free variables, thereby lambda-lifting +the join point? We should try this.