X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplify.lhs;h=303fd65e0022c8c034743b6a4e09b2a15ad01601;hb=9c383315203f0ad7cfd65272d04d921c0cef3cec;hp=242bd4b38902abeff451e527217bf128e282514a;hpb=e00e72df666d771c089f1615f66f6257e44c9da1;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 242bd4b..303fd65 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -1,1343 +1,1719 @@ % -% (c) The AQUA Project, Glasgow University, 1993-1996 +% (c) The AQUA Project, Glasgow University, 1993-1998 % \section[Simplify]{The main module of the simplifier} \begin{code} -#include "HsVersions.h" - -module Simplify ( simplTopBinds, simplExpr, simplBind ) where +module Simplify ( simplTopBinds, simplExpr ) where -IMPORT_1_3(List(partition)) - -IMP_Ubiq(){-uitous-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(SmplLoop) -- paranoia checking -#endif +#include "HsVersions.h" -import BinderInfo -import CmdLineOpts ( SimplifierSwitch(..) ) -import ConFold ( completePrim ) -import CoreUnfold ( Unfolding, SimpleUnfolding, mkFormSummary, exprIsTrivial, whnfOrBottom, FormSummary(..) ) -import CostCentre ( isSccCountCostCentre, cmpCostCentre, costsAreSubsumed, useCurrentCostCentre ) +import CmdLineOpts ( dopt, DynFlag(Opt_D_dump_inlinings), + SimplifierSwitch(..) + ) +import SimplMonad +import SimplUtils ( mkCase, mkLam, newId, prepareAlts, + simplBinder, simplBinders, simplLamBndrs, simplRecBndrs, simplLetBndr, + SimplCont(..), DupFlag(..), LetRhsFlag(..), + mkStop, mkBoringStop, pushContArgs, + contResultType, countArgs, contIsDupable, contIsRhsOrArg, + getContArgs, interestingCallContext, interestingArg, isStrictType + ) +import Var ( mustHaveLocalBinding ) +import VarEnv +import Id ( Id, idType, idInfo, idArity, isDataConId, + setIdUnfolding, isDeadBinder, + idNewDemandInfo, setIdInfo, + setIdOccInfo, zapLamIdInfo, setOneShotLambda, + ) +import OccName ( encodeFS ) +import IdInfo ( OccInfo(..), isLoopBreaker, + setArityInfo, + setUnfoldingInfo, + occInfo + ) +import NewDemand ( isStrictDmd ) +import DataCon ( dataConNumInstArgs, dataConRepStrictness ) import CoreSyn -import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp, - unTagBinders, squashableDictishCcExpr +import PprCore ( pprParendExpr, pprCoreExpr ) +import CoreUnfold ( mkOtherCon, mkUnfolding, callSiteInline ) +import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding, + exprIsConApp_maybe, mkPiTypes, findAlt, + exprType, exprIsValue, + exprOkForSpeculation, exprArity, + mkCoerce, mkCoerce2, mkSCC, mkInlineMe, mkAltExpr, applyTypeToArg ) -import Id ( idType, idMustBeINLINEd, idWantsToBeINLINEd, idMustNotBeINLINEd, - addIdArity, getIdArity, - getIdDemandInfo, addIdDemandInfo, - GenId{-instance NamedThing-} +import Rules ( lookupRule ) +import BasicTypes ( isMarkedStrict ) +import CostCentre ( currentCCS ) +import Type ( isUnLiftedType, seqType, tyConAppArgs, funArgTy, + splitFunTy_maybe, splitFunTy, eqType ) -import Name ( isExported ) -import IdInfo ( willBeDemanded, noDemandInfo, DemandInfo, ArityInfo(..), - atLeastArity, unknownArity ) -import Literal ( isNoRepLit ) -import Maybes ( maybeToBool ) -import PprType ( GenType{-instance Outputable-}, GenTyVar{- instance Outputable -} ) -#if __GLASGOW_HASKELL__ <= 30 -import PprCore ( GenCoreArg, GenCoreExpr ) -#endif -import TyVar ( GenTyVar {- instance Eq -} ) -import Pretty --( ($$) ) -import PrimOp ( primOpOkForSpeculation, PrimOp(..) ) -import SimplCase ( simplCase, bindLargeRhs ) -import SimplEnv -import SimplMonad -import SimplVar ( completeVar ) -import Unique ( Unique ) -import SimplUtils -import Type ( mkTyVarTy, mkTyVarTys, mkAppTy, applyTy, mkFunTys, maybeAppDataTyCon, - splitFunTy, splitFunTyExpandingDicts, getFunTy_maybe, eqTy +import Subst ( mkSubst, substTy, substExpr, + isInScope, lookupIdSubst, simplIdInfo ) -import TysWiredIn ( realWorldStateTy ) -import Outputable ( PprStyle(..), Outputable(..) ) -import Util ( SYN_IE(Eager), appEager, returnEager, runEager, mapEager, - isSingleton, zipEqual, zipWithEqual, mapAndUnzip, panic, pprPanic, assertPanic, pprTrace ) +import TysPrim ( realWorldStatePrimTy ) +import PrelInfo ( realWorldPrimId ) +import BasicTypes ( TopLevelFlag(..), isTopLevel, + RecFlag(..), isNonRec + ) +import OrdList +import Maybe ( Maybe ) +import Outputable +import Util ( notNull ) \end{code} -The controlling flags, and what they do -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -passes: ------- --fsimplify = run the simplifier --ffloat-inwards = runs the float lets inwards pass --ffloat = runs the full laziness pass - (ToDo: rename to -ffull-laziness) --fupdate-analysis = runs update analyser --fstrictness = runs strictness analyser --fsaturate-apps = saturates applications (eta expansion) - -options: -------- --ffloat-past-lambda = OK to do full laziness. - (ToDo: remove, as the full laziness pass is - useless without this flag, therefore - it is unnecessary. Just -ffull-laziness - should be kept.) - --ffloat-lets-ok = OK to float lets out of lets if the enclosing - let is strict or if the floating will expose - a WHNF [simplifier]. - --ffloat-primops-ok = OK to float out of lets cases whose scrutinee - is a primop that cannot fail [simplifier]. - --fcode-duplication-ok = allows the previous option to work on cases with - multiple branches [simplifier]. - --flet-to-case = does let-to-case transformation [simplifier]. - --fcase-of-case = does case of case transformation [simplifier]. - --fpedantic-bottoms = does not allow: - case x of y -> e ===> e[x/y] - (which may turn bottom into non-bottom) - - - NOTES ON INLINING - ~~~~~~~~~~~~~~~~~ - -Inlining is one of the delicate aspects of the simplifier. By -``inlining'' we mean replacing an occurrence of a variable ``x'' by -the RHS of x's definition. Thus - - let x = e in ...x... ===> let x = e in ...e... - -We have two mechanisms for inlining: - -1. Unconditional. The occurrence analyser has pinned an (OneOcc -FunOcc NoDupDanger NotInsideSCC n) flag on the variable, saying ``it's -certainly safe to inline this variable, and to drop its binding''. -(...Umm... if n <= 1; if n > 1, it is still safe, provided you are -happy to be duplicating code...) When it encounters such a beast, the -simplifer binds the variable to its RHS (in the id_env) and continues. -It doesn't even look at the RHS at that stage. It also drops the -binding altogether. - -2. Conditional. In all other situations, the simplifer simplifies -the RHS anyway, and keeps the new binding. It also binds the new -(cloned) variable to a ``suitable'' Unfolding in the UnfoldEnv. - -Here, ``suitable'' might mean NoUnfolding (if the occurrence -info is ManyOcc and the RHS is not a manifest HNF, or UnfoldAlways (if -the variable has an INLINE pragma on it). The idea is that anything -in the UnfoldEnv is safe to use, but also has an enclosing binding if -you decide not to use it. - -Head normal forms -~~~~~~~~~~~~~~~~~ -We *never* put a non-HNF unfolding in the UnfoldEnv except in the -INLINE-pragma case. - -At one time I thought it would be OK to put non-HNF unfoldings in for -variables which occur only once [if they got inlined at that -occurrence the RHS of the binding would become dead, so no duplication -would occur]. But consider: -@ - let x = - f = \y -> ...y...y...y... - in f x -@ -Now, it seems that @x@ appears only once, but even so it is NOT safe -to put @x@ in the UnfoldEnv, because @f@ will be inlined, and will -duplicate the references to @x@. - -Because of this, the "unconditional-inline" mechanism above is the -only way in which non-HNFs can get inlined. - -INLINE pragmas -~~~~~~~~~~~~~~ - -When a variable has an INLINE pragma on it --- which includes wrappers -produced by the strictness analyser --- we treat it rather carefully. - -For a start, we are careful not to substitute into its RHS, because -that might make it BIG, and the user said "inline exactly this", not -"inline whatever you get after inlining other stuff inside me". For -example - let f = BIG - in {-# INLINE y #-} y = f 3 - in ...y...y... - -Here we don't want to substitute BIG for the (single) occurrence of f, -because then we'd duplicate BIG when we inline'd y. (Exception: -things in the UnfoldEnv with UnfoldAlways flags, which originated in -other INLINE pragmas.) - -So, we clean out the UnfoldEnv of all SimpleUnfolding inlinings before -going into such an RHS. +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 -What about imports? They don't really matter much because we only -inline relatively small things via imports. + case e of (a,b) -> \x -> case a of (p,q) -> \y -> r -We augment the the UnfoldEnv with UnfoldAlways guidance if there's an -INLINE pragma. We also do this for the RHSs of recursive decls, -before looking at the recursive decls. That way we achieve the effect -of inlining a wrapper in the body of its worker, in the case of a -mutually-recursive worker/wrapper split. +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. %************************************************************************ %* * -\subsection[Simplify-simplExpr]{The main function: simplExpr} +\subsection{Bindings} %* * %************************************************************************ -At the top level things are a little different. - - * No cloning (not allowed for exported Ids, unnecessary for the others) - * Floating is done a bit differently (no case floating; check for leaks; handle letrec) - \begin{code} -simplTopBinds :: SimplEnv -> [InBinding] -> SmplM [OutBinding] - --- Dead code is now discarded by the occurrence analyser, +simplTopBinds :: SimplEnv -> [InBind] -> SimplM [OutBind] simplTopBinds env binds - = mapSmpl (floatBind env True) binds `thenSmpl` \ binds_s -> - simpl_top_binds env (concat binds_s) + = -- 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. + simplRecBndrs env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') -> + simpl_binds env binds bndrs' `thenSmpl` \ (floats, _) -> + freeTick SimplifierDone `thenSmpl_` + returnSmpl (floatBinds floats) where - simpl_top_binds env [] = returnSmpl [] - - simpl_top_binds env (NonRec binder@(in_id,occ_info) rhs : binds) - = --- No cloning necessary at top level - simplRhsExpr env binder rhs in_id `thenSmpl` \ (rhs',arity) -> - completeNonRec env binder (in_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds1') -> - simpl_top_binds new_env binds `thenSmpl` \ binds2' -> - returnSmpl (binds1' ++ binds2') - - simpl_top_binds env (Rec pairs : binds) - = -- No cloning necessary at top level, but we nevertheless - -- add the Ids to the environment. This makes sure that - -- info carried on the Id (such as arity info) gets propagated - -- to occurrences. - -- - -- This may seem optional, but I found an occasion when it Really matters. - -- Consider foo{n} = ...foo... - -- baz* = foo - -- - -- where baz* is exported and foo isn't. Then when we do "indirection-shorting" - -- in tidyCore, we need the {no-inline} pragma from foo to attached to the final - -- thing: baz*{n} = ...baz... - -- - -- Sure we could have made the indirection-shorting a bit cleverer, but - -- propagating pragma info is a Good Idea anyway. - let - env1 = extendIdEnvWithClones env binders ids - in - simplRecursiveGroup env1 ids pairs `thenSmpl` \ (bind', new_env) -> - simpl_top_binds new_env binds `thenSmpl` \ binds' -> - returnSmpl (Rec bind' : binds') - where - binders = map fst pairs - ids = map fst binders + -- 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[Simplify-simplExpr]{The main function: simplExpr} +\subsection{simplNonRec} %* * %************************************************************************ +simplNonRecBind is used for + * non-top-level non-recursive lets in expressions + * beta reduction -\begin{code} -simplExpr :: SimplEnv - -> InExpr -> [OutArg] - -> OutType -- Type of (e args); i.e. type of overall result - -> SmplM OutExpr -\end{code} - -The expression returned has the same meaning as the input expression -applied to the specified arguments. +It takes + * An unsimplified (binder, rhs) pair + * The env for the RHS. It may not be the same as the + current env because the bind might occur via (\x.E) arg +It uses the CPS form because the binding might be strict, in which +case we might discard the continuation: + let x* = error "foo" in (...x...) -Variables -~~~~~~~~~ -Check if there's a macro-expansion, and if so rattle on. Otherwise do -the more sophisticated stuff. +It needs to turn unlifted bindings into a @case@. They can arise +from, say: (\x -> e) (4# + 3#) \begin{code} -simplExpr env (Var v) args result_ty - = case (runEager $ lookupId env v) of - LitArg lit -- A boring old literal - -> ASSERT( null args ) - returnSmpl (Lit lit) - - VarArg var -- More interesting! An id! - -> completeVar env var args result_ty - -- Either Id is in the local envt, or it's a global. - -- In either case we don't need to apply the type - -- environment to it. +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 + | preInlineUnconditionally env NotTopLevel bndr + = tick (PreInlineUnconditionally bndr) `thenSmpl_` + thing_inside (extendSubst env bndr (ContEx (getSubstEnv rhs_se) rhs)) + + + | isStrictDmd (idNewDemandInfo bndr) || isStrictType (idType bndr) -- A strict let + = -- Don't use simplBinder because that doesn't keep + -- fragile occurrence info in the substitution + simplLetBndr env bndr `thenSmpl` \ (env, bndr') -> + let + -- simplLetBndr doesn't deal with the IdInfo, so we must + -- do so here (c.f. simplLazyBind) + bndr'' = bndr' `setIdInfo` simplIdInfo (getSubst env) (idInfo bndr) + env1 = modifyInScope env bndr'' bndr'' + in + simplStrictArg AnRhs env1 rhs rhs_se (idType bndr') cont_ty $ \ env rhs1 -> + + -- Now complete the binding and simplify the body + completeNonRecX env True {- strict -} bndr bndr'' 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 \end{code} -Literals -~~~~~~~~ +A specialised variant of simplNonRec used when the RHS is already simplified, notably +in knownCon. It uses case-binding where necessary. \begin{code} -simplExpr env (Lit l) [] result_ty = returnSmpl (Lit l) -#ifdef DEBUG -simplExpr env (Lit l) _ _ = panic "simplExpr:Lit with argument" -#endif +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) -> + returnSmpl (emptyFloats env, Case new_rhs bndr' [(DEFAULT, [], wrapFloats floats body)]) + + | preInlineUnconditionally env NotTopLevel bndr + -- This happens; for example, the case_bndr during case of + -- known constructor: case (a,b) of x { (p,q) -> ... } + -- Here x isn't mentioned in the RHS, so we don't want to + -- create the (dead) let-binding let x = (a,b) in ... + -- + -- Similarly, single occurrences can be inlined vigourously + -- e.g. case (f x, g y) of (a,b) -> .... + -- If a,b occur once we can avoid constructing the let binding for them. + = thing_inside (extendSubst env bndr (ContEx emptySubstEnv new_rhs)) + + | otherwise + = simplBinder env bndr `thenSmpl` \ (env, bndr') -> + completeNonRecX env 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} -Primitive applications are simple. -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -NB: Prim expects an empty argument list! (Because it should be -saturated and not higher-order. ADR) +%************************************************************************ +%* * +\subsection{Lazy bindings} +%* * +%************************************************************************ + +simplRecBind is used for + * recursive bindings only \begin{code} -simplExpr env (Prim op prim_args) args result_ty - = ASSERT (null args) - mapEager (simplArg env) prim_args `appEager` \ prim_args' -> - simpl_op op `appEager` \ op' -> - completePrim env op' prim_args' +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 - -- PrimOps just need any types in them renamed. + 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} - simpl_op (CCallOp label is_asm may_gc arg_tys result_ty) - = mapEager (simplTy env) arg_tys `appEager` \ arg_tys' -> - simplTy env result_ty `appEager` \ result_ty' -> - returnEager (CCallOp label is_asm may_gc arg_tys' result_ty') - simpl_op other_op = returnEager other_op -\end{code} +simplRecOrTopPair is used for + * recursive bindings (whether top level or not) + * top-level non-recursive bindings -Constructor applications -~~~~~~~~~~~~~~~~~~~~~~~~ -Nothing to try here. We only reuse constructors when they appear as the -rhs of a let binding (see completeLetBinding). +It assumes the binder has already been simplified, but not its IdInfo. \begin{code} -simplExpr env (Con con con_args) args result_ty - = ASSERT( null args ) - mapEager (simplArg env) con_args `appEager` \ con_args' -> - returnSmpl (Con con con_args') +simplRecOrTopPair :: SimplEnv + -> TopLevelFlag + -> InId -> OutId -- Binder, both pre-and post simpl + -> InExpr -- The RHS and its environment + -> SimplM (FloatsWith SimplEnv) + +simplRecOrTopPair env top_lvl bndr bndr' rhs + | preInlineUnconditionally env top_lvl bndr -- Check for unconditional inline + = tick (PreInlineUnconditionally bndr) `thenSmpl_` + returnSmpl (emptyFloats env, extendSubst env bndr (ContEx (getSubstEnv env) rhs)) + + | otherwise + = simplLazyBind env top_lvl Recursive bndr bndr' rhs env + -- May not actually be recursive, but it doesn't matter \end{code} -Applications are easy too: -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Just stuff 'em in the arg stack +simplLazyBind is used for + * recursive bindings (whether top level or not) + * top-level non-recursive bindings + * non-top-level *lazy* non-recursive bindings -\begin{code} -simplExpr env (App fun arg) args result_ty - = simplArg env arg `appEager` \ arg' -> - simplExpr env fun (arg' : args) result_ty -\end{code} +[Thus it deals with the lazy cases from simplNonRecBind, and all cases +from SimplRecOrTopBind] -Type lambdas -~~~~~~~~~~~~ +Nota bene: + 1. It assumes that the binder is *already* simplified, + and is in scope, but not its IdInfo -First the case when it's applied to an argument. + 2. It assumes that the binder type is lifted. -\begin{code} -simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args) result_ty - = -- ASSERT(not (isPrimType ty)) - tick TyBetaReduction `thenSmpl_` - simplExpr (extendTyEnv env tyvar ty) body args result_ty -\end{code} + 3. It does not check for pre-inline-unconditionallly; + that should have been done already. \begin{code} -simplExpr env tylam@(Lam (TyBinder tyvar) body) [] result_ty - = cloneTyVarSmpl tyvar `thenSmpl` \ tyvar' -> +simplLazyBind :: SimplEnv + -> TopLevelFlag -> RecFlag + -> InId -> OutId -- Binder, both pre-and post simpl + -> InExpr -> SimplEnv -- The RHS and its environment + -> SimplM (FloatsWith SimplEnv) + +simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se + = -- Substitute IdInfo on binder, in the light of earlier + -- substitutions in this very letrec, and extend the + -- in-scope env, so that the IdInfo for this binder extends + -- over the RHS for the binder itself. + -- + -- This is important. Manuel found cases where he really, really + -- wanted a RULE for a recursive function to apply in that function's + -- own right-hand side. + -- + -- NB: does no harm for non-recursive bindings let - new_ty = mkTyVarTy tyvar' - new_env = extendTyEnv env tyvar new_ty - new_result_ty = applyTy result_ty new_ty + bndr'' = bndr' `setIdInfo` simplIdInfo (getSubst env) (idInfo bndr) + env1 = modifyInScope env bndr'' bndr'' + rhs_env = setInScope rhs_se env1 + is_top_level = isTopLevel top_lvl + ok_float_unlifted = not is_top_level && isNonRec is_rec + rhs_cont = mkStop (idType bndr') AnRhs in - simplExpr new_env body [] new_result_ty `thenSmpl` \ body' -> - returnSmpl (Lam (TyBinder tyvar') body') + -- Simplify the RHS; note the mkStop, which tells + -- the simplifier that this is the RHS of a let. + simplExprF rhs_env rhs rhs_cont `thenSmpl` \ (floats, rhs1) -> + + -- If any of the floats can't be floated, give up now + -- (The allLifted predicate says True for empty floats.) + if (not ok_float_unlifted && not (allLifted floats)) then + completeLazyBind env1 top_lvl bndr bndr'' + (wrapFloats floats rhs1) + else + + -- ANF-ise a constructor or PAP rhs + mkAtomicArgs False {- Not strict -} + ok_float_unlifted rhs1 `thenSmpl` \ (aux_binds, rhs2) -> + + -- If the result is a PAP, float the floats out, else wrap them + -- By this time it's already been ANF-ised (if necessary) + if isEmptyFloats floats && isNilOL aux_binds then -- Shortcut a common case + completeLazyBind env1 top_lvl bndr bndr'' rhs2 + + -- We use exprIsTrivial here because we want to reveal lone variables. + -- E.g. let { x = letrec { y = E } in y } in ... + -- Here we definitely want to float the y=E defn. + -- exprIsValue definitely isn't right for that. + -- + -- BUT we can't use "exprIsCheap", because that causes a strictness bug. + -- x = let y* = E in case (scc y) of { T -> F; F -> T} + -- The case expression is 'cheap', but it's wrong to transform to + -- y* = E; x = case (scc y) of {...} + -- Either we must be careful not to float demanded non-values, or + -- we must use exprIsValue for the test, which ensures that the + -- thing is non-strict. I think. The WARN below tests for this. + else if is_top_level || exprIsTrivial rhs2 || exprIsValue rhs2 then + + -- There's a subtlety here. There may be a binding (x* = e) in the + -- floats, where the '*' means 'will be demanded'. So is it safe + -- to float it out? Answer no, but it won't matter because + -- we only float if arg' is a WHNF, + -- and so there can't be any 'will be demanded' bindings in the floats. + -- Hence the assert + WARN( any demanded_float (floatBinds floats), + ppr (filter demanded_float (floatBinds floats)) ) + + tick LetFloatFromLet `thenSmpl_` ( + addFloats env1 floats $ \ env2 -> + addAtomicBinds env2 (fromOL aux_binds) $ \ env3 -> + completeLazyBind env3 top_lvl bndr bndr'' rhs2) + + else + completeLazyBind env1 top_lvl bndr bndr'' (wrapFloats floats rhs1) #ifdef DEBUG -simplExpr env (Lam (TyBinder _) _) (_ : _) result_ty - = panic "simplExpr:TyLam with non-TyArg" +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} -Ordinary lambdas -~~~~~~~~~~~~~~~~ +%************************************************************************ +%* * +\subsection{Completing a lazy binding} +%* * +%************************************************************************ -There's a complication with lambdas that aren't saturated. -Suppose we have: +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 - (\x. \y. ...x...) +It does the following: + - tries discarding a dead binding + - tries PostInlineUnconditionally + - add unfolding [this is the only place we add an unfolding] + - add arity -If we did nothing, x is used inside the \y, so would be marked -as dangerous to dup. But in the common case where the abstraction -is applied to two arguments this is over-pessimistic. -So instead we don't take account of the \y when dealing with x's usage; -instead, the simplifier is careful when partially applying lambdas. +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} -simplExpr env expr@(Lam (ValBinder binder) body) orig_args result_ty - = go 0 env expr orig_args - where - go n env (Lam (ValBinder binder) body) (val_arg : args) - | isValArg val_arg -- The lambda has an argument - = tick BetaReduction `thenSmpl_` - go (n+1) (extendIdEnvWithAtom env binder val_arg) body args - - go n env expr@(Lam (ValBinder binder) body) args - -- The lambda is un-saturated, so we must zap the occurrence info - -- on the arguments we've already beta-reduced into the body of the lambda - = ASSERT( null args ) -- Value lambda must match value argument! - let - new_env = markDangerousOccs env (take n orig_args) - in - simplValLam new_env expr 0 {- Guaranteed applied to at least 0 args! -} result_ty - `thenSmpl` \ (expr', arity) -> - returnSmpl expr' - - go n env non_val_lam_expr args -- The lambda had enough arguments - = simplExpr env non_val_lam_expr args result_ty -\end{code} +completeLazyBind :: SimplEnv + -> TopLevelFlag -- Flag stuck into unfolding + -> InId -- Old binder + -> OutId -- New binder + -> OutExpr -- Simplified RHS + -> SimplM (FloatsWith SimplEnv) +-- We return a new SimplEnv, because completeLazyBind may choose to do its work +-- by extending the substitution (e.g. let x = y in ...) +-- The new binding (if any) is returned as part of the floats. +-- NB: the returned SimplEnv has the right SubstEnv, but you should +-- (as usual) use the in-scope-env from the floats + +completeLazyBind env top_lvl old_bndr new_bndr new_rhs + | postInlineUnconditionally env new_bndr occ_info new_rhs + = -- Drop the binding + tick (PostInlineUnconditionally old_bndr) `thenSmpl_` + returnSmpl (emptyFloats env, extendSubst env old_bndr (DoneEx new_rhs)) + -- Use the substitution to make quite, quite sure that the substitution + -- will happen, since we are going to discard the binding + + | otherwise + = let + -- Add arity info + new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs + + -- Add the unfolding *only* for non-loop-breakers + -- Making loop breakers not have an unfolding at all + -- means that we can avoid tests in exprIsConApp, for example. + -- This is important: if exprIsConApp says 'yes' for a recursive + -- thing, then we can get into an infinite loop + info_w_unf | loop_breaker = new_bndr_info + | otherwise = new_bndr_info `setUnfoldingInfo` unfolding + unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs + + final_id = new_bndr `setIdInfo` info_w_unf + in + -- These seqs forces the Id, and hence its IdInfo, + -- and hence any inner substitutions + final_id `seq` + returnSmpl (unitFloat env final_id new_rhs, env) + where + loop_breaker = isLoopBreaker occ_info + old_info = idInfo old_bndr + occ_info = occInfo old_info +\end{code} -Let expressions -~~~~~~~~~~~~~~~ -\begin{code} -simplExpr env (Let bind body) args result_ty - = simplBind env bind (\env -> simplExpr env body args result_ty) result_ty -\end{code} -Case expressions -~~~~~~~~~~~~~~~~ +%************************************************************************ +%* * +\subsection[Simplify-simplExpr]{The main function: simplExpr} +%* * +%************************************************************************ -\begin{code} -simplExpr env expr@(Case scrut alts) args result_ty - = simplCase env scrut alts (\env rhs -> simplExpr env rhs args result_ty) result_ty -\end{code} +The reason for this OutExprStuff stuff is that we want to float *after* +simplifying a RHS, not before. If we do so naively we get quadratic +behaviour as things float out. +To see why it's important to do it after, consider this (real) example: -Coercions -~~~~~~~~~ -\begin{code} -simplExpr env (Coerce coercion ty body) args result_ty - = simplCoerce env coercion ty body args result_ty -\end{code} + let t = f x + in fst t +==> + let t = let a = e1 + b = e2 + in (a,b) + in fst t +==> + let a = e1 + b = e2 + t = (a,b) + in + a -- Can't inline a this round, cos it appears twice +==> + e1 +Each of the ==> steps is a round of simplification. We'd save a +whole round if we float first. This can cascade. Consider -Set-cost-centre -~~~~~~~~~~~~~~~ + let f = g d + in \x -> ...f... +==> + let f = let d1 = ..d.. in \y -> e + in \x -> ...f... +==> + let d1 = ..d.. + in \x -> ...(\y ->e)... -1) Eliminating nested sccs ... -We must be careful to maintain the scc counts ... +Only in this second round can the \y be applied, and it +might do the same again. -\begin{code} -simplExpr env (SCC cc1 (SCC cc2 expr)) args result_ty - | not (isSccCountCostCentre cc2) && case cmpCostCentre cc1 cc2 of { EQ_ -> True; _ -> False } - -- eliminate inner scc if no call counts and same cc as outer - = simplExpr env (SCC cc1 expr) args result_ty - - | not (isSccCountCostCentre cc2) && not (isSccCountCostCentre cc1) - -- eliminate outer scc if no call counts associated with either ccs - = simplExpr env (SCC cc2 expr) args result_ty -\end{code} -2) Moving sccs inside lambdas ... - \begin{code} -simplExpr env (SCC cc (Lam binder@(ValBinder _) body)) args result_ty - | not (isSccCountCostCentre cc) - -- move scc inside lambda only if no call counts - = simplExpr env (Lam binder (SCC cc body)) args result_ty - -simplExpr env (SCC cc (Lam binder body)) args result_ty - -- always ok to move scc inside type/usage lambda - = simplExpr env (Lam binder (SCC cc body)) args result_ty -\end{code} +simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr +simplExpr env expr = simplExprC env expr (mkStop expr_ty' AnArg) + where + expr_ty' = substTy (getSubst env) (exprType expr) + -- The type in the Stop continuation, expr_ty', is usually not used + -- It's only needed when discarding continuations after finding + -- a function that returns bottom. + -- Hence the lazy substitution + + +simplExprC :: SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr + -- Simplify an expression, given a continuation +simplExprC env expr cont + = simplExprF env expr cont `thenSmpl` \ (floats, expr) -> + returnSmpl (wrapFloats floats expr) + +simplExprF :: SimplEnv -> InExpr -> SimplCont -> SimplM FloatsWithExpr + -- Simplify an expression, returning floated binds + +simplExprF env (Var v) cont = simplVar env v cont +simplExprF env (Lit lit) cont = rebuild env (Lit lit) cont +simplExprF env expr@(Lam _ _) cont = simplLam env expr cont +simplExprF env (Note note expr) cont = simplNote env note expr cont +simplExprF env (App fun arg) cont = simplExprF env fun (ApplyTo NoDup arg env cont) + +simplExprF env (Type ty) cont + = ASSERT( contIsRhsOrArg cont ) + simplType env ty `thenSmpl` \ ty' -> + rebuild env (Type ty') cont + +simplExprF env (Case scrut bndr alts) cont + | not (switchIsOn (getSwitchChecker env) NoCaseOfCase) + = -- Simplify the scrutinee with a Select continuation + simplExprF env scrut (Select NoDup bndr alts env cont) -3) Eliminating dict sccs ... + | 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 (contResultType cont)) -\begin{code} -simplExpr env (SCC cc expr) args result_ty - | squashableDictishCcExpr cc expr - -- eliminate dict cc if trivial dict expression - = simplExpr env expr args result_ty -\end{code} +simplExprF env (Let (Rec pairs) body) cont + = simplRecBndrs env (map fst pairs) `thenSmpl` \ (env, bndrs') -> + -- NB: bndrs' don't have unfoldings or spec-envs + -- We add them as we go down, using simplPrags -4) Moving arguments inside the body of an scc ... -This moves the cost of doing the application inside the scc -(which may include the cost of extracting methods etc) + simplRecBind env NotTopLevel pairs bndrs' `thenSmpl` \ (floats, env) -> + addFloats env floats $ \ env -> + simplExprF env body cont -\begin{code} -simplExpr env (SCC cost_centre body) args result_ty - = let - new_env = setEnclosingCC env cost_centre - in - simplExpr new_env body args result_ty `thenSmpl` \ body' -> - returnSmpl (SCC cost_centre body') +-- 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 (getSubst env) ty \end{code} + %************************************************************************ %* * -\subsection{Simplify RHS of a Let/Letrec} +\subsection{Lambdas} %* * %************************************************************************ -simplRhsExpr does arity-expansion. That is, given: - - * a right hand side /\ tyvars -> \a1 ... an -> e - * the information (stored in BinderInfo) that the function will always - be applied to at least k arguments - -it transforms the rhs to - - /\tyvars -> \a1 ... an b(n+1) ... bk -> (e b(n+1) ... bk) +\begin{code} +simplLam env fun cont + = go env fun cont + where + zap_it = mkLamBndrZapper fun (countArgs cont) + cont_ty = contResultType cont + + -- Type-beta reduction + go env (Lam bndr body) (ApplyTo _ (Type ty_arg) arg_se body_cont) + = ASSERT( isTyVar bndr ) + tick (BetaReduction bndr) `thenSmpl_` + simplType (setInScope arg_se env) ty_arg `thenSmpl` \ ty_arg' -> + go (extendSubst env bndr (DoneTy ty_arg')) body body_cont + + -- Ordinary beta reduction + go env (Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont) + = tick (BetaReduction bndr) `thenSmpl_` + simplNonRecBind env (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 + (bndrs,body) = collectBinders lam -This is a Very Good Thing! + -- Exactly enough args + go env expr cont = simplExprF env expr cont -\begin{code} -simplRhsExpr - :: SimplEnv - -> InBinder - -> InExpr - -> OutId -- The new binder (used only for its type) - -> SmplM (OutExpr, ArityInfo) +mkLamBndrZapper :: CoreExpr -- Function + -> 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 -> zapLamIdInfo b + where + -- 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} -First a special case for variable right-hand sides - v = w -It's OK to simplify the RHS, but it's often a waste of time. Often -these v = w things persist because v is exported, and w is used -elsewhere. So if we're not careful we'll eta expand the rhs, only -to eta reduce it in competeNonRec. - -If we leave the binding unchanged, we will certainly replace v by w at -every occurrence of v, which is good enough. - -In fact, it's *better* to replace v by w than to inline w in v's rhs, -even if this is the only occurrence of w. Why? Because w might have -IdInfo (like strictness) that v doesn't. -Furthermore, there might be other uses of w; if so, inlining w in -v's rhs will duplicate w's rhs, whereas replacing v by w doesn't. - -HOWEVER, we have to be careful if w is something that *must* be -inlined. In particular, its binding may have been dropped. Here's -an example that actually happened: - let x = let y = e in y - in f x -The "let y" was floated out, and then (since y occurs once in a -definitely inlinable position) the binding was dropped, leaving - {y=e} let x = y in f x -But now using the reasoning of this little section, -y wasn't inlined, because it was a let x=y form. -\begin{code} -simplRhsExpr env binder@(id,occ_info) (Var v) new_id - | maybeToBool maybe_stop_at_var - = returnSmpl (Var the_var, getIdArity the_var) - where - maybe_stop_at_var - = case (runEager $ lookupId env v) of - VarArg v' | not (must_unfold v') -> Just v' - other -> Nothing - - Just the_var = maybe_stop_at_var - - must_unfold v' = idMustBeINLINEd v' - || case lookupOutIdEnv env v' of - Just (_, _, InUnfolding _ _) -> True - other -> False -\end{code} +%************************************************************************ +%* * +\subsection{Notes} +%* * +%************************************************************************ \begin{code} -simplRhsExpr env binder@(id,occ_info) rhs new_id - | maybeToBool (maybeAppDataTyCon rhs_ty) - -- Deal with the data type case, in which case the elaborate - -- eta-expansion nonsense is really quite a waste of time. - = simplExpr rhs_env rhs [] rhs_ty `thenSmpl` \ rhs' -> - returnSmpl (rhs', ArityExactly 0) - - | otherwise -- OK, use the big hammer - = -- Deal with the big lambda part - ASSERT( null uvars ) -- For now - - mapSmpl cloneTyVarSmpl tyvars `thenSmpl` \ tyvars' -> - let - new_tys = mkTyVarTys tyvars' - body_ty = foldl applyTy rhs_ty new_tys - lam_env = extendTyEnvList rhs_env (zipEqual "simplRhsExpr" tyvars new_tys) - in - -- Deal with the little lambda part - -- Note that we call simplLam even if there are no binders, - -- in case it can do arity expansion. - simplValLam lam_env body (getBinderInfoArity occ_info) body_ty `thenSmpl` \ (lambda', arity) -> - - -- Put on the big lambdas, trying to float out any bindings caught inside - mkRhsTyLam tyvars' lambda' `thenSmpl` \ rhs' -> +simplNote env (Coerce to from) body cont + = let + in_scope = getInScope env - returnSmpl (rhs', arity) - where - rhs_ty = idType new_id - rhs_env | idWantsToBeINLINEd id -- Don't ever inline in a INLINE thing's rhs - = switchOffInlining env1 -- See comments with switchOffInlining - | otherwise - = env1 - - -- The top level "enclosing CC" is "SUBSUMED". But the enclosing CC - -- for the rhs of top level defs is "OST_CENTRE". Consider - -- f = \x -> e - -- g = \y -> let v = f y in scc "x" (v ...) - -- Here we want to inline "f", since its CC is SUBSUMED, but we don't - -- want to inline "v" since its CC is dynamically determined. - - current_cc = getEnclosingCC env - env1 | costsAreSubsumed current_cc = setEnclosingCC env useCurrentCostCentre - | otherwise = env - - (uvars, tyvars, body) = collectUsageAndTyBinders rhs + addCoerce s1 k1 (CoerceIt t1 cont) + -- coerce T1 S1 (coerce S1 K1 e) + -- ==> + -- e, if T1=K1 + -- coerce T1 K1 e, otherwise + -- + -- For example, in the initial form of a worker + -- we may find (coerce T (coerce S (\x.e))) y + -- and we'd like it to simplify to e[y/x] in one round + -- of simplification + | t1 `eqType` k1 = cont -- The coerces cancel out + | otherwise = CoerceIt t1 cont -- They don't cancel, but + -- the inner one is redundant + + addCoerce t1t2 s1s2 (ApplyTo dup arg arg_se cont) + | 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 (mkSubst in_scope (getSubstEnv arg_se)) arg) + in + ApplyTo dup new_arg (zapSubstEnv env) (addCoerce t2 s2 cont) + + addCoerce to' _ cont = CoerceIt to' cont + in + simplType env to `thenSmpl` \ to' -> + simplType env from `thenSmpl` \ from' -> + simplExprF env body (addCoerce to' from' cont) + + +-- Hack: we only distinguish subsumed cost centre stacks for the purposes of +-- inlining. All other CCCSs are mapped to currentCCS. +simplNote env (SCC cc) e cont + = simplExpr (setEnclosingCC env currentCCS) e `thenSmpl` \ e' -> + rebuild env (mkSCC cc e') cont + +simplNote env InlineCall e cont + = simplExprF env e (InlinePlease cont) + +-- See notes with SimplMonad.inlineMode +simplNote env InlineMe e cont + | contIsRhsOrArg cont -- Totally boring continuation; see notes above + = -- Don't inline inside an INLINE expression + simplExpr (setMode inlineMode env ) e `thenSmpl` \ e' -> + rebuild env (mkInlineMe e') cont + + | otherwise -- Dissolve the InlineMe note if there's + -- an interesting context of any kind to combine with + -- (even a type application -- anything except Stop) + = simplExprF env e cont \end{code} %************************************************************************ %* * -\subsection{Simplify a lambda abstraction} +\subsection{Dealing with calls} %* * %************************************************************************ -Simplify (\binders -> body) trying eta expansion and reduction, given that -the abstraction will always be applied to at least min_no_of_args. - \begin{code} -simplValLam env expr min_no_of_args expr_ty - | not (switchIsSet env SimplDoLambdaEtaExpansion) || -- Bale out if eta expansion off - - exprIsTrivial expr || -- or it's a trivial RHS - -- No eta expansion for trivial RHSs - -- It's rather a Bad Thing to expand - -- g = f alpha beta - -- to - -- g = \a b c -> f alpha beta a b c +simplVar env var cont + = case lookupIdSubst (getSubst env) var of + DoneEx e -> simplExprF (zapSubstEnv env) e cont + ContEx se e -> simplExprF (setSubstEnv env se) e cont + DoneId var1 occ -> WARN( not (isInScope var1 (getSubst env)) && mustHaveLocalBinding var1, + text "simplVar:" <+> ppr var ) + completeCall (zapSubstEnv env) var1 occ cont + -- The template is already simplified, so don't re-substitute. + -- This is VITAL. Consider + -- let x = e in + -- let y = \z -> ...x... in + -- \ x -> ...y... + -- We'll clone the inner \x, adding x->x' in the id_subst + -- Then when we inline y, we must *not* replace x by x' in + -- the inlined copy!! + +--------------------------------------------------------- +-- Dealing with a call site + +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 -> + + -- 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 -- - -- The original RHS is "trivial" (exprIsTrivial), because it generates - -- no code (renames f to g). But the new RHS isn't. + -- 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 - null potential_extra_binder_tys || -- or ain't a function - no_of_extra_binders <= 0 -- or no extra binders needed - = cloneIds env binders `thenSmpl` \ binders' -> let - new_env = extendIdEnvWithClones env binders binders' + in_scope = getInScope env + maybe_rule = case activeRule env of + Nothing -> Nothing -- No rules apply + Just act_fn -> lookupRule act_fn in_scope var args in - simplExpr new_env body [] body_ty `thenSmpl` \ body' -> - returnSmpl (mkValLam binders' body', final_arity) - - | otherwise -- Eta expansion possible - = -- A SSERT( no_of_extra_binders <= length potential_extra_binder_tys ) - (if not ( no_of_extra_binders <= length potential_extra_binder_tys ) then - pprTrace "simplValLam" (vcat [ppr PprDebug expr, - ppr PprDebug expr_ty, - ppr PprDebug binders, - int no_of_extra_binders, - ppr PprDebug potential_extra_binder_tys]) - else \x -> x) $ - - tick EtaExpansion `thenSmpl_` - cloneIds env binders `thenSmpl` \ binders' -> + 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 + + -- Next, look for an inlining let - new_env = extendIdEnvWithClones env binders binders' - in - newIds extra_binder_tys `thenSmpl` \ extra_binders' -> - simplExpr new_env body (map VarArg extra_binders') etad_body_ty `thenSmpl` \ body' -> - returnSmpl ( - mkValLam (binders' ++ extra_binders') body', - final_arity - ) + arg_infos = [ interestingArg arg | arg <- args, isValArg arg] + 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_` + 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 - (binders,body) = collectValBinders expr - no_of_binders = length binders - (arg_tys, res_ty) = splitFunTyExpandingDicts expr_ty - potential_extra_binder_tys = (if not (no_of_binders <= length arg_tys) then - pprTrace "simplValLam" (vcat [ppr PprDebug expr, - ppr PprDebug expr_ty, - ppr PprDebug binders]) - else \x->x) $ - drop no_of_binders arg_tys - body_ty = mkFunTys potential_extra_binder_tys res_ty - - -- Note: it's possible that simplValLam will be applied to something - -- with a forall type. Eg when being applied to the rhs of - -- let x = wurble - -- where wurble has a forall-type, but no big lambdas at the top. - -- We could be clever an insert new big lambdas, but we don't bother. - - etad_body_ty = mkFunTys (drop no_of_extra_binders potential_extra_binder_tys) res_ty - extra_binder_tys = take no_of_extra_binders potential_extra_binder_tys - final_arity = atLeastArity (no_of_binders + no_of_extra_binders) - - no_of_extra_binders = -- First, use the info about how many args it's - -- always applied to in its scope; but ignore this - -- info for thunks. To see why we ignore it for thunks, - -- consider let f = lookup env key in (f 1, f 2) - -- We'd better not eta expand f just because it is - -- always applied! - (min_no_of_args - no_of_binders) - - -- Next, try seeing if there's a lambda hidden inside - -- something cheap. - -- etaExpandCount can reuturn a huge number (like 10000!) if - -- it finds that the body is a call to "error"; hence - -- the use of "min" here. - `max` - (etaExpandCount body `min` length potential_extra_binder_tys) - - -- Finally, see if it's a state transformer, in which - -- case we eta-expand on principle! This can waste work, - -- but usually doesn't - `max` - case potential_extra_binder_tys of - [ty] | ty `eqTy` realWorldStateTy -> 1 - other -> 0 -\end{code} + zap_it = mkLamBndrZapper fun (length args) + + -- Type-beta reduction + go env (Lam bndr body) (Type ty_arg : args) + = ASSERT( isTyVar bndr ) + tick (BetaReduction bndr) `thenSmpl_` + go (extendSubst env bndr (DoneTy ty_arg)) body args + + -- 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} %************************************************************************ %* * -\subsection[Simplify-coerce]{Coerce expressions} +\subsection{Arguments} %* * %************************************************************************ \begin{code} --- (coerce (case s of p -> r)) args ==> case s of p -> (coerce r) args -simplCoerce env coercion ty expr@(Case scrut alts) args result_ty - = simplCase env scrut alts (\env rhs -> simplCoerce env coercion ty rhs args result_ty) result_ty - --- (coerce (let defns in b)) args ==> let defns' in (coerce b) args -simplCoerce env coercion ty (Let bind body) args result_ty - = simplBind env bind (\env -> simplCoerce env coercion ty body args result_ty) result_ty - --- Default case -simplCoerce env coercion ty expr args result_ty - = simplTy env ty `appEager` \ ty' -> - simplTy env expr_ty `appEager` \ expr_ty' -> - simplExpr env expr [] expr_ty' `thenSmpl` \ expr' -> - returnSmpl (mkGenApp (mkCoerce coercion ty' expr') args) +--------------------------------------------------------- +-- 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 - expr_ty = coreExprType (unTagBinders expr) -- Rather like simplCase other_scrut - - -- Try cancellation; we do this "on the way up" because - -- I think that's where it'll bite best - mkCoerce (CoerceOut con1) ty1 (Coerce (CoerceIn con2) ty2 body) | con1 == con2 = body - mkCoerce coercion ty body = Coerce coercion ty body -\end{code} + 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) -%************************************************************************ -%* * -\subsection[Simplify-bind]{Binding groups} -%* * -%************************************************************************ +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 -\begin{code} -simplBind :: SimplEnv - -> InBinding - -> (SimplEnv -> SmplM OutExpr) - -> OutType - -> SmplM OutExpr - -simplBind env (NonRec binder rhs) body_c body_ty = simplNonRec env binder rhs body_c body_ty -simplBind env (Rec pairs) body_c body_ty = simplRec env pairs body_c body_ty + | otherwise + = simplExprF (setInScope arg_se env) val_arg + (mkStop arg_ty AnArg) `thenSmpl` \ (floats, arg1) -> + addFloats env floats $ \ env -> + 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[Simplify-let]{Let-expressions} +\subsection{mkAtomicArgs} %* * %************************************************************************ -Float switches -~~~~~~~~~~~~~~ -The booleans controlling floating have to be set with a little care. -Here's one performance bug I found: - - let x = let y = let z = case a# +# 1 of {b# -> E1} - in E2 - in E3 - in E4 - -Now, if E2, E3 aren't HNFs we won't float the y-binding or the z-binding. -Before case_floating_ok included float_exposes_hnf, the case expression was floated -*one level per simplifier iteration* outwards. So it made th s +mkAtomicArgs takes a putative RHS, checks whether it's a PAP or +constructor application and, if so, converts it to ANF, so that the +resulting thing can be inlined more easily. Thus + x = (f a, g b) +becomes + t1 = f a + t2 = g b + x = (t1,t2) +There are three sorts of binding context, specified by the two +boolean arguments -Floating case from let -~~~~~~~~~~~~~~~~~~~~~~ -When floating cases out of lets, remember this: +Strict + OK-unlifted - let x* = case e of alts - in +N N Top-level or recursive Only bind args of lifted type -where x* is sure to be demanded or e is a cheap operation that cannot -fail, e.g. unboxed addition. Here we should be prepared to duplicate -. A good example: +N Y Non-top-level and non-recursive, Bind args of lifted type, or + but lazy unlifted-and-ok-for-speculation - let x* = case y of - p1 -> build e1 - p2 -> build e2 - in - foldr c n x* -==> - case y of - p1 -> foldr c n (build e1) - p2 -> foldr c n (build e2) +Y Y Non-top-level, non-recursive, Bind all args + and strict (demanded) + -NEW: We use the same machinery that we use for case-of-case to -*always* do case floating from let, that is we let bind and abstract -the original let body, and let the occurrence analyser later decide -whether the new let should be inlined or not. The example above -becomes: - -==> - let join_body x' = foldr c n x' - in case y of - p1 -> let x* = build e1 - in join_body x* - p2 -> let x* = build e2 - in join_body x* +For example, given -note that join_body is a let-no-escape. -In this particular example join_body will later be inlined, -achieving the same effect. -ToDo: check this is OK with andy + x = MkC (y div# z) +there is no point in transforming to -Let to case: two points -~~~~~~~~~~~ + x = case (y div# z) of r -> MkC r -Point 1. We defer let-to-case for all data types except single-constructor -ones. Suppose we change - - let x* = e in b -to - case e of x -> b - -It can be the case that we find that b ultimately contains ...(case x of ..).... -and this is the only occurrence of x. Then if we've done let-to-case -we can't inline x, which is a real pain. On the other hand, we lose no -transformations by not doing this transformation, because the relevant -case-of-X transformations are also implemented by simpl_bind. - -If x is a single-constructor type, then we go ahead anyway, giving - - case e of (y,z) -> let x = (y,z) in b - -because now we can squash case-on-x wherever they occur in b. - -We do let-to-case on multi-constructor types in the tidy-up phase -(tidyCoreExpr) mainly so that the code generator doesn't need to -spot the demand-flag. +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} +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 -Point 2. It's important to try let-to-case before doing the -strict-let-of-case transformation, which happens in the next equation -for simpl_bind. +mkAtomicArgs is_strict ok_float_unlifted rhs + | (Var fun, args) <- collectArgs rhs, -- It's an application + isDataConId fun || valArgCount args < idArity fun -- And it's a constructor or PAP + = go fun nilOL [] args -- Have a go - let a*::Int = case v of {p1->e1; p2->e2} - in b + | otherwise = bale_out -- Give up -(The * means that a is sure to be demanded.) -If we do case-floating first we get this: + where + bale_out = returnSmpl (nilOL, rhs) + + go fun binds rev_args [] + = returnSmpl (binds, mkApps (Var fun) (reverse rev_args)) + + go fun binds rev_args (arg : args) + | exprIsTrivial arg -- Easy case + = go fun binds (arg:rev_args) args + + | not can_float_arg -- Can't make this arg atomic + = bale_out -- ... so give up + + | 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 ) + returnSmpl (emptyFloats env, Case r v [(DEFAULT,[], wrapFloats floats expr)]) - let k = \a* -> b - in case v of - p1-> let a*=e1 in k a - p2-> let a*=e2 in k a + | otherwise + = addAuxiliaryBind env (NonRec v r) $ \ env -> + addAtomicBindsE env bs thing_inside +\end{code} -Now watch what happens if we do let-to-case first: - case (case v of {p1->e1; p2->e2}) of - Int a# -> let a*=I# a# in b -===> - let k = \a# -> let a*=I# a# in b - in case v of - p1 -> case e1 of I# a# -> k a# - p1 -> case e2 of I# a# -> k a# +%************************************************************************ +%* * +\subsection{The main rebuilder} +%* * +%************************************************************************ -The latter is clearly better. (Remember the reboxing let-decl for a -is likely to go away, because after all b is strict in a.) +\begin{code} +rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM FloatsWithExpr -We do not do let to case for WHNFs, e.g. +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 - let x = a:b in ... - =/=> - case a:b of x in ... +rebuildApp env fun arg cont + = simplExpr env arg `thenSmpl` \ arg' -> + rebuild env (App fun arg') cont -as this is less efficient. but we don't mind doing let-to-case for -"bottom", as that will allow us to remove more dead code, if anything: +rebuildDone env expr = returnSmpl (emptyFloats env, expr) +\end{code} - let x = error in ... - ===> - case error of x -> ... - ===> - error -Notice that let to case occurs only if x is used strictly in its body -(obviously). +%************************************************************************ +%* * +\subsection{Functions dealing with a case} +%* * +%************************************************************************ +Blob of helper functions for the "case-of-something-else" situation. \begin{code} --- Dead code is now discarded by the occurrence analyser, +--------------------------------------------------------- +-- Eliminate the case if possible + +rebuildCase :: SimplEnv + -> OutExpr -- Scrutinee + -> InId -- Case binder + -> [InAlt] -- Alternatives + -> SimplCont + -> SimplM FloatsWithExpr + +rebuildCase env scrut case_bndr alts cont + | Just (con,args) <- exprIsConApp_maybe scrut + -- Works when the scrutinee is a variable with a known unfolding + -- as well as when it's an explicit constructor application + = knownCon env (DataAlt con) args case_bndr alts cont + + | Lit lit <- scrut -- No need for same treatment as constructors + -- because literals are inlined more vigorously + = knownCon env (LitAlt lit) [] case_bndr alts cont -simplNonRec env binder@(id,occ_info) rhs body_c body_ty - | inlineUnconditionally ok_to_dup occ_info - = -- The binder is used in definitely-inline way in the body - -- So add it to the environment, drop the binding, and continue - body_c (extendEnvGivenInlining env id occ_info rhs) - - | idWantsToBeINLINEd id - = complete_bind env rhs -- Don't mess about with floating or let-to-case on - -- INLINE things | otherwise - = simpl_bind env rhs - where - -- Try let-to-case; see notes below about let-to-case - simpl_bind env rhs | try_let_to_case && - will_be_demanded && - (rhs_is_bot || - not rhs_is_whnf && - singleConstructorType rhs_ty - -- Only do let-to-case for single constructor types. - -- For other types we defer doing it until the tidy-up phase at - -- the end of simplification. - ) - = tick Let2Case `thenSmpl_` - simplCase env rhs (AlgAlts [] (BindDefault binder (Var id))) - (\env rhs -> complete_bind env rhs) body_ty - -- OLD COMMENT: [now the new RHS is only "x" so there's less worry] - -- NB: it's tidier to call complete_bind not simpl_bind, else - -- we nearly end up in a loop. Consider: - -- let x = rhs in b - -- ==> case rhs of (p,q) -> let x=(p,q) in b - -- This effectively what the above simplCase call does. - -- Now, the inner let is a let-to-case target again! Actually, since - -- the RHS is in WHNF it won't happen, but it's a close thing! - - -- Try let-from-let - simpl_bind env (Let bind rhs) | let_floating_ok - = tick LetFloatFromLet `thenSmpl_` - simplBind env (fix_up_demandedness will_be_demanded bind) - (\env -> simpl_bind env rhs) body_ty - - -- Try case-from-let; this deals with a strict let of error too - simpl_bind env (Case scrut alts) | case_floating_ok scrut - = tick CaseFloatFromLet `thenSmpl_` - - -- First, bind large let-body if necessary - if ok_to_dup || isSingleton (nonErrorRHSs alts) - then - simplCase env scrut alts (\env rhs -> simpl_bind env rhs) body_ty - else - bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) -> - let - body_c' = \env -> simplExpr env new_body [] body_ty - case_c = \env rhs -> simplNonRec env binder rhs body_c' body_ty - in - simplCase env scrut alts case_c body_ty `thenSmpl` \ case_expr -> - returnSmpl (Let extra_binding case_expr) - - -- None of the above; simplify rhs and tidy up - simpl_bind env rhs = complete_bind env rhs - - complete_bind env rhs - = cloneId env binder `thenSmpl` \ new_id -> - simplRhsExpr env binder rhs new_id `thenSmpl` \ (rhs',arity) -> - completeNonRec env binder - (new_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds) -> - body_c new_env `thenSmpl` \ body' -> - returnSmpl (mkCoLetsAny binds body') - - - -- All this stuff is computed at the start of the simpl_bind loop - float_lets = switchIsSet env SimplFloatLetsExposingWHNF - float_primops = switchIsSet env SimplOkToFloatPrimOps - ok_to_dup = switchIsSet env SimplOkToDupCode - always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets - try_let_to_case = switchIsSet env SimplLetToCase - no_float = switchIsSet env SimplNoLetFromStrictLet - - demand_info = getIdDemandInfo id - will_be_demanded = willBeDemanded demand_info - rhs_ty = idType id - - form = mkFormSummary rhs - rhs_is_bot = case form of - BottomForm -> True - other -> False - rhs_is_whnf = case form of - VarForm -> True - ValueForm -> True - other -> False - - float_exposes_hnf = floatExposesHNF float_lets float_primops ok_to_dup rhs - - let_floating_ok = (will_be_demanded && not no_float) || - always_float_let_from_let || - float_exposes_hnf - - case_floating_ok scrut = (will_be_demanded && not no_float) || - (float_exposes_hnf && is_cheap_prim_app scrut && float_primops) - -- See note below + = prepareAlts scrut case_bndr alts `thenSmpl` \ (better_alts, handled_cons) -> + + -- Deal with the case binder, and 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 -> + + -- Deal with variable scrutinee + simplCaseBinder env scrut case_bndr `thenSmpl` \ (alt_env, case_bndr', zap_occ_info) -> + + -- Deal with the case alternatives + simplAlts alt_env zap_occ_info handled_cons + case_bndr' better_alts dup_cont `thenSmpl` \ alts' -> + + -- Put the case back together + mkCase scrut case_bndr' alts' `thenSmpl` \ case_expr -> + + -- 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} +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. -@completeNonRec@ looks at the simplified post-floating RHS of the -let-expression, and decides what to do. There's one interesting -aspect to this, namely constructor reuse. Consider -@ - f = \x -> case x of - (y:ys) -> y:ys - [] -> ... -@ -Is it a good idea to replace the rhs @y:ys@ with @x@? This depends a -bit on the compiler technology, but in general I believe not. For -example, here's some code from a real program: -@ -const.Int.max.wrk{-s2516-} = - \ upk.s3297# upk.s3298# -> - let { - a.s3299 :: Int - _N_ {-# U(P) #-} - a.s3299 = I#! upk.s3297# - } in - case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of { - _LT -> I#! upk.s3298# - _EQ -> a.s3299 - _GT -> a.s3299 - } -@ -The a.s3299 really isn't doing much good. We'd be better off inlining -it. (Actually, let-no-escapery means it isn't as bad as it looks.) - -So the current strategy is to inline all known-form constructors, and -only do the reverse (turn a constructor application back into a -variable) when we find a let-expression: -@ - let x = C a1 .. an - in - ... (let y = C a1 .. an in ...) ... -@ -where it is always good to ditch the binding for y, and replace y by -x. That's just what completeLetBinding does. +Note 1 +~~~~~~ +There is a time we *don't* want to do that, namely when +-fno-case-of-case is on. This happens in the first simplifier pass, +and enhances full laziness. Here's the bad case: + f = \ y -> ...(case x of I# v -> ...(case x of ...) ... ) +If we eliminate the inner case, we trap it inside the I# v -> arm, +which might prevent some full laziness happening. I've seen this +in action in spectral/cichelli/Prog.hs: + [(m,n) | m <- [1..max], n <- [1..max]] +Hence the check for NoCaseOfCase. +Note 2 +~~~~~~ +There is another situation when we don't want to do it. If we have -\begin{code} -{- FAILED CODE - The trouble is that we keep transforming - let x = coerce e - y = coerce x - in ... - to - let x' = coerce e - y' = coerce x' - in ... - and counting a couple of ticks for this non-transformation - - -- We want to ensure that all let-bound Coerces have - -- atomic bodies, so they can freely be inlined. -completeNonRec env binder new_id (Coerce coercion ty rhs) - | not (is_atomic rhs) - = newId (coreExprType rhs) `thenSmpl` \ inner_id -> - completeNonRec env - (inner_id, dangerousArgOcc) inner_id rhs `thenSmpl` \ (env1, binds1) -> - -- Dangerous occ because, like constructor args, - -- it can be duplicated easily - let - atomic_rhs = case runEager $ lookupId env1 inner_id of - LitArg l -> Lit l - VarArg v -> Var v - in - completeNonRec env1 binder new_id - (Coerce coercion ty atomic_rhs) `thenSmpl` \ (env2, binds2) -> + case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 } + ...other cases .... } - returnSmpl (env2, binds1 ++ binds2) --} +We'll perform the binder-swap for the outer case, giving + case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 } + ...other cases .... } - -- Right hand sides that are constructors - -- let v = C args - -- in - --- ...(let w = C same-args in ...)... - -- Then use v instead of w. This may save - -- re-constructing an existing constructor. -completeNonRec env binder new_id rhs@(Con con con_args) - | switchIsSet env SimplReuseCon && - maybeToBool maybe_existing_con && - not (isExported new_id) -- Don't bother for exported things - -- because we won't be able to drop - -- its binding. - = tick ConReused `thenSmpl_` - returnSmpl (extendIdEnvWithAtom env binder (VarArg it), [NonRec new_id rhs]) - where - maybe_existing_con = lookForConstructor env con con_args - Just it = maybe_existing_con - - - -- Default case - -- Check for atomic right-hand sides. - -- We used to have a "tick AtomicRhs" in here, but it causes more trouble - -- than it's worth. For a top-level binding a = b, where a is exported, - -- we can't drop the binding, so we get repeated AtomicRhs ticks -completeNonRec env binder@(id,occ_info) new_id new_rhs - | is_atomic eta'd_rhs -- If rhs (after eta reduction) is atomic - = returnSmpl (atomic_env , [NonRec new_id eta'd_rhs]) - - | otherwise -- Non atomic rhs (don't eta after all) - = returnSmpl (non_atomic_env , [NonRec new_id new_rhs]) - where - atomic_env = extendIdEnvWithAtom env binder the_arg - - non_atomic_env = extendEnvGivenBinding (extendIdEnvWithClone env binder new_id) - occ_info new_id new_rhs - - eta'd_rhs = etaCoreExpr new_rhs - the_arg = case eta'd_rhs of - Var v -> VarArg v - Lit l -> LitArg l -\end{code} +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 -%************************************************************************ -%* * -\subsection[Simplify-letrec]{Letrec-expressions} -%* * -%************************************************************************ + case x of w1 { A -> let w2 = w1 in e1 + B -> let w2 = w1 in e2 + ...other cases .... } -Letrec expressions -~~~~~~~~~~~~~~~~~~ -Here's the game plan +This is plain silly in the common case where w2 is dead. -1. Float any let(rec)s out of the RHSs -2. Clone all the Ids and extend the envt with these clones -3. Simplify one binding at a time, adding each binding to the - environment once it's done. +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: -This relies on the occurrence analyser to - a) break all cycles with an Id marked MustNotBeInlined - b) sort the decls into topological order -The former prevents infinite inlinings, and the latter means -that we get maximum benefit from working top to bottom. + data T = MkT !Int + case v of w { MkT x -> + case x of x1 { I# y1 -> + case x of x2 { I# y2 -> ... -\begin{code} -simplRec env pairs body_c body_ty - = -- Do floating, if necessary - floatBind env False (Rec pairs) `thenSmpl` \ [Rec pairs'] -> - let - binders = map fst pairs' - in - cloneIds env binders `thenSmpl` \ ids' -> - let - env_w_clones = extendIdEnvWithClones env binders ids' - in - simplRecursiveGroup env_w_clones ids' pairs' `thenSmpl` \ (pairs', new_env) -> +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. - body_c new_env `thenSmpl` \ body' -> +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: - returnSmpl (Let (Rec pairs') body') -\end{code} + (case x of { (a,b) -> a }) (case x of { (p,q) -> q }) -\begin{code} --- The env passed to simplRecursiveGroup already has --- bindings that clone the variables of the group. -simplRecursiveGroup env new_ids [] - = returnSmpl ([], env) - -simplRecursiveGroup env (new_id : new_ids) ((binder@(_, occ_info), rhs) : pairs) - | inlineUnconditionally ok_to_dup occ_info - = -- Single occurrence, so drop binding and extend env with the inlining - let - new_env = extendEnvGivenInlining env new_id occ_info rhs - in - simplRecursiveGroup new_env new_ids pairs +Here, b and p are dead. But when we move the argment inside the first +case RHS, and eliminate the second case, we get - | otherwise - = simplRhsExpr env binder rhs new_id `thenSmpl` \ (new_rhs, arity) -> - let - new_id' = new_id `withArity` arity - - -- ToDo: this next bit could usefully share code with completeNonRec + case x or { (a,b) -> a b } - new_env - | idMustNotBeINLINEd new_id -- Occurrence analyser says "don't inline" - = env +Urk! b is alive! Reason: the scrutinee was a variable, and case elimination +happened. Hence the zap_occ_info function returned by simplCaseBinder - | is_atomic eta'd_rhs -- If rhs (after eta reduction) is atomic - = extendIdEnvWithAtom env binder the_arg +\begin{code} +simplCaseBinder env (Var v) case_bndr + | not (switchIsOn (getSwitchChecker env) NoCaseOfCase) - | otherwise -- Non-atomic - = extendEnvGivenBinding env occ_info new_id new_rhs - -- Don't eta if it doesn't eliminate the binding +-- Failed try [see Note 2 above] +-- not (isEvaldUnfolding (idUnfolding v)) - eta'd_rhs = etaCoreExpr new_rhs - the_arg = case eta'd_rhs of - Var v -> VarArg v - Lit l -> LitArg l - in - simplRecursiveGroup new_env new_ids pairs `thenSmpl` \ (new_pairs, final_env) -> - returnSmpl ((new_id', new_rhs) : new_pairs, final_env) + = simplBinder env (zap case_bndr) `thenSmpl` \ (env, case_bndr') -> + returnSmpl (modifyInScope env v case_bndr', case_bndr', zap) + -- We could extend the substitution instead, but it would be + -- a hack because then the substitution wouldn't be idempotent + -- any more (v is an OutId). And this just just as well. where - ok_to_dup = switchIsSet env SimplOkToDupCode + zap b = b `setIdOccInfo` NoOccInfo + +simplCaseBinder env other_scrut case_bndr + = simplBinder env case_bndr `thenSmpl` \ (env, case_bndr') -> + returnSmpl (env, case_bndr', \ bndr -> bndr) -- NoOp on bndr \end{code} \begin{code} -floatBind :: SimplEnv - -> Bool -- True <=> Top level - -> InBinding - -> SmplM [InBinding] - -floatBind env top_level bind - | not float_lets || - n_extras == 0 - = returnSmpl [bind] - - | otherwise - = tickN LetFloatFromLet n_extras `thenSmpl_` - -- It's important to increment the tick counts if we - -- do any floating. A situation where this turns out - -- to be important is this: - -- Float in produces: - -- letrec x = let y = Ey in Ex - -- in B - -- Now floating gives this: - -- letrec x = Ex - -- y = Ey - -- in B - --- We now want to iterate once more in case Ey doesn't - -- mention x, in which case the y binding can be pulled - -- out as an enclosing let(rec), which in turn gives - -- the strictness analyser more chance. - returnSmpl binds' - +simplAlts :: SimplEnv + -> (InId -> InId) -- Occ-info zapper + -> [AltCon] -- Alternatives the scrutinee can't be + -- in the default case + -> OutId -- Case binder + -> [InAlt] -> SimplCont + -> SimplM [OutAlt] -- Includes the continuation + +simplAlts env zap_occ_info handled_cons case_bndr' alts cont' + = mapSmpl simpl_alt alts where - (binds', _, n_extras) = fltBind bind - - float_lets = switchIsSet env SimplFloatLetsExposingWHNF - always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets - - -- fltBind guarantees not to return leaky floats - -- and all the binders of the floats have had their demand-info zapped - fltBind (NonRec bndr rhs) - = (binds ++ [NonRec (un_demandify bndr) rhs'], - leakFree bndr rhs', - length binds) - where - (binds, rhs') = fltRhs rhs - - fltBind (Rec pairs) - = ([Rec (extras - ++ - binders `zip` rhss')], - and (zipWith leakFree binders rhss'), - length extras - ) - - where - (binders, rhss) = unzip pairs - (binds_s, rhss') = mapAndUnzip fltRhs rhss - extras = concat (map get_pairs (concat binds_s)) - - get_pairs (NonRec bndr rhs) = [(bndr,rhs)] - get_pairs (Rec pairs) = pairs - - -- fltRhs has same invariant as fltBind - fltRhs rhs - | (always_float_let_from_let || - floatExposesHNF True False False rhs) - = fltExpr rhs - - | otherwise - = ([], rhs) - - - -- fltExpr has same invariant as fltBind - fltExpr (Let bind body) - | not top_level || binds_wont_leak - -- fltExpr guarantees not to return leaky floats - = (binds' ++ body_binds, body') - where - (body_binds, body') = fltExpr body - (binds', binds_wont_leak, _) = fltBind bind - - fltExpr expr = ([], expr) - --- Crude but effective -leakFree (id,_) rhs = case getIdArity id of - ArityAtLeast n | n > 0 -> True - ArityExactly n | n > 0 -> True - other -> whnfOrBottom rhs + inst_tys' = tyConAppArgs (idType case_bndr') + + simpl_alt (DEFAULT, _, rhs) + = let + -- In the default case we record the constructors that the + -- case-binder *can't* be. + -- We take advantage of any OtherCon info in the case scrutinee + case_bndr_w_unf = case_bndr' `setIdUnfolding` mkOtherCon handled_cons + env_with_unf = modifyInScope env case_bndr' case_bndr_w_unf + in + simplExprC env_with_unf rhs cont' `thenSmpl` \ rhs' -> + returnSmpl (DEFAULT, [], rhs') + + simpl_alt (con, vs, rhs) + = -- Deal with the 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 + unfolding = mkUnfolding False (mkAltExpr con vs' inst_tys') + env_with_unf = modifyInScope env case_bndr' (case_bndr' `setIdUnfolding` unfolding) + in + simplExprC env_with_unf 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 + -- + -- case x of { T a b -> T (a+1) b } + -- + -- We really must record that b is already evaluated so that we don't + -- go and re-evaluate it when constructing the result. + + add_evals (DataAlt 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) + | isMarkedStrict str = evald_v : cat_evals vs strs + | otherwise = zapped_v : cat_evals vs strs + where + zapped_v = zap_occ_info v + evald_v = zapped_v `setIdUnfolding` mkOtherCon [] \end{code} %************************************************************************ %* * -\subsection[Simplify-atoms]{Simplifying atoms} +\subsection{Known constructor} %* * %************************************************************************ -\begin{code} -simplArg :: SimplEnv -> InArg -> Eager ans OutArg +We are a bit careful with occurrence info. Here's an example + + (\x* -> case x of (a*, b) -> f a) (h v, e) -simplArg env (LitArg lit) = returnEager (LitArg lit) -simplArg env (TyArg ty) = simplTy env ty `appEager` \ ty' -> - returnEager (TyArg ty') -simplArg env (VarArg id) = lookupId env id +where the * means "occurs once". This effectively becomes + case (h v, e) of (a*, b) -> f a) +and then + let a* = h v; b = e in f a +and then + f (h v) + +All this should happen in one sweep. + +\begin{code} +knownCon :: SimplEnv -> AltCon -> [OutExpr] + -> InId -> [InAlt] -> SimplCont + -> SimplM FloatsWithExpr + +knownCon env con args bndr alts cont + = tick (KnownBranch bndr) `thenSmpl_` + case findAlt con alts of + (DEFAULT, bs, rhs) -> ASSERT( null bs ) + simplNonRecX env bndr scrut $ \ env -> + -- This might give rise to a binding with non-atomic args + -- like x = Node (f x) (g x) + -- but no harm will be done + simplExprF env rhs cont + where + scrut = case con of + LitAlt lit -> Lit lit + DataAlt dc -> mkConApp dc args + + (LitAlt lit, bs, rhs) -> ASSERT( null bs ) + simplNonRecX env bndr (Lit lit) $ \ env -> + simplExprF env rhs cont + + (DataAlt dc, bs, rhs) -> ASSERT( length bs + n_tys == length args ) + bind_args env bs (drop n_tys args) $ \ env -> + let + con_app = mkConApp dc (take n_tys args ++ con_args) + con_args = [substExpr (getSubst env) (varToCoreExpr b) | b <- bs] + -- args are aready OutExprs, but bs are InIds + in + simplNonRecX env bndr con_app $ \ env -> + simplExprF env rhs cont + where + n_tys = dataConNumInstArgs dc -- Non-existential type args +-- Ugh! +bind_args env [] _ thing_inside = thing_inside env + +bind_args env (b:bs) (Type ty : args) thing_inside + = bind_args (extendSubst env b (DoneTy ty)) bs args thing_inside + +bind_args env (b:bs) (arg : args) thing_inside + = simplNonRecX env b arg $ \ env -> + bind_args env bs args thing_inside \end{code} + %************************************************************************ %* * -\subsection[Simplify-quickies]{Some local help functions} +\subsection{Duplicating continuations} %* * %************************************************************************ +\begin{code} +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} --- fix_up_demandedness switches off the willBeDemanded Info field --- for bindings floated out of a non-demanded let -fix_up_demandedness True {- Will be demanded -} bind - = bind -- Simple; no change to demand info needed -fix_up_demandedness False {- May not be demanded -} (NonRec binder rhs) - = NonRec (un_demandify binder) rhs -fix_up_demandedness False {- May not be demanded -} (Rec pairs) - = Rec [(un_demandify binder, rhs) | (binder,rhs) <- pairs] - -un_demandify (id, occ_info) = (id `addIdDemandInfo` noDemandInfo, occ_info) - -is_cheap_prim_app (Prim op _) = primOpOkForSpeculation op -is_cheap_prim_app other = False - -computeResultType :: SimplEnv -> InType -> [OutArg] -> OutType -computeResultType env expr_ty orig_args - = simplTy env expr_ty `appEager` \ expr_ty' -> +mkDupableCont :: SimplEnv -> SimplCont + -> SimplM (FloatsWith (SimplCont, SimplCont)) + +mkDupableCont env cont + | contIsDupable cont + = 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 -> + + if exprIsDupable arg' then + returnSmpl (emptyFloats env, (ApplyTo OkToDup arg' (zapSubstEnv se) dup_cont, nondup_cont)) + else + 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 - go ty [] = ty - go ty (TyArg ty_arg : args) = go (mkAppTy ty ty_arg) args - go ty (a:args) | isValArg a = case (getFunTy_maybe ty) of - Just (_, res_ty) -> go res_ty args - Nothing -> - pprPanic "computeResultType" (vcat [ - ppr PprDebug (a:args), - ppr PprDebug orig_args, - ppr PprDebug expr_ty', - ppr PprDebug ty]) + alt_env = setInScope se env in - go expr_ty' orig_args - - -var `withArity` UnknownArity = var -var `withArity` arity = var `addIdArity` arity - -is_atomic (Var v) = True -is_atomic (Lit l) = not (isNoRepLit l) -is_atomic other = False + 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) + = mkDupableAlt env case_bndr' dupable_cont alt `thenSmpl` \ (floats1, alt') -> + addFloats env floats1 $ \ env -> + go env alts `thenSmpl` \ (floats2, alts') -> + returnSmpl (floats2, alt' : alts') + +mkDupableAlt env case_bndr' cont alt@(con, bndrs, rhs) + = simplBinders env bndrs `thenSmpl` \ (env, bndrs') -> + simplExprC env rhs cont `thenSmpl` \ rhs' -> + + if exprIsDupable rhs' then + returnSmpl (emptyFloats env, (con, bndrs', rhs')) + -- It is worth checking for a small RHS because otherwise we + -- get extra let bindings that may cause an extra iteration of the simplifier to + -- inline back in place. Quite often the rhs is just a variable or constructor. + -- The Ord instance of Maybe in PrelMaybe.lhs, for example, took several extra + -- iterations because the version with the let bindings looked big, and so wasn't + -- inlined, but after the join points had been inlined it looked smaller, and so + -- was inlined. + -- + -- NB: we have to check the size of rhs', not rhs. + -- Duplicating a small InAlt might invalidate occurrence information + -- However, if it *is* dupable, we return the *un* simplified alternative, + -- because otherwise we'd need to pair it up with an empty subst-env.... + -- but we only have one env shared between all the alts. + -- (Remember we must zap the subst-env before re-simplifying something). + -- Rather than do this we simply agree to re-simplify the original (small) thing later. + + else + let + rhs_ty' = exprType rhs' + used_bndrs' = filter (not . isDeadBinder) (case_bndr' : bndrs') + -- The deadness info on the new binders is unscathed + in + -- If we try to lift a primitive-typed something out + -- for let-binding-purposes, we will *caseify* it (!), + -- with potentially-disastrous strictness results. So + -- instead we turn it into a function: \v -> e + -- where v::State# RealWorld#. The value passed to this function + -- is realworld#, which generates (almost) no code. + + -- There's a slight infelicity here: we pass the overall + -- case_bndr to all the join points if it's used in *any* RHS, + -- because we don't know its usage in each RHS separately + + -- We used to say "&& isUnLiftedType rhs_ty'" here, but now + -- we make the join point into a function whenever used_bndrs' + -- is empty. This makes the join-point more CPR friendly. + -- Consider: let j = if .. then I# 3 else I# 4 + -- in case .. of { A -> j; B -> j; C -> ... } + -- + -- Now CPR doesn't w/w j because it's a thunk, so + -- that means that the enclosing function can't w/w either, + -- which is a lose. Here's the example that happened in practice: + -- kgmod :: Int -> Int -> Int + -- kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0 + -- then 78 + -- else 5 + -- + -- I have seen a case alternative like this: + -- True -> \v -> ... + -- It's a bit silly to add the realWorld dummy arg in this case, making + -- $j = \s v -> ... + -- True -> $j s + -- (the \v alone is enough to make CPR happy) but I think it's rare + + ( if null used_bndrs' + then newId FSLIT("w") realWorldStatePrimTy `thenSmpl` \ rw_id -> + returnSmpl ([rw_id], [Var realWorldPrimId]) + else + returnSmpl (used_bndrs', map varToCoreExpr used_bndrs') + ) `thenSmpl` \ (final_bndrs', final_args) -> + + -- See comment about "$j" name above + newId (encodeFS 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 + really_final_bndrs = map one_shot final_bndrs' + one_shot v | isId v = setOneShotLambda v + | otherwise = v + join_rhs = mkLams really_final_bndrs rhs' + join_call = mkApps (Var join_bndr) final_args + in + returnSmpl (unitFloat env join_bndr join_rhs, (con, bndrs', join_call)) \end{code} -