X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplify.lhs;h=9f0c1a36e8b7ff49b3ea5debb3ed65df6a2c5a81;hb=cbf5bb17365e9228f3f724b87f958982c4b66cba;hp=f4eef9f930460dc01cb93c0f3edba9072b8b6b6d;hpb=63592052b4746774966913134a298ff31298ac37;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index f4eef9f..9f0c1a3 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -1,1386 +1,1587 @@ % -% (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} -module Simplify ( simplTopBinds, simplExpr, simplBind ) where +module Simplify ( simplTopBinds, simplExpr ) where #include "HsVersions.h" -import BinderInfo -import CmdLineOpts ( SimplifierSwitch(..) ) -import ConFold ( completePrim ) -import CoreUnfold ( Unfolding, mkFormSummary, - exprIsTrivial, whnfOrBottom, inlineUnconditionally, - FormSummary(..) +import CmdLineOpts ( switchIsOn, opt_SimplDoEtaReduction, + opt_SimplNoPreInlining, + SimplifierSwitch(..) + ) +import SimplMonad +import SimplUtils ( mkCase, transformRhs, findAlt, + simplBinder, simplBinders, simplIds, findDefault, + SimplCont(..), DupFlag(..), mkStop, mkRhsStop, + contResultType, discardInline, countArgs, contIsDupable, + getContArgs, interestingCallContext, interestingArg, isStrictType + ) +import Var ( mkSysTyVar, tyVarKind ) +import VarEnv +import VarSet ( elemVarSet ) +import Id ( Id, idType, idInfo, isDataConId, + idUnfolding, setIdUnfolding, isExportedId, isDeadBinder, + idDemandInfo, setIdInfo, + idOccInfo, setIdOccInfo, + zapLamIdInfo, setOneShotLambda, + ) +import IdInfo ( OccInfo(..), isDeadOcc, isLoopBreaker, + setArityInfo, unknownArity, + setUnfoldingInfo, + occInfo + ) +import Demand ( isStrict ) +import DataCon ( dataConNumInstArgs, dataConRepStrictness, + dataConSig, dataConArgTys ) -import CostCentre ( isSccCountCostCentre, cmpCostCentre, costsAreSubsumed, useCurrentCostCentre ) import CoreSyn -import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp, - unTagBinders, squashableDictishCcExpr +import CoreFVs ( mustHaveLocalBinding, exprFreeVars ) +import CoreUnfold ( mkOtherCon, mkUnfolding, otherCons, + callSiteInline ) -import Id ( idType, idMustBeINLINEd, idWantsToBeINLINEd, idMustNotBeINLINEd, - addIdArity, getIdArity, - getIdDemandInfo, addIdDemandInfo +import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsTrivial, + exprIsConApp_maybe, mkPiType, + exprType, coreAltsType, exprIsValue, idAppIsCheap, + exprOkForSpeculation, + mkCoerce, mkSCC, mkInlineMe, mkAltExpr ) -import Name ( isExported, isLocallyDefined ) -import IdInfo ( willBeDemanded, noDemandInfo, DemandInfo, ArityInfo(..), - atLeastArity, unknownArity ) -import Literal ( isNoRepLit ) -import Maybes ( maybeToBool ) -import PrimOp ( primOpOkForSpeculation, PrimOp(..) ) -import SimplCase ( simplCase, bindLargeRhs ) -import SimplEnv -import SimplMonad -import SimplVar ( completeVar, simplBinder, simplBinders, simplTyBinder, simplTyBinders ) -import SimplUtils -import Type ( mkTyVarTy, mkTyVarTys, mkAppTy, applyTy, applyTys, - mkFunTys, splitAlgTyConApp_maybe, - splitFunTys, splitFunTy_maybe, isUnpointedType +import Rules ( lookupRule ) +import CostCentre ( currentCCS ) +import Type ( mkTyVarTys, isUnLiftedType, seqType, + mkFunTy, splitTyConApp_maybe, tyConAppArgs, + funResultTy ) -import TysPrim ( realWorldStatePrimTy ) -import Util ( Eager, appEager, returnEager, runEager, mapEager, - isSingleton, zipEqual, zipWithEqual, mapAndUnzip +import Subst ( mkSubst, substTy, + isInScope, lookupIdSubst, substIdInfo ) -import Outputable +import TyCon ( isDataTyCon, tyConDataConsIfAvailable ) +import TysPrim ( realWorldStatePrimTy ) +import PrelInfo ( realWorldPrimId ) +import Maybes ( maybeToBool ) +import Util ( zipWithEqual ) +import Outputable \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. -What about imports? They don't really matter much because we only -inline relatively small things via imports. -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. %************************************************************************ %* * -\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 :: [InBind] -> SimplM [OutBind] + +simplTopBinds binds + = -- Put all the top-level binders into scope at the start + -- so that if a transformation rule has unexpectedly brought + -- anything into scope, then we don't get a complaint about that. + -- It's rather as if the top-level binders were imported. + simplIds (bindersOfBinds binds) $ \ bndrs' -> + simpl_binds binds bndrs' `thenSmpl` \ (binds', _) -> + freeTick SimplifierDone `thenSmpl_` + returnSmpl binds' + where -simplTopBinds env binds - = mapSmpl (floatBind env True) binds `thenSmpl` \ binds_s -> - simpl_top_binds env (concat binds_s) + -- We need to track the zapped top-level binders, because + -- they should have their fragile IdInfo zapped (notably occurrence info) + simpl_binds [] bs = ASSERT( null bs ) returnSmpl ([], panic "simplTopBinds corner") + simpl_binds (NonRec bndr rhs : binds) (b:bs) = simplLazyBind True bndr b rhs (simpl_binds binds bs) + simpl_binds (Rec pairs : binds) bs = simplRecBind True pairs (take n bs) (simpl_binds binds (drop n bs)) + where + n = length pairs + +simplRecBind :: Bool -> [(InId, InExpr)] -> [OutId] + -> SimplM (OutStuff a) -> SimplM (OutStuff a) +simplRecBind top_lvl pairs bndrs' thing_inside + = go pairs bndrs' `thenSmpl` \ (binds', (binds'', res)) -> + returnSmpl (Rec (flattenBinds binds') : binds'', res) where - simpl_top_binds env [] = returnSmpl [] - - simpl_top_binds env (NonRec binder@(in_id,occ_info) rhs : binds) - = --- No cloning necessary at top level - simplBinder env binder `thenSmpl` \ (env1, out_id) -> - simplRhsExpr env binder rhs out_id `thenSmpl` \ (rhs',arity) -> - completeNonRec env1 binder (out_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. - simplBinders env (map fst pairs) `thenSmpl` \ (env1, out_ids) -> - simplRecursiveGroup env1 out_ids pairs `thenSmpl` \ (bind', new_env) -> - simpl_top_binds new_env binds `thenSmpl` \ binds' -> - returnSmpl (Rec bind' : binds') + go [] _ = thing_inside `thenSmpl` \ stuff -> + returnSmpl ([], stuff) + + go ((bndr, rhs) : pairs) (bndr' : bndrs') + = simplLazyBind top_lvl bndr bndr' rhs (go pairs bndrs') + -- Don't float unboxed bindings out, + -- because we can't "rec" them \end{code} + %************************************************************************ %* * \subsection[Simplify-simplExpr]{The main function: simplExpr} %* * %************************************************************************ +The reason for this OutExprStuff stuff is that we want to float *after* +simplifying a RHS, not before. If we do so naively we get quadratic +behaviour as things float out. -\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. - +To see why it's important to do it after, consider this (real) example: -Variables -~~~~~~~~~ -Check if there's a macro-expansion, and if so rattle on. Otherwise do -the more sophisticated stuff. - -\begin{code} -simplExpr env (Var var) args result_ty - = case lookupIdSubst env var of - - Just (SubstExpr ty_subst id_subst expr) - -> simplExpr (setSubstEnvs env ty_subst id_subst) expr args result_ty + 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 - Just (SubstLit lit) -- A boring old literal - -> ASSERT( null args ) - returnSmpl (Lit lit) +Each of the ==> steps is a round of simplification. We'd save a +whole round if we float first. This can cascade. Consider - Just (SubstVar var') -- More interesting! An id! - -> completeVar env var' args result_ty + 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)... - Nothing -- Not in the substitution; hand off to completeVar - -> completeVar env var args result_ty -\end{code} +Only in this second round can the \y be applied, and it +might do the same again. -Literals -~~~~~~~~ \begin{code} -simplExpr env (Lit l) [] result_ty = returnSmpl (Lit l) -#ifdef DEBUG -simplExpr env (Lit l) _ _ = panic "simplExpr:Lit with argument" -#endif +simplExpr :: CoreExpr -> SimplM CoreExpr +simplExpr expr = getSubst `thenSmpl` \ subst -> + simplExprC expr (mkStop (substTy subst (exprType expr))) + -- The type in the Stop continuation is usually not used + -- It's only needed when discarding continuations after finding + -- a function that returns bottom. + -- Hence the lazy substitution + +simplExprC :: CoreExpr -> SimplCont -> SimplM CoreExpr + -- Simplify an expression, given a continuation + +simplExprC expr cont = simplExprF expr cont `thenSmpl` \ (floats, (_, body)) -> + returnSmpl (mkLets floats body) + +simplExprF :: InExpr -> SimplCont -> SimplM OutExprStuff + -- Simplify an expression, returning floated binds + +simplExprF (Var v) cont + = simplVar v cont + +simplExprF (Lit lit) (Select _ bndr alts se cont) + = knownCon (Lit lit) (LitAlt lit) [] bndr alts se cont + +simplExprF (Lit lit) cont + = rebuild (Lit lit) cont + +simplExprF (App fun arg) cont + = getSubstEnv `thenSmpl` \ se -> + simplExprF fun (ApplyTo NoDup arg se cont) + +simplExprF (Case scrut bndr alts) cont + = getSubstEnv `thenSmpl` \ subst_env -> + getSwitchChecker `thenSmpl` \ chkr -> + if not (switchIsOn chkr NoCaseOfCase) then + -- Simplify the scrutinee with a Select continuation + simplExprF scrut (Select NoDup bndr alts subst_env cont) + + else + -- If case-of-case is off, simply simplify the case expression + -- in a vanilla Stop context, and rebuild the result around it + simplExprC scrut (Select NoDup bndr alts subst_env + (mkStop (contResultType cont))) `thenSmpl` \ case_expr' -> + rebuild case_expr' cont + + +simplExprF (Let (Rec pairs) body) cont + = simplIds (map fst pairs) $ \ bndrs' -> + -- NB: bndrs' don't have unfoldings or spec-envs + -- We add them as we go down, using simplPrags + + simplRecBind False pairs bndrs' (simplExprF body cont) + +simplExprF expr@(Lam _ _) cont = simplLam expr cont + +simplExprF (Type ty) cont + = ASSERT( case cont of { Stop _ _ -> True; ArgOf _ _ _ -> True; other -> False } ) + simplType ty `thenSmpl` \ ty' -> + rebuild (Type ty') cont + +-- Comments about the Coerce case +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- It's worth checking for a coerce in the continuation, +-- in case we can cancel them. 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 + +simplExprF (Note (Coerce to from) e) (CoerceIt outer_to cont) + = simplType from `thenSmpl` \ from' -> + if outer_to == from' then + -- The coerces cancel out + simplExprF e cont + else + -- They don't cancel, but the inner one is redundant + simplExprF e (CoerceIt outer_to cont) + +simplExprF (Note (Coerce to from) e) cont + = simplType to `thenSmpl` \ to' -> + simplExprF e (CoerceIt to' cont) + +-- hack: we only distinguish subsumed cost centre stacks for the purposes of +-- inlining. All other CCCSs are mapped to currentCCS. +simplExprF (Note (SCC cc) e) cont + = setEnclosingCC currentCCS $ + simplExpr e `thenSmpl` \ e -> + rebuild (mkSCC cc e) cont + +simplExprF (Note InlineCall e) cont + = simplExprF e (InlinePlease cont) + +-- Comments about the InlineMe case +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Don't inline in the RHS of something that has an +-- inline pragma. But be careful that the InScopeEnv that +-- we return does still have inlinings on! +-- +-- It really is important to switch off inlinings. This function +-- may be inlinined in other modules, so we don't want to remove +-- (by inlining) calls to functions that have specialisations, or +-- that may have transformation rules in an importing scope. +-- E.g. {-# INLINE f #-} +-- f x = ...g... +-- and suppose that g is strict *and* has specialisations. +-- If we inline g's wrapper, we deny f the chance of getting +-- the specialised version of g when f is inlined at some call site +-- (perhaps in some other module). + +simplExprF (Note InlineMe e) cont + = case cont of + Stop _ _ -> -- Totally boring continuation + -- Don't inline inside an INLINE expression + setBlackList noInlineBlackList (simplExpr e) `thenSmpl` \ e' -> + rebuild (mkInlineMe e') cont + + other -> -- Dissolve the InlineMe note if there's + -- an interesting context of any kind to combine with + -- (even a type application -- anything except Stop) + simplExprF e cont + +-- A non-recursive let is dealt with by simplBeta +simplExprF (Let (NonRec bndr rhs) body) cont + = getSubstEnv `thenSmpl` \ se -> + simplBeta bndr rhs se (contResultType cont) $ + simplExprF body cont \end{code} -Primitive applications are simple. -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -NB: Prim expects an empty argument list! (Because it should be -saturated and not higher-order. ADR) +--------------------------------- \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' +simplLam fun cont + = go fun cont where - -- PrimOps just need any types in them renamed. - - 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') + zap_it = mkLamBndrZapper fun cont + cont_ty = contResultType cont + + -- Type-beta reduction + go (Lam bndr body) (ApplyTo _ (Type ty_arg) arg_se body_cont) + = ASSERT( isTyVar bndr ) + tick (BetaReduction bndr) `thenSmpl_` + simplTyArg ty_arg arg_se `thenSmpl` \ ty_arg' -> + extendSubst bndr (DoneTy ty_arg') + (go body body_cont) + + -- Ordinary beta reduction + go (Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont) + = tick (BetaReduction bndr) `thenSmpl_` + simplBeta zapped_bndr arg arg_se cont_ty + (go body body_cont) + where + zapped_bndr = zap_it bndr - simpl_op other_op = returnEager other_op -\end{code} + -- Not enough args + go lam@(Lam _ _) cont = completeLam [] lam cont -Constructor applications -~~~~~~~~~~~~~~~~~~~~~~~~ -Nothing to try here. We only reuse constructors when they appear as the -rhs of a let binding (see completeLetBinding). + -- Exactly enough args + go expr cont = simplExprF expr cont -\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') -\end{code} +-- completeLam deals with the case where a lambda doesn't have an ApplyTo +-- continuation, so there are real lambdas left to put in the result +-- We try for eta reduction here, but *only* if we get all the +-- way to an exprIsTrivial expression. +-- We don't want to remove extra lambdas unless we are going +-- to avoid allocating this thing altogether -Applications are easy too: -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Just stuff 'em in the arg stack - -\begin{code} -simplExpr env (App fun arg) args result_ty - = simplArg env arg `appEager` \ arg' -> - simplExpr env fun (arg' : args) result_ty -\end{code} +completeLam rev_bndrs (Lam bndr body) cont + = simplBinder bndr $ \ bndr' -> + completeLam (bndr':rev_bndrs) body cont -Type lambdas -~~~~~~~~~~~~ +completeLam rev_bndrs body cont + = simplExpr body `thenSmpl` \ body' -> + case try_eta body' of + Just etad_lam -> tick (EtaReduction (head rev_bndrs)) `thenSmpl_` + rebuild etad_lam cont -First the case when it's applied to an argument. + Nothing -> rebuild (foldl (flip Lam) body' rev_bndrs) cont + where + -- We don't use CoreUtils.etaReduce, because we can be more + -- efficient here: (a) we already have the binders, (b) we can do + -- the triviality test before computing the free vars + try_eta body | not opt_SimplDoEtaReduction = Nothing + | otherwise = go rev_bndrs body + + go (b : bs) (App fun arg) | ok_arg b arg = go bs fun -- Loop round + go [] body | ok_body body = Just body -- Success! + go _ _ = Nothing -- Failure! + + ok_body body = exprIsTrivial body && not (any (`elemVarSet` exprFreeVars body) rev_bndrs) + ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg + +mkLamBndrZapper :: CoreExpr -- Function + -> SimplCont -- The context + -> Id -> Id -- Use this to zap the binders +mkLamBndrZapper fun cont + | n_args >= n_params fun = \b -> b -- Enough args + | otherwise = \b -> zapLamIdInfo b + where + -- NB: we count all the args incl type args + -- so we must count all the binders (incl type lambdas) + n_args = countArgs cont -\begin{code} -simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args) result_ty - = tick TyBetaReduction `thenSmpl_` - simplExpr (bindTyVar env tyvar ty) body args result_ty + n_params (Note _ e) = n_params e + n_params (Lam b e) = 1 + n_params e + n_params other = 0::Int \end{code} + +--------------------------------- \begin{code} -simplExpr env tylam@(Lam (TyBinder tyvar) body) [] result_ty - = simplTyBinder env tyvar `thenSmpl` \ (new_env, tyvar') -> +simplType :: InType -> SimplM OutType +simplType ty + = getSubst `thenSmpl` \ subst -> let - new_result_ty = applyTy result_ty (mkTyVarTy tyvar') + new_ty = substTy subst ty in - simplExpr new_env body [] new_result_ty `thenSmpl` \ body' -> - returnSmpl (Lam (TyBinder tyvar') body') - -#ifdef DEBUG -simplExpr env (Lam (TyBinder _) _) (_ : _) result_ty - = panic "simplExpr:TyLam with non-TyArg" -#endif + seqType new_ty `seq` + returnSmpl new_ty \end{code} -Ordinary lambdas -~~~~~~~~~~~~~~~~ - -There's a complication with lambdas that aren't saturated. -Suppose we have: +%************************************************************************ +%* * +\subsection{Binding} +%* * +%************************************************************************ - (\x. \y. ...x...) +@simplBeta@ is used for non-recursive lets in expressions, +as well as true beta reduction. -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. +Very similar to @simplLazyBind@, but not quite the same. \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) (bindIdToAtom 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 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} +simplBeta :: InId -- Binder + -> InExpr -> SubstEnv -- Arg, with its subst-env + -> OutType -- Type of thing computed by the context + -> SimplM OutExprStuff -- The body + -> SimplM OutExprStuff +#ifdef DEBUG +simplBeta bndr rhs rhs_se cont_ty thing_inside + | isTyVar bndr + = pprPanic "simplBeta" (ppr bndr <+> ppr rhs) +#endif +simplBeta bndr rhs rhs_se cont_ty thing_inside + | preInlineUnconditionally False {- not black listed -} bndr + = tick (PreInlineUnconditionally bndr) `thenSmpl_` + extendSubst bndr (ContEx rhs_se rhs) thing_inside -Let expressions -~~~~~~~~~~~~~~~ + | otherwise + = -- Simplify the RHS + simplBinder bndr $ \ bndr' -> + let + bndr_ty' = idType bndr' + is_strict = isStrict (idDemandInfo bndr) || isStrictType bndr_ty' + in + simplValArg bndr_ty' is_strict rhs rhs_se cont_ty $ \ rhs' -> -\begin{code} -simplExpr env (Let bind body) args result_ty - = simplBind env bind (\env -> simplExpr env body args result_ty) result_ty + -- Now complete the binding and simplify the body + if needsCaseBinding bndr_ty' rhs' then + addCaseBind bndr' rhs' thing_inside + else + completeBinding bndr bndr' False False rhs' thing_inside \end{code} -Case expressions -~~~~~~~~~~~~~~~~ \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 +simplTyArg :: InType -> SubstEnv -> SimplM OutType +simplTyArg ty_arg se + = getInScope `thenSmpl` \ in_scope -> + let + ty_arg' = substTy (mkSubst in_scope se) ty_arg + in + seqType ty_arg' `seq` + returnSmpl ty_arg' + +simplValArg :: OutType -- rhs_ty: Type of arg; used only occasionally + -> Bool -- True <=> evaluate eagerly + -> InExpr -> SubstEnv + -> OutType -- cont_ty: Type of thing computed by the context + -> (OutExpr -> SimplM OutExprStuff) + -- Takes an expression of type rhs_ty, + -- returns an expression of type cont_ty + -> SimplM OutExprStuff -- An expression of type cont_ty + +simplValArg arg_ty is_strict arg arg_se cont_ty thing_inside + | is_strict + = getEnv `thenSmpl` \ env -> + setSubstEnv arg_se $ + simplExprF arg (ArgOf NoDup cont_ty $ \ rhs' -> + setAllExceptInScope env $ + thing_inside rhs') + + | otherwise + = simplRhs False {- Not top level -} + True {- OK to float unboxed -} + arg_ty arg arg_se + thing_inside \end{code} -Coercions -~~~~~~~~~ -\begin{code} -simplExpr env (Coerce coercion ty body) args result_ty - = simplCoerce env coercion ty body args result_ty -\end{code} +completeBinding + - deals only with Ids, not TyVars + - take an already-simplified RHS +It does *not* attempt to do let-to-case. Why? Because they are used for -Set-cost-centre -~~~~~~~~~~~~~~~ + - top-level bindings + (when let-to-case is impossible) -1) Eliminating nested sccs ... -We must be careful to maintain the scc counts ... + - many situations where the "rhs" is known to be a WHNF + (so let-to-case is inappropriate). \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} +completeBinding :: InId -- Binder + -> OutId -- New binder + -> Bool -- True <=> top level + -> Bool -- True <=> black-listed; don't inline + -> OutExpr -- Simplified RHS + -> SimplM (OutStuff a) -- Thing inside + -> SimplM (OutStuff a) + +completeBinding old_bndr new_bndr top_lvl black_listed new_rhs thing_inside + | isDeadOcc occ_info -- This happens; for example, the case_bndr during case of + -- known constructor: case (a,b) of x { (p,q) -> ... } + -- Here x isn't mentioned in the RHS, so we don't want to + -- create the (dead) let-binding let x = (a,b) in ... + = thing_inside + + | exprIsTrivial new_rhs + -- We're looking at a binding with a trivial RHS, so + -- perhaps we can discard it altogether! + -- + -- NB: a loop breaker never has postInlineUnconditionally True + -- and non-loop-breakers only have *forward* references + -- Hence, it's safe to discard the binding + -- + -- NOTE: This isn't our last opportunity to inline. + -- We're at the binding site right now, and + -- we'll get another opportunity when we get to the ocurrence(s) + + -- Note that we do this unconditional inlining only for trival RHSs. + -- Don't inline even WHNFs inside lambdas; doing so may + -- simply increase allocation when the function is called + -- This isn't the last chance; see NOTE above. + -- + -- NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here + -- Why? Because we don't even want to inline them into the + -- RHS of constructor arguments. See NOTE above + -- + -- NB: Even NOINLINEis ignored here: if the rhs is trivial + -- it's best to inline it anyway. We often get a=E; b=a + -- from desugaring, with both a and b marked NOINLINE. + = if must_keep_binding then -- Keep the binding + finally_bind_it unknownArity new_rhs + -- Arity doesn't really matter because for a trivial RHS + -- we will inline like crazy at call sites + -- If this turns out be false, we can easily compute arity + else -- Drop the binding + extendSubst 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 + tick (PostInlineUnconditionally old_bndr) `thenSmpl_` + thing_inside + + | Note coercion@(Coerce _ inner_ty) inner_rhs <- new_rhs + -- [NB inner_rhs is guaranteed non-trivial by now] + -- x = coerce t e ==> c = e; x = inline_me (coerce t c) + -- Now x can get inlined, which moves the coercion + -- to the usage site. This is a bit like worker/wrapper stuff, + -- but it's useful to do it very promptly, so that + -- x = coerce T (I# 3) + -- get's w/wd to + -- c = I# 3 + -- x = coerce T c + -- This in turn means that + -- case (coerce Int x) of ... + -- will inline x. + -- Also the full-blown w/w thing isn't set up for non-functions + -- + -- The inline_me note is so that the simplifier doesn't + -- just substitute c back inside x's rhs! (Typically, x will + -- get substituted away, but not if it's exported.) + = newId SLIT("c") inner_ty $ \ c_id -> + completeBinding c_id c_id top_lvl False inner_rhs $ + completeBinding old_bndr new_bndr top_lvl black_listed + (Note InlineMe (Note coercion (Var c_id))) $ + thing_inside -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} -3) Eliminating dict sccs ... + | otherwise + = transformRhs new_rhs finally_bind_it -\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} + where + old_info = idInfo old_bndr + occ_info = occInfo old_info + loop_breaker = isLoopBreaker occ_info + must_keep_binding = black_listed || loop_breaker || isExportedId old_bndr + + finally_bind_it arity_info new_rhs + = getSubst `thenSmpl` \ subst -> + let + -- We make new IdInfo for the new binder by starting from the old binder, + -- doing appropriate substitutions. + -- Then we add arity and unfolding info to get the new binder + new_bndr_info = substIdInfo subst old_info (idInfo new_bndr) + `setArityInfo` arity_info + + -- 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` mkUnfolding 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` + addLetBind (NonRec final_id new_rhs) $ + modifyInScope new_bndr final_id thing_inside +\end{code} -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) -\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') -\end{code} %************************************************************************ %* * -\subsection{Simplify RHS of a Let/Letrec} +\subsection{simplLazyBind} %* * %************************************************************************ -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 +simplLazyBind basically just simplifies the RHS of a let(rec). +It does two important optimisations though: - /\tyvars -> \a1 ... an b(n+1) ... bk -> (e b(n+1) ... bk) + * It floats let(rec)s out of the RHS, even if they + are hidden by big lambdas -This is a Very Good Thing! + * It does eta expansion \begin{code} -simplRhsExpr - :: SimplEnv - -> InBinder - -> InExpr - -> OutId -- The new binder (used only for its type) - -> SmplM (OutExpr, ArityInfo) +simplLazyBind :: Bool -- True <=> top level + -> InId -> OutId + -> InExpr -- The RHS + -> SimplM (OutStuff a) -- The body of the binding + -> SimplM (OutStuff a) +-- When called, the subst env is correct for the entire let-binding +-- and hence right for the RHS. +-- Also the binder has already been simplified, and hence is in scope + +simplLazyBind top_lvl bndr bndr' rhs thing_inside + = getBlackList `thenSmpl` \ black_list_fn -> + let + black_listed = black_list_fn bndr + in + + if preInlineUnconditionally black_listed bndr then + -- Inline unconditionally + tick (PreInlineUnconditionally bndr) `thenSmpl_` + getSubstEnv `thenSmpl` \ rhs_se -> + (extendSubst bndr (ContEx rhs_se rhs) thing_inside) + else + + -- Simplify the RHS + getSubstEnv `thenSmpl` \ rhs_se -> + simplRhs top_lvl False {- Not ok to float unboxed (conservative) -} + (idType bndr') + rhs rhs_se $ \ rhs' -> + + -- Now compete the binding and simplify the body + completeBinding bndr bndr' top_lvl black_listed rhs' thing_inside \end{code} + \begin{code} -simplRhsExpr env binder@(id,occ_info) rhs new_id - | maybeToBool (splitAlgTyConApp_maybe 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 - simplTyBinders env tyvars `thenSmpl` \ (lam_env, tyvars') -> +simplRhs :: Bool -- True <=> Top level + -> Bool -- True <=> OK to float unboxed (speculative) bindings + -- False for (a) recursive and (b) top-level bindings + -> OutType -- Type of RHS; used only occasionally + -> InExpr -> SubstEnv + -> (OutExpr -> SimplM (OutStuff a)) + -> SimplM (OutStuff a) +simplRhs top_lvl float_ubx rhs_ty rhs rhs_se thing_inside + = -- Simplify it + setSubstEnv rhs_se (simplExprF rhs (mkRhsStop rhs_ty)) `thenSmpl` \ (floats, (in_scope', rhs')) -> + + -- Float lets out of RHS let - body_ty = applyTys rhs_ty (mkTyVarTys tyvars') + (floats_out, rhs'') = splitFloats float_ubx floats rhs' 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' -> - - returnSmpl (rhs', arity) + if (top_lvl || wantToExpose 0 rhs') && -- Float lets if (a) we're at the top level + not (null floats_out) -- or (b) the resulting RHS is one we'd like to expose + then + tickLetFloat floats_out `thenSmpl_` + -- Do the float + -- + -- There's a subtlety here. There may be a binding (x* = e) in the + -- floats, where the '*' means 'will be demanded'. So is it safe + -- to float it out? Answer no, but it won't matter because + -- we only float if arg' is a WHNF, + -- and so there can't be any 'will be demanded' bindings in the floats. + -- Hence the assert + WARN( any demanded_float floats_out, ppr floats_out ) + addLetBinds floats_out $ + setInScope in_scope' $ + thing_inside rhs'' + -- in_scope' may be excessive, but that's OK; + -- it's a superset of what's in scope + else + -- Don't do the float + thing_inside (mkLets floats rhs') + +-- In a let-from-let float, we just tick once, arbitrarily +-- choosing the first floated binder to identify it +tickLetFloat (NonRec b r : fs) = tick (LetFloatFromLet b) +tickLetFloat (Rec ((b,r):prs) : fs) = tick (LetFloatFromLet b) + +demanded_float (NonRec b r) = isStrict (idDemandInfo b) && not (isUnLiftedType (idType b)) + -- Unlifted-type (cheap-eagerness) lets may well have a demanded flag on them +demanded_float (Rec _) = False + +-- If float_ubx is true we float all the bindings, otherwise +-- we just float until we come across an unlifted one. +-- Remember that the unlifted bindings in the floats are all for +-- guaranteed-terminating non-exception-raising unlifted things, +-- which we are happy to do speculatively. However, we may still +-- not be able to float them out, because the context +-- is either a Rec group, or the top level, neither of which +-- can tolerate them. +splitFloats float_ubx floats rhs + | float_ubx = (floats, rhs) -- Float them all + | otherwise = go floats 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 - - (tyvars, body) = collectTyBinders rhs + go [] = ([], rhs) + go (f:fs) | must_stay f = ([], mkLets (f:fs) rhs) + | otherwise = case go fs of + (out, rhs') -> (f:out, rhs') + + must_stay (Rec prs) = False -- No unlifted bindings in here + must_stay (NonRec b r) = isUnLiftedType (idType b) + +wantToExpose :: Int -> CoreExpr -> Bool +-- True for expressions that we'd like to expose at the +-- top level of an RHS. This includes partial applications +-- even if the args aren't cheap; the next pass will let-bind the +-- args and eta expand the partial application. So exprIsCheap won't do. +-- Here's the motivating example: +-- z = letrec g = \x y -> ...g... in g E +-- Even though E is a redex we'd like to float the letrec to give +-- g = \x y -> ...g... +-- z = g E +-- Now the next use of SimplUtils.tryEtaExpansion will give +-- g = \x y -> ...g... +-- z = let v = E in \w -> g v w +-- And now we'll float the v to give +-- g = \x y -> ...g... +-- v = E +-- z = \w -> g v w +-- Which is what we want; chances are z will be inlined now. + +wantToExpose n (Var v) = idAppIsCheap v n +wantToExpose n (Lit l) = True +wantToExpose n (Lam _ e) = True +wantToExpose n (Note _ e) = wantToExpose n e +wantToExpose n (App f (Type _)) = wantToExpose n f +wantToExpose n (App f a) = wantToExpose (n+1) f +wantToExpose n other = False -- There won't be any lets \end{code} ----------------------------------------------------------------- - An old special case that is now nuked. -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 (such as strictness) that v doesn't. +%************************************************************************ +%* * +\subsection{Variables} +%* * +%************************************************************************ -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. +\begin{code} +simplVar var cont + = getSubst `thenSmpl` \ subst -> + case lookupIdSubst subst var of + DoneEx e -> zapSubstEnv (simplExprF e cont) + ContEx env1 e -> setSubstEnv env1 (simplExprF e cont) + DoneId var1 occ -> WARN( not (isInScope var1 subst) && mustHaveLocalBinding var1, + text "simplVar:" <+> ppr var ) + zapSubstEnv (completeCall 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 + +completeCall var occ cont + = getBlackList `thenSmpl` \ black_list_fn -> + getInScope `thenSmpl` \ in_scope -> + getContArgs var cont `thenSmpl` \ (args, call_cont, inline_call) -> + getDOptsSmpl `thenSmpl` \ dflags -> + let + black_listed = black_list_fn var + arg_infos = [ interestingArg in_scope arg subst + | (arg, subst, _) <- args, isValArg arg] -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. + interesting_cont = interestingCallContext (not (null args)) + (not (null arg_infos)) + call_cont + inline_cont | inline_call = discardInline cont + | otherwise = cont - HOWEVER + maybe_inline = callSiteInline dflags black_listed inline_call occ + var arg_infos interesting_cont + in + -- First, look for an inlining + case maybe_inline of { + Just unfolding -- There is an inlining! + -> tick (UnfoldingDone var) `thenSmpl_` + simplExprF unfolding inline_cont -This "optimisation" turned out to be a bad idea. If there's are -top-level exported bindings like + ; + Nothing -> -- No inlining! - y = I# 3# - x = y -then y wasn't getting inlined in x's rhs, and we were getting -bad code. So I've removed the special case from here, and -instead we only try eta reduction and constructor reuse -in completeNonRec if the thing is *not* exported. + simplifyArgs (isDataConId var) args (contResultType call_cont) $ \ args' -> + -- Next, look for rules or specialisations that match + -- + -- It's important to simplify the args first, because the rule-matcher + -- doesn't do substitution as it goes. We don't want to use subst_args + -- (defined in the 'where') because that throws away useful occurrence info, + -- and perhaps-very-important specialisations. + -- + -- Some functions have specialisations *and* are strict; in this case, + -- we don't want to inline the wrapper of the non-specialised thing; better + -- to call the specialised thing instead. + -- But the black-listing mechanism means that inlining of the wrapper + -- won't occur for things that have specialisations till a later phase, so + -- it's ok to try for inlining first. + + getSwitchChecker `thenSmpl` \ chkr -> + let + maybe_rule | switchIsOn chkr DontApplyRules = Nothing + | otherwise = lookupRule in_scope var args' + in + case maybe_rule of { + Just (rule_name, rule_rhs) -> + tick (RuleFired rule_name) `thenSmpl_` + simplExprF rule_rhs call_cont ; + + Nothing -> -- No rules + + -- Done + rebuild (mkApps (Var var) args') call_cont + }} + + +--------------------------------------------------------- +-- Simplifying the arguments of a call + +simplifyArgs :: Bool -- It's a data constructor + -> [(InExpr, SubstEnv, Bool)] -- Details of the arguments + -> OutType -- Type of the continuation + -> ([OutExpr] -> SimplM OutExprStuff) + -> SimplM OutExprStuff + +-- 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 is_data_con args cont_ty thing_inside + | not is_data_con + = go args thing_inside + + | otherwise -- It's a data constructor, so we want + -- to switch off inlining in the arguments + -- If we don't do this, consider: + -- let x = +# p q in C {x} + -- Even though x get's an occurrence of 'many', its RHS looks cheap, + -- and there's a good chance it'll get inlined back into C's RHS. Urgh! + = getBlackList `thenSmpl` \ old_bl -> + setBlackList noInlineBlackList $ + go args $ \ args' -> + setBlackList old_bl $ + thing_inside args' -\begin{pseudocode} -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 + where + go [] thing_inside = thing_inside [] + go (arg:args) thing_inside = simplifyArg is_data_con arg cont_ty $ \ arg' -> + go args $ \ args' -> + thing_inside (arg':args') - Just the_var = maybe_stop_at_var +simplifyArg is_data_con (Type ty_arg, se, _) cont_ty thing_inside + = simplTyArg ty_arg se `thenSmpl` \ new_ty_arg -> + thing_inside (Type new_ty_arg) - must_unfold v' = idMustBeINLINEd v' - || case lookupOutIdEnv env v' of - Just (_, _, InUnfolding _ _) -> True - other -> False -\end{pseudocode} +simplifyArg is_data_con (val_arg, se, is_strict) cont_ty thing_inside + = getInScope `thenSmpl` \ in_scope -> + let + arg_ty = substTy (mkSubst in_scope se) (exprType val_arg) + in + if not is_data_con then + -- An ordinary function + simplValArg arg_ty is_strict val_arg se cont_ty thing_inside + else + -- A data constructor + -- simplifyArgs has already switched off inlining, so + -- all we have to do here is to let-bind any non-trivial argument + + -- It's not always the case that new_arg will be trivial + -- Consider f x + -- where, in one pass, f gets substituted by a constructor, + -- but x gets substituted by an expression (assume this is the + -- unique occurrence of x). It doesn't really matter -- it'll get + -- fixed up next pass. And it happens for dictionary construction, + -- which mentions the wrapper constructor to start with. + simplValArg arg_ty is_strict val_arg se cont_ty $ \ arg' -> - End of old, nuked, special case. ------------------------------------------------------------------- + if exprIsTrivial arg' then + thing_inside arg' + else + newId SLIT("a") (exprType arg') $ \ arg_id -> + addNonRecBind arg_id arg' $ + thing_inside (Var arg_id) +\end{code} %************************************************************************ %* * -\subsection{Simplify a lambda abstraction} +\subsection{Decisions about inlining} %* * %************************************************************************ -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 - -- - -- The original RHS is "trivial" (exprIsTrivial), because it generates - -- no code (renames f to g). But the new RHS isn't. - - null potential_extra_binder_tys || -- or ain't a function - no_of_extra_binders <= 0 -- or no extra binders needed - = simplBinders env binders `thenSmpl` \ (new_env, binders') -> - 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 expr, - ppr expr_ty, - ppr binders, - int no_of_extra_binders, - ppr potential_extra_binder_tys]) - else \x -> x) $ - - tick EtaExpansion `thenSmpl_` - simplBinders env binders `thenSmpl` \ (new_env, binders') -> - 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 - ) +NB: At one time I tried not pre/post-inlining top-level things, +even if they occur exactly once. Reason: + (a) some might appear as a function argument, so we simply + replace static allocation with dynamic allocation: + l = <...> + x = f l + becomes + x = f <...> - where - (binders,body) = collectValBinders expr - no_of_binders = length binders - (arg_tys, res_ty) = splitFunTys expr_ty - potential_extra_binder_tys = (if not (no_of_binders <= length arg_tys) then - pprTrace "simplValLam" (vcat [ppr expr, - ppr expr_ty, - ppr 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 == realWorldStatePrimTy -> 1 - other -> 0 -\end{code} + (b) some top level things might be black listed +HOWEVER, I found that some useful foldr/build fusion was lost (most +notably in spectral/hartel/parstof) because the foldr didn't see the build. - -%************************************************************************ -%* * -\subsection[Simplify-coerce]{Coerce expressions} -%* * -%************************************************************************ +Doing the dynamic allocation isn't a big deal, in fact, but losing the +fusion can be. \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) - 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 +preInlineUnconditionally :: Bool {- Black listed -} -> InId -> Bool + -- Examines a bndr to see if it is used just once in a + -- completely safe way, so that it is safe to discard the binding + -- inline its RHS at the (unique) usage site, REGARDLESS of how + -- big the RHS might be. If this is the case we don't simplify + -- the RHS first, but just inline it un-simplified. + -- + -- This is much better than first simplifying a perhaps-huge RHS + -- and then inlining and re-simplifying it. + -- + -- NB: we don't even look at the RHS to see if it's trivial + -- We might have + -- x = y + -- where x is used many times, but this is the unique occurrence + -- of y. We should NOT inline x at all its uses, because then + -- we'd do the same for y -- aargh! So we must base this + -- pre-rhs-simplification decision solely on x's occurrences, not + -- on its rhs. + -- + -- Evne RHSs labelled InlineMe aren't caught here, because + -- there might be no benefit from inlining at the call site. + +preInlineUnconditionally black_listed bndr + | black_listed || opt_SimplNoPreInlining = False + | otherwise = case idOccInfo bndr of + OneOcc in_lam once -> not in_lam && once + -- Not inside a lambda, one occurrence ==> safe! + other -> False \end{code} -%************************************************************************ -%* * -\subsection[Simplify-bind]{Binding groups} -%* * -%************************************************************************ - -\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 -\end{code} - %************************************************************************ %* * -\subsection[Simplify-let]{Let-expressions} +\subsection{The main rebuilder} %* * %************************************************************************ -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 - - -Floating case from let -~~~~~~~~~~~~~~~~~~~~~~ -When floating cases out of lets, remember this: - - let x* = case e of alts - in +\begin{code} +------------------------------------------------------------------- +-- Finish rebuilding +rebuild_done expr + = getInScope `thenSmpl` \ in_scope -> + returnSmpl ([], (in_scope, expr)) -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: +--------------------------------------------------------- +rebuild :: OutExpr -> SimplCont -> SimplM OutExprStuff - 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) +-- Stop continuation +rebuild expr (Stop _ _) = rebuild_done expr -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: +-- ArgOf continuation +rebuild expr (ArgOf _ _ cont_fn) = cont_fn expr -==> - 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* +-- ApplyTo continuation +rebuild expr cont@(ApplyTo _ arg se cont') + = setSubstEnv se (simplExpr arg) `thenSmpl` \ arg' -> + rebuild (App expr arg') cont' -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 +-- Coerce continuation +rebuild expr (CoerceIt to_ty cont) + = rebuild (mkCoerce to_ty (exprType expr) expr) cont +-- Inline continuation +rebuild expr (InlinePlease cont) + = rebuild (Note InlineCall expr) cont -Let to case: two points -~~~~~~~~~~~ - -Point 1. We defer let-to-case for all data types except single-constructor -ones. Suppose we change +rebuild scrut (Select _ bndr alts se cont) + = rebuild_case scrut bndr alts se cont +\end{code} - let x* = e in b -to - case e of x -> b +Case elimination [see the code above] +~~~~~~~~~~~~~~~~ +Start with a simple situation: + + case x# of ===> e[x#/y#] + y# -> e + +(when x#, y# are of primitive type, of course). We can't (in general) +do this for algebraic cases, because we might turn bottom into +non-bottom! + +Actually, we generalise this idea to look for a case where we're +scrutinising a variable, and we know that only the default case can +match. For example: +\begin{verbatim} + case x of + 0# -> ... + other -> ...(case x of + 0# -> ... + other -> ...) ... +\end{code} +Here the inner case can be eliminated. This really only shows up in +eliminating error-checking code. -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. +We also make sure that we deal with this very common case: -If x is a single-constructor type, then we go ahead anyway, giving + case e of + x -> ...x... - case e of (y,z) -> let x = (y,z) in b +Here we are using the case as a strict let; if x is used only once +then we want to inline it. We have to be careful that this doesn't +make the program terminate when it would have diverged before, so we +check that + - x is used strictly, or + - e is already evaluated (it may so if e is a variable) -because now we can squash case-on-x wherever they occur in b. +Lastly, we generalise the transformation to handle this: -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. + case e of ===> r + True -> r + False -> r +We only do this for very cheaply compared r's (constructors, literals +and variables). If pedantic bottoms is on, we only do it when the +scrutinee is a PrimOp which can't fail. -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. +We do it *here*, looking at un-simplified alternatives, because we +have to check that r doesn't mention the variables bound by the +pattern in each alternative, so the binder-info is rather useful. - let a*::Int = case v of {p1->e1; p2->e2} - in b +So the case-elimination algorithm is: -(The * means that a is sure to be demanded.) -If we do case-floating first we get this: + 1. Eliminate alternatives which can't match - let k = \a* -> b - in case v of - p1-> let a*=e1 in k a - p2-> let a*=e2 in k a + 2. Check whether all the remaining alternatives + (a) do not mention in their rhs any of the variables bound in their pattern + and (b) have equal rhss -Now watch what happens if we do let-to-case first: + 3. Check we can safely ditch the case: + * PedanticBottoms is off, + or * the scrutinee is an already-evaluated variable + or * the scrutinee is a primop which is ok for speculation + -- ie we want to preserve divide-by-zero errors, and + -- calls to error itself! - 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# + or * [Prim cases] the scrutinee is a primitive variable -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.) + or * [Alg cases] the scrutinee is a variable and + either * the rhs is the same variable + (eg case x of C a b -> x ===> x) + or * there is only one alternative, the default alternative, + and the binder is used strictly in its scope. + [NB this is helped by the "use default binder where + possible" transformation; see below.] -We do not do let to case for WHNFs, e.g. - let x = a:b in ... - =/=> - case a:b of x in ... +If so, then we can replace the case with one of the rhss. -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: - let x = error in ... - ===> - case error of x -> ... - ===> - error +Blob of helper functions for the "case-of-something-else" situation. -Notice that let to case occurs only if x is used strictly in its body -(obviously). +\begin{code} +--------------------------------------------------------- +-- Eliminate the case if possible +rebuild_case scrut bndr alts se cont + | maybeToBool maybe_con_app + = knownCon scrut (DataAlt con) args bndr alts se cont -\begin{code} --- Dead code is now discarded by the occurrence analyser, - -simplNonRec env binder@(id,_) rhs body_c body_ty - | inlineUnconditionally ok_to_dup binder - = -- The binder is used in definitely-inline way in the body - -- So add it to the environment, drop the binding, and continue - body_c (bindIdToExpr env binder rhs) - - | idWantsToBeINLINEd id - = complete_bind env rhs -- Don't mess about with floating or let-to-case on - -- INLINE things - - -- Do let-to-case right away for unpointed types - -- These shouldn't occur much, but do occur right after desugaring, - -- because we havn't done dependency analysis at that point, so - -- we can't trivially do let-to-case (because there may be some unboxed - -- things bound in letrecs that aren't really recursive). - | isUnpointedType rhs_ty && not rhs_is_whnf - = simplCase env rhs (PrimAlts [] (BindDefault binder (Var id))) - (\env rhs -> complete_bind env rhs) body_ty - - -- Try let-to-case; see notes below about let-to-case - | try_let_to_case && - will_be_demanded && - ( rhs_is_bot - || (not rhs_is_whnf && singleConstructorType rhs_ty) - -- Don't do let-to-case if the RHS is a constructor application. - -- Even then only do it 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! + | canEliminateCase scrut bndr alts + = tick (CaseElim bndr) `thenSmpl_` ( + setSubstEnv se $ + simplBinder bndr $ \ bndr' -> + -- Remember to bind the case binder! + completeBinding bndr bndr' False False scrut $ + simplExprF (head (rhssOfAlts alts)) cont) | otherwise - = simpl_bind env rhs - where - -- Try let-from-let - simpl_bind env (Let bind rhs) | let_floating_ok - = tick LetFloatFromLet `thenSmpl_` - simplBind env (if will_be_demanded then bind - else un_demandify_bind 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 - = simplBinder env binder `thenSmpl` \ (env_w_clone, new_id) -> - simplRhsExpr env binder rhs new_id `thenSmpl` \ (rhs',arity) -> - completeNonRec env_w_clone 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 -\end{code} + = complete_case scrut bndr alts se cont + where + maybe_con_app = exprIsConApp_maybe scrut + Just (con, args) = maybe_con_app + + -- See if we can get rid of the case altogether + -- See the extensive notes on case-elimination above +canEliminateCase scrut bndr alts + = -- Check that the RHSs are all the same, and + -- don't use the binders in the alternatives + -- This test succeeds rapidly in the common case of + -- a single DEFAULT alternative + all (cheapEqExpr rhs1) other_rhss && all binders_unused alts + + -- Check that the scrutinee can be let-bound instead of case-bound + && ( exprOkForSpeculation scrut + -- OK not to evaluate it + -- This includes things like (==# a# b#)::Bool + -- so that we simplify + -- case ==# a# b# of { True -> x; False -> x } + -- to just + -- x + -- This particular example shows up in default methods for + -- comparision operations (e.g. in (>=) for Int.Int32) + || exprIsValue scrut -- It's already evaluated + || var_demanded_later scrut -- It'll be demanded later + +-- || not opt_SimplPedanticBottoms) -- Or we don't care! +-- We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on, +-- but that breaks badly for the dataToTag# primop, which relies on a case to evaluate +-- its argument: case x of { y -> dataToTag# y } +-- Here we must *not* discard the case, because dataToTag# just fetches the tag from +-- the info pointer. So we'll be pedantic all the time, and see if that gives any +-- other problems + ) -@completeNonRec@ looks at the simplified post-floating RHS of the -let-expression, with a view to turning - x = e -into - x = y -where y is just a variable. Now we can eliminate the binding -altogether, and replace x by y throughout. - -There are two cases when we can do this: + where + (rhs1:other_rhss) = rhssOfAlts alts + binders_unused (_, bndrs, _) = all isDeadBinder bndrs - * When e is a constructor application, and we have - another variable in scope bound to the same - constructor application. [This is just a special - case of common-subexpression elimination.] + var_demanded_later (Var v) = isStrict (idDemandInfo bndr) -- It's going to be evaluated later + var_demanded_later other = False - * When e can be eta-reduced to a variable. E.g. - x = \a b -> y a b +--------------------------------------------------------- +-- Case of something else -HOWEVER, if x is exported, we don't attempt this at all. Why not? -Because then we can't remove the x=y binding, in which case we -have just made things worse, perhaps a lot worse. +complete_case scrut case_bndr alts se cont + = -- Prepare case alternatives + prepareCaseAlts case_bndr (splitTyConApp_maybe (idType case_bndr)) + impossible_cons alts `thenSmpl` \ better_alts -> + + -- Set the new subst-env in place (before dealing with the case binder) + setSubstEnv se $ -\begin{code} -completeNonRec env binder new_id new_rhs - = returnSmpl (env', [NonRec b r | (b,r) <- binds]) - where - (env', binds) = completeBind env binder new_id new_rhs + -- Deal with the case binder, and prepare the continuation; + -- The new subst_env is in place + prepareCaseCont better_alts cont $ \ cont' -> + + -- Deal with variable scrutinee + ( + getSwitchChecker `thenSmpl` \ chkr -> + simplCaseBinder (switchIsOn chkr NoCaseOfCase) + scrut case_bndr $ \ case_bndr' zap_occ_info -> -completeBind :: SimplEnv - -> InBinder -> OutId -> OutExpr -- Id and RHS - -> (SimplEnv, [(OutId, OutExpr)]) -- Final envt and binding(s) + -- Deal with the case alternatives + simplAlts zap_occ_info impossible_cons + case_bndr' better_alts cont' `thenSmpl` \ alts' -> -completeBind env binder@(_,occ_info) new_id new_rhs - | idMustNotBeINLINEd new_id -- Occurrence analyser says "don't inline" - = (env, new_binds) + mkCase scrut case_bndr' alts' + ) `thenSmpl` \ case_expr -> - | atomic_rhs -- If rhs (after eta reduction) is atomic - && not (isExported new_id) -- and binder isn't exported - = -- Drop the binding completely - let - env1 = notInScope env new_id - env2 = bindIdToAtom env1 binder the_arg - in - (env2, []) - - | atomic_rhs -- Rhs is atomic, and new_id is exported - && case eta'd_rhs of { Var v -> isLocallyDefined v && not (isExported v); other -> False } - = -- The local variable v will be eliminated next time round - -- in favour of new_id, so it's a waste to replace all new_id's with v's - -- this time round. - -- This case is an optional improvement; saves a simplifier iteration - (env, [(new_id, eta'd_rhs)]) - - | otherwise -- Non-atomic - = let - env1 = extendEnvGivenBinding env occ_info new_id new_rhs - in - (env1, new_binds) - + -- Notice that the simplBinder, prepareCaseCont, etc, do *not* scope + -- over the rebuild_done; rebuild_done returns the in-scope set, and + -- that should not include these chaps! + rebuild_done case_expr where - new_binds = [(new_id, new_rhs)] - atomic_rhs = is_atomic eta'd_rhs - eta'd_rhs = case lookForConstructor env new_rhs of - Just v -> Var v - other -> etaCoreExpr new_rhs - - the_arg = case eta'd_rhs of - Var v -> VarArg v - Lit l -> LitArg l + impossible_cons = case scrut of + Var v -> otherCons (idUnfolding v) + other -> [] + + +knownCon :: OutExpr -> AltCon -> [OutExpr] + -> InId -> [InAlt] -> SubstEnv -> SimplCont + -> SimplM OutExprStuff + +knownCon expr con args bndr alts se cont + = tick (KnownBranch bndr) `thenSmpl_` + setSubstEnv se ( + simplBinder bndr $ \ bndr' -> + completeBinding bndr bndr' False False expr $ + -- Don't use completeBeta here. The expr might be + -- an unboxed literal, like 3, or a variable + -- whose unfolding is an unboxed literal... and + -- completeBeta will just construct another case + -- expression! + case findAlt con alts of + (DEFAULT, bs, rhs) -> ASSERT( null bs ) + simplExprF rhs cont + + (LitAlt lit, bs, rhs) -> ASSERT( null bs ) + simplExprF rhs cont + + (DataAlt dc, bs, rhs) -> ASSERT( length bs == length real_args ) + extendSubstList bs (map mk real_args) $ + simplExprF rhs cont + where + real_args = drop (dataConNumInstArgs dc) args + mk (Type ty) = DoneTy ty + mk other = DoneEx other + ) \end{code} ----------------------------------------------------------------------------- - A digression on constructor CSE - -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. - End of digression ----------------------------------------------------------------------------- - ----------------------------------------------------------------------------- - A digression on "optimising" coercions - - The trouble is that we kept 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 -\begin{pseudocode} - -- 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) -> - - returnSmpl (env2, binds1 ++ binds2) -\end{pseudocode} ----------------------------------------------------------------------------- +\begin{code} +prepareCaseCont :: [InAlt] -> SimplCont + -> (SimplCont -> SimplM (OutStuff a)) + -> SimplM (OutStuff a) + -- Polymorphic recursion here! + +prepareCaseCont [alt] cont thing_inside = thing_inside cont +prepareCaseCont alts cont thing_inside = simplType (coreAltsType alts) `thenSmpl` \ alts_ty -> + mkDupableCont alts_ty cont thing_inside + -- At one time I passed in the un-simplified type, and simplified + -- it only if we needed to construct a join binder, but that + -- didn't work because we have to decompse function types + -- (using funResultTy) in mkDupableCont. +\end{code} +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. +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 no_case_of_case argument -%************************************************************************ -%* * -\subsection[Simplify-letrec]{Letrec-expressions} -%* * -%************************************************************************ -Letrec expressions -~~~~~~~~~~~~~~~~~~ -Here's the game plan +If we do this, then we have to nuke any occurrence info (eg IAmDead) +in the case binder, because the case-binder now effectively occurs +whenever v does. AND we have to do the same for the pattern-bound +variables! Example: -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. + (case x of { (a,b) -> a }) (case x of { (p,q) -> q }) -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. +Here, b and p are dead. But when we move the argment inside the first +case RHS, and eliminate the second case, we get + case x or { (a,b) -> a b } -\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 - simplBinders env binders `thenSmpl` \ (env_w_clones, ids') -> - simplRecursiveGroup env_w_clones ids' pairs' `thenSmpl` \ (pairs', new_env) -> - - body_c new_env `thenSmpl` \ body' -> - - returnSmpl (Let (Rec pairs') body') -\end{code} +Urk! b is alive! Reason: the scrutinee was a variable, and case elimination +happened. Hence the zap_occ_info function returned by simplCaseBinder \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, rhs) : pairs) - | inlineUnconditionally ok_to_dup binder - = -- Single occurrence, so drop binding and extend env with the inlining - -- This is a little delicate, because what if the unique occurrence - -- is *before* this binding? This'll never happen, because - -- either it'll be marked "never inline" or else its occurrence will - -- occur after its binding in the group. - -- - -- If these claims aren't right Core Lint will spot an unbound - -- variable. A quick fix is to delete this clause for simplRecursiveGroup - let - new_env = bindIdToExpr env binder rhs - in - simplRecursiveGroup new_env new_ids pairs - - | otherwise - = simplRhsExpr env binder rhs new_id `thenSmpl` \ (new_rhs, arity) -> - let - new_id' = new_id `withArity` arity - (new_env, new_binds') = completeBind env binder new_id' new_rhs - in - simplRecursiveGroup new_env new_ids pairs `thenSmpl` \ (new_pairs, final_env) -> - returnSmpl (new_binds' ++ new_pairs, final_env) +simplCaseBinder no_case_of_case (Var v) case_bndr thing_inside + | not no_case_of_case + = simplBinder (zap case_bndr) $ \ case_bndr' -> + modifyInScope v case_bndr' $ + -- 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. + thing_inside case_bndr' zap where - ok_to_dup = switchIsSet env SimplOkToDupCode + zap b = b `setIdOccInfo` NoOccInfo + +simplCaseBinder add_eval_info other_scrut case_bndr thing_inside + = simplBinder case_bndr $ \ case_bndr' -> + thing_inside case_bndr' (\ bndr -> bndr) -- NoOp on bndr \end{code} +prepareCaseAlts does two things: +1. Remove impossible alternatives -\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' +2. If the DEFAULT alternative can match only one possible constructor, + then make that constructor explicit. + e.g. + case e of x { DEFAULT -> rhs } + ===> + case e of x { (a,b) -> rhs } + where the type is a single constructor type. This gives better code + when rhs also scrutinises x or e. +\begin{code} +prepareCaseAlts bndr (Just (tycon, inst_tys)) scrut_cons alts + | isDataTyCon tycon + = case (findDefault filtered_alts, missing_cons) of + + ((alts_no_deflt, Just rhs), [data_con]) -- Just one missing constructor! + -> tick (FillInCaseDefault bndr) `thenSmpl_` + let + (_,_,ex_tyvars,_,_,_) = dataConSig data_con + in + getUniquesSmpl (length ex_tyvars) `thenSmpl` \ tv_uniqs -> + let + ex_tyvars' = zipWithEqual "simpl_alt" mk tv_uniqs ex_tyvars + mk uniq tv = mkSysTyVar uniq (tyVarKind tv) + arg_tys = dataConArgTys data_con + (inst_tys ++ mkTyVarTys ex_tyvars') + in + newIds SLIT("a") arg_tys $ \ bndrs -> + returnSmpl ((DataAlt data_con, ex_tyvars' ++ bndrs, rhs) : alts_no_deflt) + + other -> returnSmpl filtered_alts where - binds' = fltBind bind - n_extras = sum (map no_of_binds binds') - no_of_binds bind + -- Filter out alternatives that can't possibly match + filtered_alts = case scrut_cons of + [] -> alts + other -> [alt | alt@(con,_,_) <- alts, not (con `elem` scrut_cons)] - float_lets = switchIsSet env SimplFloatLetsExposingWHNF - always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets + missing_cons = [data_con | data_con <- tyConDataConsIfAvailable tycon, + not (data_con `elem` handled_data_cons)] + handled_data_cons = [data_con | DataAlt data_con <- scrut_cons] ++ + [data_con | (DataAlt data_con, _, _) <- filtered_alts] - -- 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 bndr rhs'] - where - (binds, rhs') = fltRhs rhs - - fltBind (Rec pairs) - = [Rec pairs'] - where - pairs' = concat [ let - (binds, rhs') = fltRhs rhs - in - foldr get_pairs [(bndr, rhs')] binds - | (bndr, rhs) <- pairs - ] - - get_pairs (NonRec bndr rhs) rest = (bndr,rhs) : rest - get_pairs (Rec pairs) rest = pairs ++ rest - - -- 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 - binds_wont_leak = all leakFreeBind binds' - (body_binds, body') = fltExpr body - binds' = fltBind (un_demandify_bind bind) - - fltExpr expr = ([], expr) +-- The default case +prepareCaseAlts _ _ scrut_cons alts + = returnSmpl alts -- Functions --- Crude but effective -no_of_binds (NonRec _ _) = 1 -no_of_binds (Rec pairs) = length pairs -leakFreeBind (NonRec bndr rhs) = leakFree bndr rhs -leakFreeBind (Rec pairs) = and [leakFree bndr rhs | (bndr, rhs) <- pairs] - -leakFree (id,_) rhs = case getIdArity id of - ArityAtLeast n | n > 0 -> True - ArityExactly n | n > 0 -> True - other -> whnfOrBottom (mkFormSummary rhs) +---------------------- +simplAlts zap_occ_info scrut_cons case_bndr' alts cont' + = mapSmpl simpl_alt alts + where + inst_tys' = tyConAppArgs (idType case_bndr') + + -- handled_cons is all the constructors that are dealt + -- with, either by being impossible, or by there being an alternative + handled_cons = scrut_cons ++ [con | (con,_,_) <- alts, con /= DEFAULT] + + simpl_alt (DEFAULT, _, rhs) + = -- In the default case we record the constructors that the + -- case-binder *can't* be. + -- We take advantage of any OtherCon info in the case scrutinee + modifyInScope case_bndr' (case_bndr' `setIdUnfolding` mkOtherCon handled_cons) $ + simplExprC rhs cont' `thenSmpl` \ rhs' -> + returnSmpl (DEFAULT, [], rhs') + + simpl_alt (con, vs, rhs) + = -- Deal with the pattern-bound variables + -- Mark the ones that are in ! positions in the data constructor + -- as certainly-evaluated. + -- 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 (add_evals con vs) $ \ vs' -> + + -- Bind the case-binder to (con args) + let + unfolding = mkUnfolding False (mkAltExpr con vs' inst_tys') + in + modifyInScope case_bndr' (case_bndr' `setIdUnfolding` unfolding) $ + simplExprC rhs cont' `thenSmpl` \ rhs' -> + returnSmpl (con, vs', rhs') + + + -- add_evals records the evaluated-ness of the bound variables of + -- a case pattern. This is *important*. Consider + -- data T = T !Int !Int + -- + -- 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) + | isStrict str = (v' `setIdUnfolding` mkOtherCon []) : cat_evals vs strs + | otherwise = v' : cat_evals vs strs + where + v' = zap_occ_info v \end{code} %************************************************************************ %* * -\subsection[Simplify-atoms]{Simplifying atoms} -%* * -%************************************************************************ - -\begin{code} -simplArg :: SimplEnv -> InArg -> Eager ans OutArg - -simplArg env (LitArg lit) = returnEager (LitArg lit) -simplArg env (TyArg ty) = simplTy env ty `appEager` \ ty' -> - returnEager (TyArg ty') -simplArg env arg@(VarArg id) - = case lookupIdSubst env id of - Just (SubstVar id') -> returnEager (VarArg id') - Just (SubstLit lit) -> returnEager (LitArg lit) - Just (SubstExpr _ __) -> panic "simplArg" - Nothing -> case lookupOutIdEnv env id of - Just (id', _, _) -> returnEager (VarArg id') - Nothing -> returnEager arg -\end{code} - -%************************************************************************ -%* * -\subsection[Simplify-quickies]{Some local help functions} +\subsection{Duplicating continuations} %* * %************************************************************************ - \begin{code} --- un_demandify_bind switches off the willBeDemanded Info field --- for bindings floated out of a non-demanded let -un_demandify_bind (NonRec binder rhs) - = NonRec (un_demandify_bndr binder) rhs -un_demandify_bind (Rec pairs) - = Rec [(un_demandify_bndr binder, rhs) | (binder,rhs) <- pairs] - -un_demandify_bndr (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 :: OutType -- Type of the thing to be given to the continuation + -> SimplCont + -> (SimplCont -> SimplM (OutStuff a)) + -> SimplM (OutStuff a) +mkDupableCont ty cont thing_inside + | contIsDupable cont + = thing_inside cont + +mkDupableCont _ (CoerceIt ty cont) thing_inside + = mkDupableCont ty cont $ \ cont' -> + thing_inside (CoerceIt ty cont') + +mkDupableCont ty (InlinePlease cont) thing_inside + = mkDupableCont ty cont $ \ cont' -> + thing_inside (InlinePlease cont') + +mkDupableCont join_arg_ty (ArgOf _ cont_ty cont_fn) thing_inside + = -- Build the RHS of the join point + newId SLIT("a") join_arg_ty ( \ arg_id -> + cont_fn (Var arg_id) `thenSmpl` \ (binds, (_, rhs)) -> + returnSmpl (Lam (setOneShotLambda arg_id) (mkLets binds rhs)) + ) `thenSmpl` \ join_rhs -> + + -- Build the join Id and continuation + -- We give it a "$j" name just so that for later amusement + -- we can identify any join points that don't end up as let-no-escapes + -- [NOTE: the type used to be exprType join_rhs, but this seems more elegant.] + newId SLIT("$j") (mkFunTy join_arg_ty cont_ty) $ \ join_id -> let - go ty [] = ty - go ty (TyArg ty_arg : args) = go (mkAppTy ty ty_arg) args - go ty (a:args) | isValArg a = case (splitFunTy_maybe ty) of - Just (_, res_ty) -> go res_ty args - Nothing -> - pprPanic "computeResultType" (vcat [ - ppr (a:args), - ppr orig_args, - ppr expr_ty', - ppr ty]) + new_cont = ArgOf OkToDup cont_ty + (\arg' -> rebuild_done (App (Var join_id) arg')) 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 + tick (CaseOfCase join_id) `thenSmpl_` + -- Want to tick here so that we go round again, + -- and maybe copy or inline the code; + -- not strictly CaseOf Case + addLetBind (NonRec join_id join_rhs) $ + thing_inside new_cont + +mkDupableCont ty (ApplyTo _ arg se cont) thing_inside + = mkDupableCont (funResultTy ty) cont $ \ cont' -> + setSubstEnv se (simplExpr arg) `thenSmpl` \ arg' -> + if exprIsDupable arg' then + thing_inside (ApplyTo OkToDup arg' emptySubstEnv cont') + else + newId SLIT("a") (exprType arg') $ \ bndr -> + + tick (CaseOfCase bndr) `thenSmpl_` + -- Want to tick here so that we go round again, + -- and maybe copy or inline the code; + -- not strictly CaseOf Case + + addLetBind (NonRec bndr arg') $ + -- But what if the arg should be case-bound? We can't use + -- addNonRecBind here because its type is too specific. + -- This has been this way for a long time, so I'll leave it, + -- but I can't convince myself that it's right. + + thing_inside (ApplyTo OkToDup (Var bndr) emptySubstEnv cont') + + +mkDupableCont ty (Select _ case_bndr alts se cont) thing_inside + = tick (CaseOfCase case_bndr) `thenSmpl_` + setSubstEnv se ( + simplBinder case_bndr $ \ case_bndr' -> + prepareCaseCont alts cont $ \ cont' -> + mapAndUnzipSmpl (mkDupableAlt case_bndr case_bndr' cont') alts `thenSmpl` \ (alt_binds_s, alts') -> + returnSmpl (concat alt_binds_s, alts') + ) `thenSmpl` \ (alt_binds, alts') -> + + addAuxiliaryBinds alt_binds $ + + -- NB that the new alternatives, alts', are still InAlts, using the original + -- binders. That means we can keep the case_bndr intact. This is important + -- because another case-of-case might strike, and so we want to keep the + -- info that the case_bndr is dead (if it is, which is often the case). + -- This is VITAL when the type of case_bndr is an unboxed pair (often the + -- case in I/O rich code. We aren't allowed a lambda bound + -- arg of unboxed tuple type, and indeed such a case_bndr is always dead + thing_inside (Select OkToDup case_bndr alts' se (mkStop (contResultType cont))) + +mkDupableAlt :: InId -> OutId -> SimplCont -> InAlt -> SimplM (OutStuff InAlt) +mkDupableAlt case_bndr case_bndr' cont alt@(con, bndrs, rhs) + = simplBinders bndrs $ \ bndrs' -> + simplExprC rhs cont `thenSmpl` \ rhs' -> + + if (case cont of { Stop _ _ -> exprIsDupable rhs'; other -> False}) then + -- 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. + -- + -- But since the continuation is absorbed into the rhs, we only do this + -- for a Stop continuation. + -- + -- 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. + -- (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. + returnSmpl ([], alt) + + else + let + rhs_ty' = exprType rhs' + (used_bndrs, used_bndrs') + = unzip [pr | pr@(bndr,bndr') <- zip (case_bndr : bndrs) + (case_bndr' : bndrs'), + not (isDeadBinder bndr)] + -- The new binders have lost their occurrence info, + -- so we have to extract it from the old ones + in + ( if null used_bndrs' + -- If we try to lift a primitive-typed something out + -- for let-binding-purposes, we will *caseify* it (!), + -- with potentially-disastrous strictness results. So + -- 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 should not w/w j because it's a thunk, so + -- that means that the enclosing function can't w/w either, + -- which is a lose. Here's the example that happened in practice: + -- kgmod :: Int -> Int -> Int + -- kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0 + -- then 78 + -- else 5 + + then newId SLIT("w") realWorldStatePrimTy $ \ rw_id -> + returnSmpl ([rw_id], [Var realWorldPrimId]) + else + returnSmpl (used_bndrs', map varToCoreExpr used_bndrs) + ) + `thenSmpl` \ (final_bndrs', final_args) -> + + -- See comment about "$j" name above + newId SLIT("$j") (foldr mkPiType rhs_ty' final_bndrs') $ \ join_bndr -> + -- Notice the funky mkPiType. If the contructor has existentials + -- it's possible that the join point will be abstracted over + -- type varaibles as well as term variables. + -- Example: Suppose we have + -- data T = forall t. C [t] + -- Then faced with + -- case (case e of ...) of + -- C t xs::[t] -> rhs + -- We get the join point + -- let j :: forall t. [t] -> ... + -- j = /\t \xs::[t] -> rhs + -- in + -- case (case e of ...) of + -- C t xs::[t] -> j t xs + + let + -- We make the lambdas into one-shot-lambdas. The + -- join point is sure to be applied at most once, and doing so + -- prevents the body of the join point being floated out by + -- the full laziness pass + really_final_bndrs = map one_shot final_bndrs' + one_shot v | isId v = setOneShotLambda v + | otherwise = v + in + returnSmpl ([NonRec join_bndr (mkLams really_final_bndrs rhs')], + (con, bndrs, mkApps (Var join_bndr) final_args)) \end{code} -