X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplify.lhs;h=9f0c1a36e8b7ff49b3ea5debb3ed65df6a2c5a81;hb=cbf5bb17365e9228f3f724b87f958982c4b66cba;hp=cac1d68f54cb0c95b00a7a91a84c122513fb14f2;hpb=1e54134a0be2892fe49f8f9b9505f6e8bf9c196f;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index cac1d68..9f0c1a3 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -1,90 +1,135 @@ - +% % (c) The AQUA Project, Glasgow University, 1993-1998 % \section[Simplify]{The main module of the simplifier} \begin{code} -module Simplify ( simplBind ) where +module Simplify ( simplTopBinds, simplExpr ) where #include "HsVersions.h" -import CmdLineOpts ( switchIsOn, opt_SccProfilingOn, opt_PprStyle_Debug, - opt_NoPreInlining, opt_DictsStrict, opt_D_dump_inlinings, +import CmdLineOpts ( switchIsOn, opt_SimplDoEtaReduction, + opt_SimplNoPreInlining, SimplifierSwitch(..) ) import SimplMonad -import SimplUtils ( mkCase, etaCoreExpr, etaExpandCount, findAlt, mkRhsTyLam, - simplBinder, simplBinders, simplIds, findDefault +import SimplUtils ( mkCase, transformRhs, findAlt, + simplBinder, simplBinders, simplIds, findDefault, + SimplCont(..), DupFlag(..), mkStop, mkRhsStop, + contResultType, discardInline, countArgs, contIsDupable, + getContArgs, interestingCallContext, interestingArg, isStrictType ) -import Var ( TyVar, mkSysTyVar, tyVarKind ) +import Var ( mkSysTyVar, tyVarKind ) import VarEnv -import VarSet -import Id ( Id, idType, - getIdUnfolding, setIdUnfolding, - getIdSpecialisation, setIdSpecialisation, - getIdDemandInfo, setIdDemandInfo, - getIdArity, setIdArity, - getIdStrictness, - setInlinePragma, getInlinePragma, idMustBeINLINEd, - idWantsToBeINLINEd +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 IdInfo ( InlinePragInfo(..), OccInfo(..), StrictnessInfo(..), - ArityInfo, atLeastArity, arityLowerBound, unknownArity +import Demand ( isStrict ) +import DataCon ( dataConNumInstArgs, dataConRepStrictness, + dataConSig, dataConArgTys ) -import Demand ( Demand, isStrict, wwLazy ) -import Const ( isWHNFCon, conOkForAlt ) -import ConFold ( tryPrimOp ) -import PrimOp ( PrimOp, primOpStrictness ) -import DataCon ( DataCon, dataConNumInstArgs, dataConStrictMarks, dataConSig, dataConArgTys ) -import Const ( Con(..) ) -import MagicUFs ( applyMagicUnfoldingFun ) -import Name ( isExported, isLocallyDefined ) import CoreSyn -import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..), - mkUnfolding, smallEnoughToInline, - isEvaldUnfolding +import CoreFVs ( mustHaveLocalBinding, exprFreeVars ) +import CoreUnfold ( mkOtherCon, mkUnfolding, otherCons, + callSiteInline ) -import CoreUtils ( IdSubst, SubstCoreExpr(..), - cheapEqExpr, exprIsDupable, exprIsWHNF, exprIsTrivial, - coreExprType, coreAltsType, exprIsCheap, substExpr, - FormSummary(..), mkFormSummary, whnfOrBottom +import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsTrivial, + exprIsConApp_maybe, mkPiType, + exprType, coreAltsType, exprIsValue, idAppIsCheap, + exprOkForSpeculation, + mkCoerce, mkSCC, mkInlineMe, mkAltExpr ) -import SpecEnv ( lookupSpecEnv, isEmptySpecEnv, substSpecEnv ) -import CostCentre ( isSubsumedCCS, currentCCS, isEmptyCC ) -import Type ( Type, mkTyVarTy, mkTyVarTys, isUnLiftedType, fullSubstTy, - mkFunTy, splitFunTys, splitTyConApp_maybe, splitFunTy_maybe, - applyTy, applyTys, funResultTy, isDictTy, isDataType +import Rules ( lookupRule ) +import CostCentre ( currentCCS ) +import Type ( mkTyVarTys, isUnLiftedType, seqType, + mkFunTy, splitTyConApp_maybe, tyConAppArgs, + funResultTy ) -import TyCon ( isDataTyCon, tyConDataCons, tyConClass_maybe, tyConArity, isDataTyCon ) +import Subst ( mkSubst, substTy, + isInScope, lookupIdSubst, substIdInfo + ) +import TyCon ( isDataTyCon, tyConDataConsIfAvailable ) import TysPrim ( realWorldStatePrimTy ) -import PrelVals ( realWorldPrimId ) -import BasicTypes ( StrictnessMark(..) ) +import PrelInfo ( realWorldPrimId ) import Maybes ( maybeToBool ) -import Util ( zipWithEqual, stretchZipEqual ) -import PprCore +import Util ( zipWithEqual ) import Outputable \end{code} The guts of the simplifier is in this module, but the driver -loop for the simplifier is in SimplPgm.lhs. +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. + + %************************************************************************ %* * -\subsection[Simplify-simplExpr]{The main function: simplExpr} +\subsection{Bindings} %* * %************************************************************************ \begin{code} -addBind :: CoreBind -> OutStuff a -> OutStuff a -addBind bind (binds, res) = (bind:binds, res) +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 -addBinds :: [CoreBind] -> OutStuff a -> OutStuff a -addBinds [] stuff = stuff -addBinds binds1 (binds2, res) = (binds1++binds2, res) + -- 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 + 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. @@ -124,150 +169,210 @@ might do the same again. \begin{code} -simplExpr :: CoreExpr -> SimplCont -> SimplM CoreExpr -simplExpr expr cont = simplExprB expr cont `thenSmpl` \ (binds, (_, body)) -> - returnSmpl (mkLetBinds binds body) +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 -simplExprB :: InExpr -> SimplCont -> SimplM OutExprStuff +simplExprC :: CoreExpr -> SimplCont -> SimplM CoreExpr + -- Simplify an expression, given a continuation -simplExprB (Note InlineCall (Var v)) cont - = simplVar True v cont +simplExprC expr cont = simplExprF expr cont `thenSmpl` \ (floats, (_, body)) -> + returnSmpl (mkLets floats body) -simplExprB (Var v) cont - = simplVar False v cont +simplExprF :: InExpr -> SimplCont -> SimplM OutExprStuff + -- Simplify an expression, returning floated binds -simplExprB expr@(Con (PrimOp op) args) cont - = simplType (coreExprType expr) `thenSmpl` \ expr_ty -> - getInScope `thenSmpl` \ in_scope -> - getSubstEnv `thenSmpl` \ se -> - let - (val_arg_demands, _) = primOpStrictness op - - -- Main game plan: loop through the arguments, simplifying - -- each of them with an ArgOf continuation. Getting the right - -- cont_ty in the ArgOf continuation is a bit of a nuisance. - go [] ds args' = rebuild_primop (reverse args') - go (arg:args) ds args' - | isTypeArg arg = setSubstEnv se (simplArg arg) `thenSmpl` \ arg' -> - go args ds (arg':args') - go (arg:args) (d:ds) args' - | not (isStrict d) = setSubstEnv se (simplArg arg) `thenSmpl` \ arg' -> - go args ds (arg':args') - | otherwise = setSubstEnv se (simplExprB arg (mk_cont args ds args')) - - cont_ty = contResultType in_scope expr_ty cont - mk_cont args ds args' = ArgOf NoDup (\ arg' -> go args ds (arg':args')) cont_ty - in - go args val_arg_demands [] - where +simplExprF (Var v) cont + = simplVar v cont - rebuild_primop args' - = -- Try the prim op simplification - -- It's really worth trying simplExpr again if it succeeds, - -- because you can find - -- case (eqChar# x 'a') of ... - -- ==> - -- case (case x of 'a' -> True; other -> False) of ... - case tryPrimOp op args' of - Just e' -> zapSubstEnv (simplExprB e' cont) - Nothing -> rebuild (Con (PrimOp op) args') cont - -simplExprB (Con con@(DataCon _) args) cont - = simplConArgs args $ \ args' -> - rebuild (Con con args') cont - -simplExprB expr@(Con con@(Literal _) args) cont - = ASSERT( null args ) - rebuild expr cont - -simplExprB (App fun arg) cont - = getSubstEnv `thenSmpl` \ se -> - simplExprB fun (ApplyTo NoDup arg se cont) +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 -simplExprB (Case scrut bndr alts) cont +simplExprF (App fun arg) cont = getSubstEnv `thenSmpl` \ se -> - simplExprB scrut (Select NoDup bndr alts se cont) + simplExprF fun (ApplyTo NoDup arg se cont) -simplExprB (Note (Coerce to from) e) cont - | to == from = simplExprB e cont - | otherwise = getSubstEnv `thenSmpl` \ se -> - simplExprB e (CoerceIt NoDup to se cont) +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) --- hack: we only distinguish subsumed cost centre stacks for the purposes of --- inlining. All other CCCSs are mapped to currentCCS. -simplExprB (Note (SCC cc) e) cont - = setEnclosingCC currentCCS $ - simplExpr e Stop `thenSmpl` \ e -> - rebuild (mkNote (SCC cc) e) cont + 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 -simplExprB (Note note e) cont - = simplExpr e Stop `thenSmpl` \ e' -> - rebuild (mkNote note e') cont --- A non-recursive let is dealt with by simplBeta -simplExprB (Let (NonRec bndr rhs) body) cont - = getSubstEnv `thenSmpl` \ se -> - simplBeta bndr rhs se body cont - -simplExprB (Let (Rec pairs) body) cont - = simplRecBind pairs (simplExprB body cont) - --- Type-beta reduction -simplExprB expr@(Lam bndr body) cont@(ApplyTo _ (Type ty_arg) arg_se body_cont) - = ASSERT( isTyVar bndr ) - tick BetaReduction `thenSmpl_` - setSubstEnv arg_se (simplType ty_arg) `thenSmpl` \ ty' -> - extendTySubst bndr ty' $ - simplExprB body body_cont - --- Ordinary beta reduction -simplExprB expr@(Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont) - = tick BetaReduction `thenSmpl_` - simplBeta bndr' arg arg_se body body_cont - where - bndr' = zapLambdaBndr bndr body body_cont +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 -simplExprB (Lam bndr body) cont - = simplBinder bndr $ \ bndr' -> - simplExpr body Stop `thenSmpl` \ body' -> - rebuild (Lam bndr' body') cont + simplRecBind False pairs bndrs' (simplExprF body cont) + +simplExprF expr@(Lam _ _) cont = simplLam expr cont -simplExprB (Type ty) cont - = ASSERT( case cont of { Stop -> True; ArgOf _ _ _ -> True; other -> False } ) +simplExprF (Type ty) cont + = ASSERT( case cont of { Stop _ _ -> True; ArgOf _ _ _ -> True; other -> False } ) simplType ty `thenSmpl` \ ty' -> rebuild (Type ty') cont -\end{code} +-- 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) ---------------------------------- -\begin{code} -simplArg :: InArg -> SimplM OutArg -simplArg arg = simplExpr arg Stop +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} + --------------------------------- -simplConArgs makes sure that the arguments all end up being atomic. -That means it may generate some Lets, hence the \begin{code} -simplConArgs :: [InArg] -> ([OutArg] -> SimplM OutExprStuff) -> SimplM OutExprStuff -simplConArgs [] thing_inside - = thing_inside [] +simplLam fun cont + = go fun cont + where + 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 + + -- Not enough args + go lam@(Lam _ _) cont = completeLam [] lam cont + + -- Exactly enough args + go expr cont = simplExprF expr cont + +-- 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 + +completeLam rev_bndrs (Lam bndr body) cont + = simplBinder bndr $ \ bndr' -> + completeLam (bndr':rev_bndrs) body cont -simplConArgs (arg:args) thing_inside - = switchOffInlining (simplArg arg) `thenSmpl` \ arg' -> - -- Simplify the RHS with inlining switched off, so that - -- only absolutely essential things will happen. +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 - simplConArgs args $ \ args' -> + 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 - -- If the argument ain't trivial, then let-bind it - if exprIsTrivial arg' then - thing_inside (arg' : args') - else - newId (coreExprType arg') $ \ arg_id -> - thing_inside (Var arg_id : args') `thenSmpl` \ res -> - returnSmpl (addBind (NonRec arg_id arg') res) + n_params (Note _ e) = n_params e + n_params (Lam b e) = 1 + n_params e + n_params other = 0::Int \end{code} @@ -275,279 +380,228 @@ simplConArgs (arg:args) thing_inside \begin{code} simplType :: InType -> SimplM OutType simplType ty - = getTyEnv `thenSmpl` \ (ty_subst, in_scope) -> - returnSmpl (fullSubstTy ty_subst in_scope ty) + = getSubst `thenSmpl` \ subst -> + let + new_ty = substTy subst ty + in + seqType new_ty `seq` + returnSmpl new_ty \end{code} -\begin{code} --- Find out whether the lambda is saturated, --- if not zap the over-optimistic info in the binder - -zapLambdaBndr bndr body body_cont - | isTyVar bndr || safe_info || definitely_saturated 20 body body_cont - -- The "20" is to catch pathalogical cases with bazillions of arguments - -- because we are using an n**2 algorithm here - = bndr -- No need to zap - | otherwise - = setInlinePragma (setIdDemandInfo bndr wwLazy) - safe_inline_prag - - where - inline_prag = getInlinePragma bndr - demand = getIdDemandInfo bndr - - safe_info = is_safe_inline_prag && not (isStrict demand) - - is_safe_inline_prag = case inline_prag of - ICanSafelyBeINLINEd StrictOcc nalts -> False - ICanSafelyBeINLINEd LazyOcc nalts -> False - other -> True - - safe_inline_prag = case inline_prag of - ICanSafelyBeINLINEd _ nalts - -> ICanSafelyBeINLINEd InsideLam nalts - other -> inline_prag - - definitely_saturated 0 _ _ = False -- Too expensive to find out - definitely_saturated n (Lam _ body) (ApplyTo _ _ _ cont) = definitely_saturated (n-1) body cont - definitely_saturated n (Lam _ _) other_cont = False - definitely_saturated n _ _ = True -\end{code} - %************************************************************************ %* * -\subsection{Variables} +\subsection{Binding} %* * %************************************************************************ -Coercions -~~~~~~~~~ -\begin{code} -simplVar inline_call var cont - = getValEnv `thenSmpl` \ (id_subst, in_scope) -> - case lookupVarEnv id_subst var of - Just (Done e) - -> zapSubstEnv (simplExprB e cont) - - Just (SubstMe e ty_subst id_subst) - -> setSubstEnv (ty_subst, id_subst) (simplExprB e cont) - - Nothing -> let - var' = case lookupVarSet in_scope var of - Just v' -> v' - Nothing -> -#ifdef DEBUG - if isLocallyDefined var && not (idMustBeINLINEd var) then - -- Not in scope - pprTrace "simplVar:" (ppr var) var - else -#endif - var - in - getSwitchChecker `thenSmpl` \ sw_chkr -> - completeVar sw_chkr in_scope inline_call var' cont - -completeVar sw_chkr in_scope inline_call var cont - -{- MAGIC UNFOLDINGS NOT USED NOW - | maybeToBool maybe_magic_result - = tick MagicUnfold `thenSmpl_` - magic_result --} - -- Look for existing specialisations before trying inlining - | maybeToBool maybe_specialisation - = tick SpecialisationDone `thenSmpl_` - setSubstEnv (spec_bindings, emptyVarEnv) ( - -- See note below about zapping the substitution here - - simplExprB spec_template remaining_cont - ) - - -- Don't actually inline the scrutinee when we see - -- case x of y { .... } - -- and x has unfolding (C a b). Why not? Because - -- we get a silly binding y = C a b. If we don't - -- inline knownCon can directly substitute x for y instead. - | has_unfolding && var_is_case_scrutinee && unfolding_is_constr - = knownCon (Var var) con con_args cont - - -- Look for an unfolding. There's a binding for the - -- thing, but perhaps we want to inline it anyway - | has_unfolding && (inline_call || ok_to_inline) - = getEnclosingCC `thenSmpl` \ encl_cc -> - if must_be_unfolded || costCentreOk encl_cc (coreExprCc unf_template) - then -- OK to unfold +@simplBeta@ is used for non-recursive lets in expressions, +as well as true beta reduction. - tickUnfold var `thenSmpl_` ( +Very similar to @simplLazyBind@, but not quite the same. - zapSubstEnv $ - -- The template is already simplified, so don't re-substitute. - -- This is VITAL. Consider - -- let x = e in - -- let y = \z -> ...x... in - -- \ x -> ...y... - -- We'll clone the inner \x, adding x->x' in the id_subst - -- Then when we inline y, we must *not* replace x by x' in - -- the inlined copy!! -#ifdef DEBUG - if opt_D_dump_inlinings then - pprTrace "Inlining:" (ppr var <+> ppr unf_template) $ - simplExprB unf_template cont - else -#endif - simplExprB unf_template cont - ) - else +\begin{code} +simplBeta :: InId -- Binder + -> InExpr -> SubstEnv -- Arg, with its subst-env + -> OutType -- Type of thing computed by the context + -> SimplM OutExprStuff -- The body + -> SimplM OutExprStuff #ifdef DEBUG - pprTrace "Inlining disallowed due to CC:\n" (ppr encl_cc <+> ppr unf_template <+> ppr (coreExprCc unf_template)) $ +simplBeta bndr rhs rhs_se cont_ty thing_inside + | isTyVar bndr + = pprPanic "simplBeta" (ppr bndr <+> ppr rhs) #endif - -- Can't unfold because of bad cost centre - rebuild (Var var) cont - | inline_call -- There was an InlineCall note, but we didn't inline! - = rebuild (Note InlineCall (Var var)) cont +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 | otherwise - = rebuild (Var var) cont + = -- 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' -> - where - unfolding = getIdUnfolding var - -{- MAGIC UNFOLDINGS NOT USED CURRENTLY - ---------- Magic unfolding stuff - maybe_magic_result = case unfolding of - MagicUnfolding _ magic_fn -> applyMagicUnfoldingFun magic_fn - cont - other -> Nothing - Just magic_result = maybe_magic_result --} - - ---------- Unfolding stuff - has_unfolding = case unfolding of - CoreUnfolding _ _ _ -> True - other -> False - CoreUnfolding form guidance unf_template = unfolding - - -- overrides cost-centre business - must_be_unfolded = case getInlinePragma var of - IMustBeINLINEd -> True - _ -> False - - ok_to_inline = okToInline sw_chkr in_scope var form guidance cont - unfolding_is_constr = case unf_template of - Con con _ -> conOkForAlt con - other -> False - Con con con_args = unf_template - - ---------- Specialisation stuff - ty_args = initial_ty_args cont - remaining_cont = drop_ty_args cont - maybe_specialisation = lookupSpecEnv (ppr var) (getIdSpecialisation var) ty_args - Just (spec_bindings, spec_template) = maybe_specialisation - - initial_ty_args (ApplyTo _ (Type ty) (ty_subst,_) cont) - = fullSubstTy ty_subst in_scope ty : initial_ty_args cont - -- Having to do the substitution here is a bit of a bore - initial_ty_args other_cont = [] - - drop_ty_args (ApplyTo _ (Type _) _ cont) = drop_ty_args cont - drop_ty_args other_cont = other_cont - - ---------- Switches - - var_is_case_scrutinee = case cont of - Select _ _ _ _ _ -> True - other -> False - ------------ costCentreOk --- costCentreOk checks that it's ok to inline this thing --- The time it *isn't* is this: --- --- f x = let y = E in --- scc "foo" (...y...) --- --- Here y has a "current cost centre", and we can't inline it inside "foo", --- regardless of whether E is a WHNF or not. - -costCentreOk ccs_encl cc_rhs - = not opt_SccProfilingOn - || isSubsumedCCS ccs_encl -- can unfold anything into a subsumed scope - || not (isEmptyCC cc_rhs) -- otherwise need a cc on the unfolding -\end{code} + -- 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} -%************************************************************************ -%* * -\subsection{Bindings} -%* * -%************************************************************************ - \begin{code} -simplBind :: InBind -> SimplM (OutStuff a) -> SimplM (OutStuff a) +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') -simplBind (NonRec bndr rhs) thing_inside - = simplTopRhs bndr rhs `thenSmpl` \ (binds, in_scope, rhs', arity) -> - setInScope in_scope $ - completeBindNonRec (bndr `setIdArity` arity) rhs' thing_inside `thenSmpl` \ stuff -> - returnSmpl (addBinds binds stuff) + | otherwise + = simplRhs False {- Not top level -} + True {- OK to float unboxed -} + arg_ty arg arg_se + thing_inside +\end{code} -simplBind (Rec pairs) thing_inside - = simplRecBind pairs thing_inside - -- The assymetry between the two cases is a bit unclean -simplRecBind :: [(InId, InExpr)] -> SimplM (OutStuff a) -> SimplM (OutStuff a) -simplRecBind pairs thing_inside - = simplIds (map fst pairs) $ \ bndrs' -> - -- NB: bndrs' don't have unfoldings or spec-envs - -- We add them as we go down, using simplPrags +completeBinding + - deals only with Ids, not TyVars + - take an already-simplified RHS - go (pairs `zip` bndrs') `thenSmpl` \ (pairs', stuff) -> - returnSmpl (addBind (Rec pairs') stuff) - where - go [] = thing_inside `thenSmpl` \ stuff -> - returnSmpl ([], stuff) +It does *not* attempt to do let-to-case. Why? Because they are used for - go (((bndr, rhs), bndr') : pairs) - = simplTopRhs bndr rhs `thenSmpl` \ (rhs_binds, in_scope, rhs', arity) -> - setInScope in_scope $ - completeBindRec bndr (bndr' `setIdArity` arity) - rhs' (go pairs) `thenSmpl` \ (pairs', stuff) -> - returnSmpl (flatten rhs_binds pairs', stuff) + - top-level bindings + (when let-to-case is impossible) - flatten (NonRec b r : binds) prs = (b,r) : flatten binds prs - flatten (Rec prs1 : binds) prs2 = prs1 ++ flatten binds prs2 - flatten [] prs = prs + - many situations where the "rhs" is known to be a WHNF + (so let-to-case is inappropriate). + +\begin{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 -completeBindRec bndr bndr' rhs' thing_inside - | postInlineUnconditionally bndr etad_rhs + | 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 - = tick PostInlineUnconditionally `thenSmpl_` - extendIdSubst bndr (Done etad_rhs) thing_inside + -- + -- 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 + | otherwise - = -- Here's the only difference from completeBindNonRec: we - -- don't do simplBinder first, because we've already - -- done simplBinder on the recursive binders - simplPrags bndr bndr' etad_rhs `thenSmpl` \ bndr'' -> - modifyInScope bndr'' $ - thing_inside `thenSmpl` \ (pairs, res) -> - returnSmpl ((bndr'', etad_rhs) : pairs, res) + = transformRhs new_rhs finally_bind_it + where - etad_rhs = etaCoreExpr rhs' -\end{code} + 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} + %************************************************************************ %* * -\subsection{Right hand sides} +\subsection{simplLazyBind} %* * %************************************************************************ -simplRhs basically just simplifies the RHS of a let(rec). +simplLazyBind basically just simplifies the RHS of a let(rec). It does two important optimisations though: * It floats let(rec)s out of the RHS, even if they @@ -556,239 +610,341 @@ It does two important optimisations though: * It does eta expansion \begin{code} -simplTopRhs :: InId -> InExpr - -> SimplM ([OutBind], InScopeEnv, OutExpr, ArityInfo) -simplTopRhs bndr rhs - = getSubstEnv `thenSmpl` \ bndr_se -> - simplRhs bndr bndr_se rhs - -simplRhs bndr bndr_se rhs - | idWantsToBeINLINEd bndr -- Don't inline in the RHS of something that has an - -- inline pragma. But be careful that the InScopeEnv that - -- we return does still have inlinings on! - = switchOffInlining (simplExpr rhs Stop) `thenSmpl` \ rhs' -> - getInScope `thenSmpl` \ in_scope -> - returnSmpl ([], in_scope, rhs', unknownArity) - - | otherwise - = -- Swizzle the inner lets past the big lambda (if any) - mkRhsTyLam rhs `thenSmpl` \ swizzled_rhs -> - - -- Simplify the swizzled RHS - simplRhs2 bndr bndr_se swizzled_rhs `thenSmpl` \ (floats, (in_scope, rhs', arity)) -> - - if not (null floats) && exprIsWHNF rhs' then -- Do the float - tick LetFloatFromLet `thenSmpl_` - returnSmpl (floats, in_scope, rhs', arity) - else -- Don't do it - getInScope `thenSmpl` \ in_scope -> - returnSmpl ([], in_scope, mkLetBinds floats rhs', arity) -\end{code} - ---------------------------------------------------------- - Try eta expansion for RHSs - -We need to pass in the substitution environment for the RHS, because -it might be different to the current one (see simplBeta, as called -from simplExpr for an applied lambda). The binder needs to - -\begin{code} -simplRhs2 bndr bndr_se (Let bind body) - = simplBind bind (simplRhs2 bndr bndr_se body) - -simplRhs2 bndr bndr_se rhs - | null ids -- Prevent eta expansion for both thunks - -- (would lose sharing) and variables (nothing gained). - -- To see why we ignore it for thunks, consider - -- let f = lookup env key in (f 1, f 2) - -- We'd better not eta expand f just because it is - -- always applied! - -- - -- Also if there isn't a lambda at the top we use - -- simplExprB so that we can do (more) let-floating - = simplExprB rhs Stop `thenSmpl` \ (binds, (in_scope, rhs')) -> - returnSmpl (binds, (in_scope, rhs', unknownArity)) - - | otherwise -- Consider eta expansion - = getSwitchChecker `thenSmpl` \ sw_chkr -> - getInScope `thenSmpl` \ in_scope -> - simplBinders tyvars $ \ tyvars' -> - simplBinders ids $ \ ids' -> +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 - if switchIsOn sw_chkr SimplDoLambdaEtaExpansion - && not (null extra_arg_tys) - then - tick EtaExpansion `thenSmpl_` - setSubstEnv bndr_se (mapSmpl simplType extra_arg_tys) - `thenSmpl` \ extra_arg_tys' -> - newIds extra_arg_tys' $ \ extra_bndrs' -> - simplExpr body (mk_cont extra_bndrs') `thenSmpl` \ body' -> - let - expanded_rhs = mkLams tyvars' - $ mkLams ids' - $ mkLams extra_bndrs' body' - expanded_arity = atLeastArity (no_of_ids + no_of_extras) - in - returnSmpl ([], (in_scope, expanded_rhs, expanded_arity)) +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 - simplExpr body Stop `thenSmpl` \ body' -> - let - unexpanded_rhs = mkLams tyvars' - $ mkLams ids' body' - unexpanded_arity = atLeastArity no_of_ids - in - returnSmpl ([], (in_scope, unexpanded_rhs, unexpanded_arity)) - where - (tyvars, ids, body) = collectTyAndValBinders rhs - no_of_ids = length ids - - potential_extra_arg_tys :: [InType] -- NB: InType - potential_extra_arg_tys = case splitFunTys (applyTys (idType bndr) (mkTyVarTys tyvars)) of - (arg_tys, _) -> drop no_of_ids arg_tys - - extra_arg_tys :: [InType] - extra_arg_tys = take no_extras_wanted potential_extra_arg_tys - no_of_extras = length extra_arg_tys + -- Simplify the RHS + getSubstEnv `thenSmpl` \ rhs_se -> + simplRhs top_lvl False {- Not ok to float unboxed (conservative) -} + (idType bndr') + rhs rhs_se $ \ rhs' -> - no_extras_wanted = -- Use information about how many args the fn is applied to - (arity - no_of_ids) `max` - - -- See if the body could obviously do with more args - etaExpandCount body `max` + -- Now compete the binding and simplify the body + completeBinding bndr bndr' top_lvl black_listed rhs' thing_inside +\end{code} - -- Finally, see if it's a state transformer, in which - -- case we eta-expand on principle! This can waste work, - -- but usually doesn't - case potential_extra_arg_tys of - [ty] | ty == realWorldStatePrimTy -> 1 - other -> 0 - arity = arityLowerBound (getIdArity bndr) - mk_cont [] = Stop - mk_cont (b:bs) = ApplyTo OkToDup (Var b) emptySubstEnv (mk_cont bs) +\begin{code} +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 + (floats_out, rhs'') = splitFloats float_ubx floats rhs' + in + 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 + 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} + %************************************************************************ %* * -\subsection{Binding} +\subsection{Variables} %* * %************************************************************************ \begin{code} -simplBeta :: InId -- Binder - -> InExpr -> SubstEnv -- Arg, with its subst-env - -> InExpr -> SimplCont -- Lambda body - -> SimplM OutExprStuff -#ifdef DEBUG -simplBeta bndr rhs rhs_se body cont - | isTyVar bndr - = pprPanic "simplBeta" ((ppr bndr <+> ppr rhs) $$ ppr cont) -#endif +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!! -simplBeta bndr rhs rhs_se body cont - | isUnLiftedType bndr_ty - || (isStrict (getIdDemandInfo bndr) || is_dict bndr) && not (exprIsWHNF rhs) - = tick Let2Case `thenSmpl_` - getSubstEnv `thenSmpl` \ body_se -> - setSubstEnv rhs_se $ - simplExprB rhs (Select NoDup bndr [(DEFAULT, [], body)] body_se cont) +--------------------------------------------------------- +-- Dealing with a call - | preInlineUnconditionally bndr && not opt_NoPreInlining - = tick PreInlineUnconditionally `thenSmpl_` - case rhs_se of { (ty_subst, id_subst) -> - extendIdSubst bndr (SubstMe rhs ty_subst id_subst) $ - simplExprB body cont } +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] - | otherwise - = getSubstEnv `thenSmpl` \ bndr_se -> - setSubstEnv rhs_se (simplRhs bndr bndr_se rhs) - `thenSmpl` \ (floats, in_scope, rhs', arity) -> - setInScope in_scope $ - completeBindNonRec (bndr `setIdArity` arity) rhs' ( - simplExprB body cont - ) `thenSmpl` \ stuff -> - returnSmpl (addBinds floats stuff) - where - -- Return true only for dictionary types where the dictionary - -- has more than one component (else we risk poking on the component - -- of a newtype dictionary) - is_dict bndr = opt_DictsStrict && isDictTy bndr_ty && isDataType bndr_ty - bndr_ty = idType bndr -\end{code} + interesting_cont = interestingCallContext (not (null args)) + (not (null arg_infos)) + call_cont + inline_cont | inline_call = discardInline cont + | otherwise = cont -completeBindNonRec - - deals only with Ids, not TyVars - - take an already-simplified RHS - - always produce let bindings + 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 -It does *not* attempt to do let-to-case. Why? Because they are used for + ; + Nothing -> -- No inlining! - - top-level bindings - (when let-to-case is impossible) - - many situations where the "rhs" is known to be a WHNF - (so let-to-case is inappropriate). + simplifyArgs (isDataConId var) args (contResultType call_cont) $ \ args' -> -\begin{code} -completeBindNonRec :: InId -- Binder - -> OutExpr -- Simplified RHS - -> SimplM (OutStuff a) -- Thing inside - -> SimplM (OutStuff a) -completeBindNonRec bndr rhs thing_inside - | isDeadBinder bndr -- This happens; for example, the case_bndr during case of - -- known constructor: case (a,b) of x { (p,q) -> ... } - -- Here x isn't mentioned in the RHS, so we don't want to - -- create the (dead) let-binding let x = (a,b) in ... - = thing_inside + -- 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 + }} - | postInlineUnconditionally bndr etad_rhs - = tick PostInlineUnconditionally `thenSmpl_` - extendIdSubst bndr (Done etad_rhs) - thing_inside - - | otherwise -- Note that we use etad_rhs here - -- This gives maximum chance for a remaining binding - -- to be zapped by the indirection zapper in OccurAnal - = simplBinder bndr $ \ bndr' -> - simplPrags bndr bndr' etad_rhs `thenSmpl` \ bndr'' -> - modifyInScope bndr'' $ - thing_inside `thenSmpl` \ stuff -> - returnSmpl (addBind (NonRec bndr' etad_rhs) stuff) - where - etad_rhs = etaCoreExpr rhs --- (simplPrags old_bndr new_bndr new_rhs) does two things --- (a) it attaches the new unfolding to new_bndr --- (b) it grabs the SpecEnv from old_bndr, applies the current --- substitution to it, and attaches it to new_bndr --- The assumption is that new_bndr, which is produced by simplBinder --- has no unfolding or specenv. +--------------------------------------------------------- +-- 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' -simplPrags old_bndr new_bndr new_rhs - | isEmptySpecEnv spec_env - = returnSmpl (bndr_w_unfolding) + 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') - | otherwise - = getSimplBinderStuff `thenSmpl` \ (ty_subst, id_subst, in_scope, us) -> +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) + +simplifyArg is_data_con (val_arg, se, is_strict) cont_ty thing_inside + = getInScope `thenSmpl` \ in_scope -> let - spec_env' = substSpecEnv ty_subst in_scope (subst_val id_subst) spec_env + arg_ty = substTy (mkSubst in_scope se) (exprType val_arg) in - returnSmpl (bndr_w_unfolding `setIdSpecialisation` spec_env') - where - bndr_w_unfolding = new_bndr `setIdUnfolding` mkUnfolding new_rhs + 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' -> + + 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} - spec_env = getIdSpecialisation old_bndr - subst_val id_subst ty_subst in_scope expr - = substExpr ty_subst id_subst in_scope expr -\end{code} + +%************************************************************************ +%* * +\subsection{Decisions about inlining} +%* * +%************************************************************************ + +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 <...> + + (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. + +Doing the dynamic allocation isn't a big deal, in fact, but losing the +fusion can be. \begin{code} -preInlineUnconditionally :: InId -> Bool +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 @@ -806,232 +962,19 @@ preInlineUnconditionally :: InId -> Bool -- we'd do the same for y -- aargh! So we must base this -- pre-rhs-simplification decision solely on x's occurrences, not -- on its rhs. -preInlineUnconditionally bndr - = case getInlinePragma bndr of - ICanSafelyBeINLINEd InsideLam _ -> False - ICanSafelyBeINLINEd not_in_lam True -> True -- Not inside a lambda, - -- one occurrence ==> safe! - other -> False - - -postInlineUnconditionally :: InId -> OutExpr -> Bool - -- Examines a (bndr = rhs) binding, AFTER the rhs has been simplified - -- It returns True if it's ok to discard the binding and inline the - -- RHS at every use site. - - -- NOTE: This isn't our last opportunity to inline. - -- We're at the binding site right now, and - -- we'll get another opportunity when we get to the ocurrence(s) - -postInlineUnconditionally bndr rhs - | isExported bndr - = False - | otherwise - = case getInlinePragma bndr of - IAmALoopBreaker -> False - IMustNotBeINLINEd -> False - IAmASpecPragmaId -> False -- Don't discard SpecPrag Ids - - ICanSafelyBeINLINEd InsideLam one_branch -> exprIsTrivial rhs - -- Don't inline even WHNFs inside lambdas; this - -- isn't the last chance; see NOTE above. - - ICanSafelyBeINLINEd not_in_lam one_branch -> one_branch || exprIsDupable rhs - - other -> exprIsTrivial rhs -- Duplicating is *free* - -- NB: Even IWantToBeINLINEd and IMustBeINLINEd are ignored here - -- Why? Because we don't even want to inline them into the - -- RHS of constructor arguments. See NOTE above - -inlineCase bndr scrut - = case getInlinePragma bndr of - -- Not expecting IAmALoopBreaker etc; this is a case binder! - - ICanSafelyBeINLINEd StrictOcc one_branch - -> one_branch || exprIsDupable scrut - -- This case is the entire reason we distinguish StrictOcc from LazyOcc - -- We want eliminate the "case" only if we aren't going to - -- build a thunk instead, and that's what StrictOcc finds - -- For example: - -- case (f x) of y { DEFAULT -> g y } - -- Here we DO NOT WANT: - -- g (f x) - -- *even* if g is strict. We want to avoid constructing the - -- thunk for (f x)! So y gets a LazyOcc. - - other -> exprIsTrivial scrut -- Duplication is free - && ( isUnLiftedType (idType bndr) - || scrut_is_evald_var -- So dropping the case won't change termination - || isStrict (getIdDemandInfo bndr)) -- It's going to get evaluated later, so again - -- termination doesn't change - where - -- Check whether or not scrut is known to be evaluted - -- It's not going to be a visible value (else the previous - -- blob would apply) so we just check the variable case - scrut_is_evald_var = case scrut of - Var v -> isEvaldUnfolding (getIdUnfolding v) - other -> False + -- + -- 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} -okToInline is used at call sites, so it is a bit more generous. -It's a very important function that embodies lots of heuristics. -\begin{code} -okToInline :: SwitchChecker - -> InScopeEnv - -> Id -- The Id - -> FormSummary -- The thing is WHNF or bottom; - -> UnfoldingGuidance - -> SimplCont - -> Bool -- True <=> inline it - --- A non-WHNF can be inlined if it doesn't occur inside a lambda, --- and occurs exactly once or --- occurs once in each branch of a case and is small --- --- If the thing is in WHNF, there's no danger of duplicating work, --- so we can inline if it occurs once, or is small - -okToInline sw_chkr in_scope id form guidance cont - | switchIsOn sw_chkr EssentialUnfoldingsOnly - = -#ifdef DEBUG - if opt_D_dump_inlinings then - pprTrace "Considering inlining" - (ppr id <+> vcat [text "essential inlinings only", - text "inline prag:" <+> ppr inline_prag, - text "ANSWER =" <+> if result then text "YES" else text "NO"]) - result - else -#endif - result - where - inline_prag = getInlinePragma id - result = idMustBeINLINEd id - -- If "essential_unfoldings_only" is true we do no inlinings at all, - -- EXCEPT for things that absolutely have to be done - -- (see comments with idMustBeINLINEd) - - -okToInline sw_chkr in_scope id form guidance cont - -- Essential unfoldings only not on - = -#ifdef DEBUG - if opt_D_dump_inlinings then - pprTrace "Considering inlining" - (ppr id <+> vcat [text "inline prag:" <+> ppr inline_prag, - text "whnf" <+> ppr whnf, - text "small enough" <+> ppr small_enough, - text "some benefit" <+> ppr some_benefit, - text "arg evals" <+> ppr arg_evals, - text "result scrut" <+> ppr result_scrut, - text "ANSWER =" <+> if result then text "YES" else text "NO"]) - result - else -#endif - result - where - result = case inline_prag of - IAmDead -> pprTrace "okToInline: dead" (ppr id) False - - IAmASpecPragmaId -> False - IMustNotBeINLINEd -> False - IAmALoopBreaker -> False - IMustBeINLINEd -> True - IWantToBeINLINEd -> True - - ICanSafelyBeINLINEd inside_lam one_branch - -> (small_enough || one_branch) && - ((whnf && some_benefit) || not_inside_lam) - - where - not_inside_lam = case inside_lam of {InsideLam -> False; other -> True} - - other -> whnf && small_enough && some_benefit - -- We could consider using exprIsCheap here, - -- as in postInlineUnconditionally, but unlike the latter we wouldn't - -- necessarily eliminate a thunk; and the "form" doesn't tell - -- us that. - - inline_prag = getInlinePragma id - whnf = whnfOrBottom form - small_enough = smallEnoughToInline id arg_evals result_scrut guidance - (arg_evals, result_scrut) = get_evals cont - - -- some_benefit checks that *something* interesting happens to - -- the variable after it's inlined. - some_benefit = contIsInteresting cont - - -- Finding out whether the args are evaluated. This isn't completely easy - -- because the args are not yet simplified, so we have to peek into them. - get_evals (ApplyTo _ arg (te,ve) cont) - | isValArg arg = case get_evals cont of - (args, res) -> (get_arg_eval arg ve : args, res) - | otherwise = get_evals cont - - get_evals (Select _ _ _ _ _) = ([], True) - get_evals other = ([], False) - - get_arg_eval (Con con _) ve = isWHNFCon con - get_arg_eval (Var v) ve = case lookupVarEnv ve v of - Just (SubstMe e' _ ve') -> get_arg_eval e' ve' - Just (Done (Con con _)) -> isWHNFCon con - Just (Done (Var v')) -> get_var_eval v' - Just (Done other) -> False - Nothing -> get_var_eval v - get_arg_eval other ve = False - - get_var_eval v = case lookupVarSet in_scope v of - Just v' -> isEvaldUnfolding (getIdUnfolding v') - Nothing -> isEvaldUnfolding (getIdUnfolding v) - - -contIsInteresting :: SimplCont -> Bool -contIsInteresting Stop = False -contIsInteresting (ArgOf _ _ _) = False -contIsInteresting (ApplyTo _ (Type _) _ cont) = contIsInteresting cont -contIsInteresting (CoerceIt _ _ _ cont) = contIsInteresting cont - --- Even a case with only a default case is a bit interesting; --- we may be able to eliminate it after inlining. --- contIsInteresting (Select _ _ [(DEFAULT,_,_)] _ _) = False - -contIsInteresting _ = True -\end{code} - -Comment about some_benefit above -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We want to avoid inlining an expression where there can't possibly be -any gain, such as in an argument position. Hence, if the continuation -is interesting (eg. a case scrutinee, application etc.) then we -inline, otherwise we don't. - -Previously some_benefit used to return True only if the variable was -applied to some value arguments. This didn't work: - - let x = _coerce_ (T Int) Int (I# 3) in - case _coerce_ Int (T Int) x of - I# y -> .... - -we want to inline x, but can't see that it's a constructor in a case -scrutinee position, and some_benefit is False. - -Another example: - -dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t) - -.... case dMonadST _@_ x0 of (a,b,c) -> .... - -we'd really like to inline dMonadST here, but we *don't* want to -inline if the case expression is just - - case x of y { DEFAULT -> ... } - -since we can just eliminate this case instead (x is in WHNF). Similar -applies when x is bound to a lambda expression. Hence -contIsInteresting looks for case expressions with just a single -default case. %************************************************************************ %* * @@ -1041,103 +984,35 @@ default case. \begin{code} ------------------------------------------------------------------- -rebuild :: OutExpr -> SimplCont -> SimplM OutExprStuff - -rebuild expr cont - = tick LeavesExamined `thenSmpl_` - do_rebuild expr cont - +-- Finish rebuilding rebuild_done expr - = getInScope `thenSmpl` \ in_scope -> + = getInScope `thenSmpl` \ in_scope -> returnSmpl ([], (in_scope, expr)) --------------------------------------------------------- --- Stop continuation - -do_rebuild expr Stop = rebuild_done expr +rebuild :: OutExpr -> SimplCont -> SimplM OutExprStuff +-- Stop continuation +rebuild expr (Stop _ _) = rebuild_done expr ---------------------------------------------------------- -- ArgOf continuation +rebuild expr (ArgOf _ _ cont_fn) = cont_fn expr -do_rebuild expr (ArgOf _ cont_fn _) = cont_fn expr - ---------------------------------------------------------- -- ApplyTo continuation +rebuild expr cont@(ApplyTo _ arg se cont') + = setSubstEnv se (simplExpr arg) `thenSmpl` \ arg' -> + rebuild (App expr arg') cont' -do_rebuild expr cont@(ApplyTo _ arg se cont') - = case expr of - Var v -> case getIdStrictness v of - NoStrictnessInfo -> non_strict_case - StrictnessInfo demands result_bot _ -> ASSERT( not (null demands) || result_bot ) - -- If this happened we'd get an infinite loop - rebuild_strict demands result_bot expr (idType v) cont - other -> non_strict_case - where - non_strict_case = setSubstEnv se (simplArg arg) `thenSmpl` \ arg' -> - do_rebuild (App expr arg') cont' - - ---------------------------------------------------------- -- Coerce continuation +rebuild expr (CoerceIt to_ty cont) + = rebuild (mkCoerce to_ty (exprType expr) expr) cont -do_rebuild expr (CoerceIt _ to_ty se cont) - = setSubstEnv se $ - simplType to_ty `thenSmpl` \ to_ty' -> - do_rebuild (mk_coerce to_ty' expr) cont - where - mk_coerce to_ty' (Note (Coerce _ from_ty) expr) = Note (Coerce to_ty' from_ty) expr - mk_coerce to_ty' expr = Note (Coerce to_ty' (coreExprType expr)) expr - - ---------------------------------------------------------- --- Case of known constructor or literal - -do_rebuild expr@(Con con args) cont@(Select _ _ _ _ _) - | conOkForAlt con -- Knocks out PrimOps and NoRepLits - = knownCon expr con args cont +-- Inline continuation +rebuild expr (InlinePlease cont) + = rebuild (Note InlineCall expr) cont - ---------------------------------------------------------- - --- Case of other value (e.g. a partial application or lambda) --- Turn it back into a let - -do_rebuild expr (Select _ bndr ((DEFAULT, bs, rhs):alts) se cont) - | case mkFormSummary expr of { ValueForm -> True; other -> False } - = ASSERT( null bs && null alts ) - tick Case2Let `thenSmpl_` - setSubstEnv se ( - completeBindNonRec bndr expr $ - simplExprB rhs cont - ) - - ---------------------------------------------------------- --- The other Select cases - -do_rebuild scrut (Select _ bndr alts se cont) - = getSwitchChecker `thenSmpl` \ chkr -> - - if all (cheapEqExpr rhs1) other_rhss - && inlineCase bndr scrut - && all binders_unused alts - && switchIsOn chkr SimplDoCaseElim - then - -- Get rid of the case altogether - -- See the extensive notes on case-elimination below - -- Remember to bind the binder though! - tick CaseElim `thenSmpl_` - setSubstEnv se ( - extendIdSubst bndr (Done scrut) $ - simplExprB rhs1 cont - ) - - else - rebuild_case chkr scrut bndr alts se cont - where - (rhs1:other_rhss) = [rhs | (_,_,rhs) <- alts] - binders_unused (_, bndrs, _) = all isDeadBinder bndrs +rebuild scrut (Select _ bndr alts se cont) + = rebuild_case scrut bndr alts se cont \end{code} Case elimination [see the code above] @@ -1219,135 +1094,138 @@ So the case-elimination algorithm is: If so, then we can replace the case with one of the rhss. +Blob of helper functions for the "case-of-something-else" situation. + \begin{code} --------------------------------------------------------- --- Rebuiling a function with strictness info - -rebuild_strict :: [Demand] -> Bool -- Stricness info - -> OutExpr -> OutType -- Function and type - -> SimplCont -- Continuation - -> SimplM OutExprStuff - -rebuild_strict [] True fun fun_ty cont = rebuild_bot fun fun_ty cont -rebuild_strict [] False fun fun_ty cont = do_rebuild fun cont +-- Eliminate the case if possible -rebuild_strict ds result_bot fun fun_ty (ApplyTo _ (Type ty_arg) se cont) - -- Type arg; don't consume a demand - = setSubstEnv se (simplType ty_arg) `thenSmpl` \ ty_arg' -> - rebuild_strict ds result_bot (App fun (Type ty_arg')) - (applyTy fun_ty ty_arg') cont +rebuild_case scrut bndr alts se cont + | maybeToBool maybe_con_app + = knownCon scrut (DataAlt con) args bndr alts se cont -rebuild_strict (d:ds) result_bot fun fun_ty (ApplyTo _ val_arg se cont) - | isStrict d || isUnLiftedType arg_ty -- Strict value argument - = getInScope `thenSmpl` \ in_scope -> - let - cont_ty = contResultType in_scope res_ty cont - in - setSubstEnv se (simplExprB val_arg (ArgOf NoDup cont_fn cont_ty)) + | 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 -- Lazy value argument - = setSubstEnv se (simplArg val_arg) `thenSmpl` \ val_arg' -> - cont_fn val_arg' + | otherwise + = complete_case scrut bndr alts se cont - where - Just (arg_ty, res_ty) = splitFunTy_maybe fun_ty - cont_fn arg' = rebuild_strict ds result_bot - (App fun arg') res_ty - 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 + ) -rebuild_strict ds result_bot fun fun_ty cont = do_rebuild fun cont + where + (rhs1:other_rhss) = rhssOfAlts alts + binders_unused (_, bndrs, _) = all isDeadBinder bndrs ---------------------------------------------------------- --- Dealing with --- * case (error "hello") of { ... } --- * (error "Hello") arg --- etc - -rebuild_bot expr expr_ty Stop -- No coerce needed - = rebuild_done expr - -rebuild_bot expr expr_ty (CoerceIt _ to_ty se Stop) -- Don't "tick" on this, - -- else simplifier never stops - = setSubstEnv se $ - simplType to_ty `thenSmpl` \ to_ty' -> - rebuild_done (mkNote (Coerce to_ty' expr_ty) expr) - -rebuild_bot expr expr_ty cont - = tick CaseOfError `thenSmpl_` - getInScope `thenSmpl` \ in_scope -> - let - result_ty = contResultType in_scope expr_ty cont - in - rebuild_done (mkNote (Coerce result_ty expr_ty) expr) -\end{code} + var_demanded_later (Var v) = isStrict (idDemandInfo bndr) -- It's going to be evaluated later + var_demanded_later other = False -Blob of helper functions for the "case-of-something-else" situation. -\begin{code} --------------------------------------------------------- -- Case of something else -rebuild_case sw_chkr scrut case_bndr alts se cont +complete_case scrut case_bndr alts se cont = -- Prepare case alternatives - prepareCaseAlts (splitTyConApp_maybe (idType case_bndr)) - scrut_cons alts `thenSmpl` \ better_alts -> + 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 $ -- Deal with the case binder, and prepare the continuation; -- The new subst_env is in place - simplBinder case_bndr $ \ case_bndr' -> prepareCaseCont better_alts cont $ \ cont' -> -- Deal with variable scrutinee - substForVarScrut scrut case_bndr' $ \ zap_occ_info -> - let - case_bndr'' = zap_occ_info case_bndr' - in + ( + getSwitchChecker `thenSmpl` \ chkr -> + simplCaseBinder (switchIsOn chkr NoCaseOfCase) + scrut case_bndr $ \ case_bndr' zap_occ_info -> + + -- Deal with the case alternatives + simplAlts zap_occ_info impossible_cons + case_bndr' better_alts cont' `thenSmpl` \ alts' -> - -- Deal with the case alternaatives - simplAlts zap_occ_info scrut_cons - case_bndr'' better_alts cont' `thenSmpl` \ alts' -> + mkCase scrut case_bndr' alts' + ) `thenSmpl` \ case_expr -> - mkCase sw_chkr scrut case_bndr'' alts' `thenSmpl` \ case_expr -> + -- Notice that the simplBinder, prepareCaseCont, etc, do *not* scope + -- over the rebuild_done; rebuild_done returns the in-scope set, and + -- that should not include these chaps! rebuild_done case_expr where - -- scrut_cons tells what constructors the scrutinee can't possibly match - scrut_cons = case scrut of - Var v -> case getIdUnfolding v of - OtherCon cons -> cons - other -> [] - other -> [] - - -knownCon expr con args (Select _ bndr alts se cont) - = tick KnownBranch `thenSmpl_` - setSubstEnv se ( + 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 ) - completeBindNonRec bndr expr $ - simplExprB rhs cont - - (Literal lit, bs, rhs) -> ASSERT( null bs ) - extendIdSubst bndr (Done expr) $ - -- Unconditionally substitute, because expr must - -- be a variable or a literal. It can't be a - -- NoRep literal because they don't occur in - -- case patterns. - simplExprB rhs cont - - (DataCon dc, bs, rhs) -> completeBindNonRec bndr expr $ - extend bs real_args $ - simplExprB rhs cont + 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 + real_args = drop (dataConNumInstArgs dc) args + mk (Type ty) = DoneTy ty + mk other = DoneEx other ) - where - extend [] [] thing_inside = thing_inside - extend (b:bs) (arg:args) thing_inside = extendIdSubst b (Done arg) $ - extend bs args thing_inside \end{code} \begin{code} @@ -1357,12 +1235,29 @@ prepareCaseCont :: [InAlt] -> SimplCont -- Polymorphic recursion here! prepareCaseCont [alt] cont thing_inside = thing_inside cont -prepareCaseCont alts cont thing_inside = mkDupableCont (coreAltsType alts) cont thing_inside +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} -substForVarScrut checks whether the scrutinee is a variable, v. -If so, try to eliminate uses of v in the RHSs in favour of case_bndr; -that way, there's a chance that v will now only be used once, and hence inlined. +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 + 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 @@ -1374,23 +1269,26 @@ variables! Example: Here, b and p are dead. But when we move the argment inside the first case RHS, and eliminate the second case, we get - case x or { (a,b) -> a b + case x or { (a,b) -> a b } Urk! b is alive! Reason: the scrutinee was a variable, and case elimination -happened. Hence the zap_occ_info function returned by substForVarScrut +happened. Hence the zap_occ_info function returned by simplCaseBinder \begin{code} -substForVarScrut (Var v) case_bndr' thing_inside - | isLocallyDefined v -- No point for imported things - = modifyInScope (v `setIdUnfolding` mkUnfolding (Var case_bndr') - `setInlinePragma` IMustBeINLINEd) $ +simplCaseBinder 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. - thing_inside (\ bndr -> bndr `setInlinePragma` NoInlinePragInfo) + -- any more (v is an OutId). And this just just as well. + thing_inside case_bndr' zap + where + zap b = b `setIdOccInfo` NoOccInfo -substForVarScrut other_scrut case_bndr' thing_inside - = thing_inside (\ bndr -> bndr) -- NoOp on bndr +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: @@ -1407,12 +1305,12 @@ prepareCaseAlts does two things: when rhs also scrutinises x or e. \begin{code} -prepareCaseAlts (Just (tycon, inst_tys)) scrut_cons alts +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 `thenSmpl_` + -> tick (FillInCaseDefault bndr) `thenSmpl_` let (_,_,ex_tyvars,_,_,_) = dataConSig data_con in @@ -1420,11 +1318,11 @@ prepareCaseAlts (Just (tycon, inst_tys)) scrut_cons alts 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 (dataConArgTys - data_con - (inst_tys ++ mkTyVarTys ex_tyvars')) $ \ bndrs -> - returnSmpl ((DataCon data_con, ex_tyvars' ++ bndrs, rhs) : alts_no_deflt) + newIds SLIT("a") arg_tys $ \ bndrs -> + returnSmpl ((DataAlt data_con, ex_tyvars' ++ bndrs, rhs) : alts_no_deflt) other -> returnSmpl filtered_alts where @@ -1433,46 +1331,49 @@ prepareCaseAlts (Just (tycon, inst_tys)) scrut_cons alts [] -> alts other -> [alt | alt@(con,_,_) <- alts, not (con `elem` scrut_cons)] - missing_cons = [data_con | data_con <- tyConDataCons tycon, + missing_cons = [data_con | data_con <- tyConDataConsIfAvailable tycon, not (data_con `elem` handled_data_cons)] - handled_data_cons = [data_con | DataCon data_con <- scrut_cons] ++ - [data_con | (DataCon data_con, _, _) <- filtered_alts] + handled_data_cons = [data_con | DataAlt data_con <- scrut_cons] ++ + [data_con | (DataAlt data_con, _, _) <- filtered_alts] -- The default case -prepareCaseAlts _ scrut_cons alts +prepareCaseAlts _ _ scrut_cons alts = returnSmpl alts -- Functions ---------------------- -simplAlts zap_occ_info scrut_cons case_bndr'' alts cont' +simplAlts zap_occ_info scrut_cons case_bndr' alts cont' = mapSmpl simpl_alt alts where - inst_tys' = case splitTyConApp_maybe (idType case_bndr'') of - Just (tycon, inst_tys) -> inst_tys + 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) - = modifyInScope (case_bndr'' `setIdUnfolding` OtherCon handled_cons) $ - simplExpr rhs cont' `thenSmpl` \ 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 case-bound variables + = -- Deal with the pattern-bound variables -- Mark the ones that are in ! positions in the data constructor - -- as certainly-evaluated - simplBinders (add_evals con vs) $ \ vs' -> + -- as certainly-evaluated. + -- NB: it happens that simplBinders does *not* erase the OtherCon + -- form of unfolding, so it's ok to add this info before + -- doing simplBinders + simplBinders (add_evals con vs) $ \ vs' -> - -- Bind the case-binder to (Con args) - -- In the default case we record the constructors it *can't* be. - -- We take advantage of any OtherCon info in the case scrutinee + -- Bind the case-binder to (con args) let - con_app = Con con (map Type inst_tys' ++ map varToCoreExpr vs') + unfolding = mkUnfolding False (mkAltExpr con vs' inst_tys') in - modifyInScope (case_bndr'' `setIdUnfolding` mkUnfolding con_app) $ - simplExpr rhs cont' `thenSmpl` \ rhs' -> + modifyInScope case_bndr' (case_bndr' `setIdUnfolding` unfolding) $ + simplExprC rhs cont' `thenSmpl` \ rhs' -> returnSmpl (con, vs', rhs') @@ -1483,20 +1384,21 @@ simplAlts zap_occ_info scrut_cons case_bndr'' alts cont' -- case x of { T a b -> T (a+1) b } -- -- We really must record that b is already evaluated so that we don't - -- go and re-evaluated it when constructing the result. + -- go and re-evaluate it when constructing the result. - add_evals (DataCon dc) vs = stretchZipEqual add_eval vs (dataConStrictMarks dc) + add_evals (DataAlt dc) vs = cat_evals vs (dataConRepStrictness dc) add_evals other_con vs = vs - add_eval v m | isTyVar v = Nothing - | otherwise = case m of - MarkedStrict -> Just (zap_occ_info v `setIdUnfolding` OtherCon []) - NotMarkedStrict -> Just (zap_occ_info v) + cat_evals [] [] = [] + cat_evals (v:vs) (str:strs) + | isTyVar v = v : cat_evals vs (str:strs) + | isStrict str = (v' `setIdUnfolding` mkOtherCon []) : cat_evals vs strs + | otherwise = v' : cat_evals vs strs + where + v' = zap_occ_info v \end{code} - - %************************************************************************ %* * \subsection{Duplicating continuations} @@ -1504,7 +1406,7 @@ simplAlts zap_occ_info scrut_cons case_bndr'' alts cont' %************************************************************************ \begin{code} -mkDupableCont :: InType -- Type of the thing to be given to the continuation +mkDupableCont :: OutType -- Type of the thing to be given to the continuation -> SimplCont -> (SimplCont -> SimplM (OutStuff a)) -> SimplM (OutStuff a) @@ -1512,76 +1414,116 @@ mkDupableCont ty cont thing_inside | contIsDupable cont = thing_inside cont -mkDupableCont _ (CoerceIt _ ty se cont) thing_inside +mkDupableCont _ (CoerceIt ty cont) thing_inside = mkDupableCont ty cont $ \ cont' -> - thing_inside (CoerceIt OkToDup ty se cont') + thing_inside (CoerceIt ty cont') -mkDupableCont join_arg_ty (ArgOf _ cont_fn res_ty) thing_inside +mkDupableCont ty (InlinePlease cont) thing_inside + = mkDupableCont ty cont $ \ cont' -> + thing_inside (InlinePlease cont') + +mkDupableCont join_arg_ty (ArgOf _ cont_ty cont_fn) thing_inside = -- Build the RHS of the join point - simplType join_arg_ty `thenSmpl` \ join_arg_ty' -> - newId join_arg_ty' ( \ arg_id -> - getSwitchChecker `thenSmpl` \ chkr -> + newId SLIT("a") join_arg_ty ( \ arg_id -> cont_fn (Var arg_id) `thenSmpl` \ (binds, (_, rhs)) -> - returnSmpl (Lam arg_id (mkLetBinds binds rhs)) + returnSmpl (Lam (setOneShotLambda arg_id) (mkLets binds rhs)) ) `thenSmpl` \ join_rhs -> -- Build the join Id and continuation - newId (coreExprType join_rhs) $ \ join_id -> + -- 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 - new_cont = ArgOf OkToDup + new_cont = ArgOf OkToDup cont_ty (\arg' -> rebuild_done (App (Var join_id) arg')) - res_ty in - - -- Do the thing inside - thing_inside new_cont `thenSmpl` \ res -> - returnSmpl (addBind (NonRec join_id join_rhs) res) + + 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 (simplArg arg) `thenSmpl` \ arg' -> + setSubstEnv se (simplExpr arg) `thenSmpl` \ arg' -> if exprIsDupable arg' then thing_inside (ApplyTo OkToDup arg' emptySubstEnv cont') else - newId (coreExprType arg') $ \ bndr -> - thing_inside (ApplyTo OkToDup (Var bndr) emptySubstEnv cont') `thenSmpl` \ res -> - returnSmpl (addBind (NonRec bndr arg') res) + newId SLIT("a") (exprType arg') $ \ bndr -> -mkDupableCont ty (Select _ case_bndr alts se cont) thing_inside - = tick CaseOfCase `thenSmpl_` ( - setSubstEnv se ( - simplBinder case_bndr $ \ case_bndr' -> - prepareCaseCont alts cont $ \ cont' -> - mapAndUnzipSmpl (mkDupableAlt case_bndr' cont') alts `thenSmpl` \ (alt_binds_s, alts') -> - returnSmpl (concat alt_binds_s, (case_bndr', alts')) - ) `thenSmpl` \ (alt_binds, (case_bndr', alts')) -> - - extendInScopes [b | NonRec b _ <- alt_binds] $ - thing_inside (Select OkToDup case_bndr' alts' emptySubstEnv Stop) `thenSmpl` \ res -> - returnSmpl (addBinds alt_binds res) - ) + 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. -mkDupableAlt :: OutId -> SimplCont -> InAlt -> SimplM (OutStuff CoreAlt) -mkDupableAlt case_bndr' cont alt@(con, bndrs, rhs) + 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' -> - simplExpr rhs cont `thenSmpl` \ rhs' -> - if exprIsDupable rhs' then - -- It's small, so don't bother to let-bind it - returnSmpl ([], (con, bndrs', rhs')) + 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 - -- It's big, so let-bind it let - rhs_ty' = coreExprType rhs' - used_bndrs' = filter (not . isDeadBinder) (case_bndr' : bndrs') + 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' && isUnLiftedType rhs_ty' - then newId realWorldStatePrimTy $ \ rw_id -> - returnSmpl ([rw_id], [varToCoreExpr realWorldPrimId]) - else - returnSmpl (used_bndrs', map varToCoreExpr used_bndrs') - ) - `thenSmpl` \ (final_bndrs', final_args) -> - + ( if 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 @@ -1593,7 +1535,53 @@ mkDupableAlt case_bndr' cont alt@(con, bndrs, rhs) -- case_bndr to all the join points if it's used in *any* RHS, -- because we don't know its usage in each RHS separately - newId (foldr (mkFunTy . idType) rhs_ty' final_bndrs') $ \ join_bndr -> - returnSmpl ([NonRec join_bndr (mkLams final_bndrs' rhs')], - (con, bndrs', mkApps (Var join_bndr) final_args)) + -- We used to say "&& isUnLiftedType rhs_ty'" here, but now + -- we make the join point into a function whenever used_bndrs' + -- is empty. This makes the join-point more CPR friendly. + -- Consider: let j = if .. then I# 3 else I# 4 + -- in case .. of { A -> j; B -> j; C -> ... } + -- + -- Now CPR 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}