From 5d89d8eb1712aba2226af68d10b04354cd939cc5 Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 1 Oct 2001 09:45:38 +0000 Subject: [PATCH] [project @ 2001-10-01 09:45:38 by simonpj] --------------------------- Match rules before inlining --------------------------- This commit fulfils a long-standing wish by Manuel that RULES matching occurs before inlining. So if a RULE matches, it'll get used, even if the function can also be inlined. It's a bit dodgy to actually rely on this, because maybe the rule doesn't match *yet* but will do after a bit more transformation. But it does help with things like class operations. Class ops are simply selectors which pick a method out of a dictionary, so they are inlined rather vigorously. But we might want a RULE for a class method (e.g. (==) [Char] = eqString), and such rules would practically never fire if inlining took priority. --- ghc/compiler/simplCore/SimplUtils.lhs | 54 +++++-------- ghc/compiler/simplCore/Simplify.lhs | 143 ++++++++++++++++++++------------- 2 files changed, 107 insertions(+), 90 deletions(-) diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 6ce4ada..afc53dc 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -12,9 +12,9 @@ module SimplUtils ( -- The continuation type SimplCont(..), DupFlag(..), LetRhsFlag(..), contIsDupable, contResultType, - countValArgs, countArgs, + countValArgs, countArgs, pushContArgs, mkBoringStop, mkStop, contIsRhs, contIsRhsOrArg, - getContArgs, interestingCallContext, interestingArg, isStrictType, discardInline + getContArgs, interestingCallContext, interestingArg, isStrictType ) where @@ -25,31 +25,25 @@ import CmdLineOpts ( SimplifierSwitch(..), opt_SimplCaseMerge, opt_UF_UpdateInPlace ) import CoreSyn -import CoreFVs ( exprSomeFreeVars, exprsSomeFreeVars ) -import CoreUtils ( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap, +import CoreUtils ( cheapEqExpr, exprType, etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce, findDefault, exprOkForSpeculation, exprIsValue ) -import Subst ( InScopeSet, mkSubst, substExpr ) import qualified Subst ( simplBndrs, simplBndr, simplLetId, simplLamBndr ) -import Id ( Id, idType, idName, +import Id ( Id, idType, idInfo, mkSysLocal, hasNoBinding, isDeadBinder, idNewDemandInfo, - idUnfolding, idNewStrictness, - mkLocalId, idInfo + idUnfolding, idNewStrictness ) -import Name ( setNameUnique ) import NewDemand ( isStrictDmd, isBotRes, splitStrictSig ) import SimplMonad -import Type ( Type, mkForAllTys, seqType, +import Type ( Type, seqType, splitTyConApp_maybe, tyConAppArgs, mkTyVarTys, - isUnLiftedType, splitRepFunTys, isStrictType + splitRepFunTys, isStrictType ) import OccName ( UserFS ) import TyCon ( tyConDataConsIfAvailable, isDataTyCon ) import DataCon ( dataConRepArity, dataConSig, dataConArgTys ) import Var ( mkSysTyVar, tyVarKind ) -import VarEnv ( SubstEnv ) -import VarSet ( mkVarSet, varSetElems, intersectVarSet ) import Util ( lengthExceeds, mapAccumL ) import Outputable \end{code} @@ -144,12 +138,6 @@ contIsDupable (InlinePlease cont) = contIsDupable cont contIsDupable other = False ------------------- -discardInline :: SimplCont -> SimplCont -discardInline (InlinePlease cont) = cont -discardInline (ApplyTo d e s cont) = ApplyTo d e s (discardInline cont) -discardInline cont = cont - -------------------- discardableCont :: SimplCont -> Bool discardableCont (Stop _ _ _) = False discardableCont (CoerceIt _ cont) = discardableCont cont @@ -182,6 +170,12 @@ countValArgs other = 0 countArgs :: SimplCont -> Int countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont countArgs other = 0 + +------------------- +pushContArgs :: SimplEnv -> [OutArg] -> SimplCont -> SimplCont +-- Pushes args with the specified environment +pushContArgs env [] cont = cont +pushContArgs env (arg : args) cont = ApplyTo NoDup arg env (pushContArgs env args cont) \end{code} @@ -269,25 +263,19 @@ getContArgs chkr fun orig_cont other -> vanilla_stricts -- Not enough args, or no strictness ------------------- -interestingArg :: InScopeSet -> InExpr -> SubstEnv -> Bool +interestingArg :: OutExpr -> Bool -- An argument is interesting if it has *some* structure -- We are here trying to avoid unfolding a function that -- is applied only to variables that have no unfolding -- (i.e. they are probably lambda bound): f x y z -- There is little point in inlining f here. -interestingArg in_scope arg subst - = analyse (substExpr (mkSubst in_scope subst) arg) - -- 'analyse' only looks at the top part of the result - -- and substExpr is lazy, so this isn't nearly as brutal - -- as it looks. - where - analyse (Var v) = hasSomeUnfolding (idUnfolding v) - -- Was: isValueUnfolding (idUnfolding v') - -- But that seems over-pessimistic - analyse (Type _) = False - analyse (App fn (Type _)) = analyse fn - analyse (Note _ a) = analyse a - analyse other = True +interestingArg (Var v) = hasSomeUnfolding (idUnfolding v) + -- Was: isValueUnfolding (idUnfolding v') + -- But that seems over-pessimistic +interestingArg (Type _) = False +interestingArg (App fn (Type _)) = interestingArg fn +interestingArg (Note _ a) = interestingArg a +interestingArg other = True -- Consider let x = 3 in f x -- The substitution will contain (x -> ContEx 3), and we want to -- to say that x is an interesting argument. diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 2bc7b8b..e966509 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -15,8 +15,8 @@ import SimplMonad import SimplUtils ( mkCase, mkLam, newId, simplBinder, simplLamBinders, simplBinders, simplRecIds, simplLetId, SimplCont(..), DupFlag(..), LetRhsFlag(..), - mkStop, mkBoringStop, - contResultType, discardInline, countArgs, contIsDupable, contIsRhsOrArg, + mkStop, mkBoringStop, pushContArgs, + contResultType, countArgs, contIsDupable, contIsRhsOrArg, getContArgs, interestingCallContext, interestingArg, isStrictType ) import Var ( mustHaveLocalBinding ) @@ -299,13 +299,8 @@ simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside simplLetId env bndr `thenSmpl` \ (env, bndr') -> simplStrictArg env AnRhs rhs rhs_se cont_ty $ \ env rhs1 -> - -- Make the arguments atomic if necessary, - -- adding suitable bindings - mkAtomicArgs True True rhs1 `thenSmpl` \ (aux_binds, rhs2) -> - addAtomicBindsE env aux_binds $ \ env -> - -- Now complete the binding and simplify the body - completeNonRecX env bndr bndr' rhs2 thing_inside + completeNonRecX env True {- strict -} bndr bndr' rhs1 thing_inside | otherwise -- Normal, lazy case = -- Don't use simplBinder because that doesn't keep @@ -340,16 +335,24 @@ simplNonRecX env bndr new_rhs thing_inside | otherwise = simplBinder env bndr `thenSmpl` \ (env, bndr') -> - completeNonRecX env bndr bndr' new_rhs thing_inside + completeNonRecX env False {- Non-strict; pessimistic -} + bndr bndr' new_rhs thing_inside -completeNonRecX env old_bndr new_bndr new_rhs thing_inside +completeNonRecX env is_strict old_bndr new_bndr new_rhs thing_inside | needsCaseBinding (idType new_bndr) new_rhs = thing_inside env `thenSmpl` \ (floats, body) -> returnSmpl (emptyFloats env, Case new_rhs new_bndr [(DEFAULT, [], wrapFloats floats body)]) | otherwise - = completeLazyBind env NotTopLevel - old_bndr new_bndr new_rhs `thenSmpl` \ (floats, env) -> + = mkAtomicArgs is_strict + True {- OK to float unlifted -} + new_rhs `thenSmpl` \ (aux_binds, rhs2) -> + + -- Make the arguments atomic if necessary, + -- adding suitable bindings + addAtomicBindsE env aux_binds $ \ env -> + completeLazyBind env NotTopLevel + old_bndr new_bndr rhs2 `thenSmpl` \ (floats, env) -> addFloats env floats thing_inside \end{code} @@ -700,7 +703,7 @@ simplType env ty simplLam env fun cont = go env fun cont where - zap_it = mkLamBndrZapper fun cont + zap_it = mkLamBndrZapper fun (countArgs cont) cont_ty = contResultType cont -- Type-beta reduction @@ -713,10 +716,8 @@ simplLam env fun cont -- Ordinary beta reduction go env (Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont) = tick (BetaReduction bndr) `thenSmpl_` - simplNonRecBind env zapped_bndr arg arg_se cont_ty $ \ env -> + simplNonRecBind env (zap_it bndr) arg arg_se cont_ty $ \ env -> go env body body_cont - where - zapped_bndr = zap_it bndr -- Not enough args, so there are real lambdas left to put in the result go env lam@(Lam _ _) cont @@ -732,16 +733,14 @@ simplLam env fun cont go env expr cont = simplExprF env expr cont mkLamBndrZapper :: CoreExpr -- Function - -> SimplCont -- The context + -> Int -- Number of args supplied, *including* type args -> Id -> Id -- Use this to zap the binders -mkLamBndrZapper fun cont +mkLamBndrZapper fun n_args | n_args >= n_params fun = \b -> b -- Enough args | otherwise = \b -> zapLamIdInfo b where -- NB: we count all the args incl type args -- so we must count all the binders (incl type lambdas) - n_args = countArgs cont - n_params (Note _ e) = n_params e n_params (Lam b e) = 1 + n_params e n_params other = 0::Int @@ -846,41 +845,16 @@ simplVar env var cont -- the inlined copy!! --------------------------------------------------------- --- Dealing with a call +-- Dealing with a call site completeCall env var occ_info cont - = getDOptsSmpl `thenSmpl` \ dflags -> + = -- Simplify the arguments + getDOptsSmpl `thenSmpl` \ dflags -> let - in_scope = getInScope env - chkr = getSwitchChecker env - + chkr = getSwitchChecker env (args, call_cont, inline_call) = getContArgs chkr var cont - - arg_infos = [ interestingArg in_scope arg (getSubstEnv arg_env) - | (arg, arg_env, _) <- args, isValArg arg] - - interesting_cont = interestingCallContext (not (null args)) - (not (null arg_infos)) - call_cont - - inline_cont | inline_call = discardInline cont - | otherwise = cont - - active_inline = activeInline env var - maybe_inline = callSiteInline dflags active_inline inline_call occ_info - 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 env unfolding inline_cont - - ; - Nothing -> -- No inlining! - - - simplifyArgs env args (contResultType call_cont) $ \ env args' -> + simplifyArgs env args (contResultType call_cont) $ \ env args -> -- Next, look for rules or specialisations that match -- @@ -892,9 +866,9 @@ completeCall env var occ_info cont -- 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. + -- We used to use the black-listing mechanism to ensure that inlining of + -- the wrapper didn't occur for things that have specialisations till a + -- later phase, so but now we just try RULES first -- -- You might think that we shouldn't apply rules for a loop breaker: -- doing so might give rise to an infinite loop, because a RULE is @@ -909,9 +883,10 @@ completeCall env var occ_info cont -- So it's up to the programmer: rules can cause divergence let + in_scope = getInScope env maybe_rule = case activeRule env of Nothing -> Nothing -- No rules apply - Just act_fn -> lookupRule act_fn in_scope var args' + Just act_fn -> lookupRule act_fn in_scope var args in case maybe_rule of { Just (rule_name, rule_rhs) -> @@ -919,7 +894,7 @@ completeCall env var occ_info cont (if dopt Opt_D_dump_inlinings dflags then pprTrace "Rule fired" (vcat [ text "Rule:" <+> ptext rule_name, - text "Before:" <+> ppr var <+> sep (map pprParendExpr args'), + text "Before:" <+> ppr var <+> sep (map pprParendExpr args), text "After: " <+> pprCoreExpr rule_rhs]) else id) $ @@ -927,9 +902,64 @@ completeCall env var occ_info cont Nothing -> -- No rules + -- Next, look for an inlining + let + arg_infos = [ interestingArg arg | arg <- args, isValArg arg] + + interesting_cont = interestingCallContext (not (null args)) + (not (null arg_infos)) + call_cont + + active_inline = activeInline env var + maybe_inline = callSiteInline dflags active_inline inline_call occ_info + var arg_infos interesting_cont + in + case maybe_inline of { + Just unfolding -- There is an inlining! + -> tick (UnfoldingDone var) `thenSmpl_` + makeThatCall env var unfolding args call_cont + + ; + Nothing -> -- No inlining! + -- Done - rebuild env (mkApps (Var var) args') call_cont + rebuild env (mkApps (Var var) args) call_cont }} + +makeThatCall :: SimplEnv + -> Id + -> InExpr -- Inlined function rhs + -> [OutExpr] -- Arguments, already simplified + -> SimplCont -- After the call + -> SimplM FloatsWithExpr +-- Similar to simplLam, but this time +-- the arguments are already simplified +makeThatCall orig_env var fun@(Lam _ _) args cont + = go orig_env fun args + where + zap_it = mkLamBndrZapper fun (length args) + + -- Type-beta reduction + go env (Lam bndr body) (Type ty_arg : args) + = ASSERT( isTyVar bndr ) + tick (BetaReduction bndr) `thenSmpl_` + go (extendSubst env bndr (DoneTy ty_arg)) body args + + -- Ordinary beta reduction + go env (Lam bndr body) (arg : args) + = tick (BetaReduction bndr) `thenSmpl_` + simplNonRecX env (zap_it bndr) arg $ \ env -> + go env body args + + -- Not enough args, so there are real lambdas left to put in the result + go env fun args + = simplExprF env fun (pushContArgs orig_env args cont) + -- NB: orig_env; the correct environment to capture with + -- the arguments.... env has been augmented with substitutions + -- from the beta reductions. + +makeThatCall env var fun args cont + = simplExprF env fun (pushContArgs env args cont) \end{code} @@ -1678,7 +1708,6 @@ mkDupableAlt env case_bndr' cont alt@(con, bndrs, 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 -- 1.7.10.4