From fa1c8a7e7013b1e9a37326b80abadec737c9347e Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Thu, 7 Feb 2008 15:51:02 +0000 Subject: [PATCH] Redo inlining patch, plus some tidying up This adds back in the patch * UNDO: Be a little keener to inline It originally broke the compiler because it tickled a Cmm optimisation bug, now fixed. In revisiting this I have also make inlining a bit cleverer, in response to more examples from Roman. In particular * CoreUnfold.CallCtxt is a data type that tells something about the context of a call. The new feature is that if the context is the argument position of a function call, we record both - whether the function (or some higher up function) has rules - what the argument discount in that position is Either of these make functions keener to inline, even if it's in a lazy position * There was conseqential tidying up on the data type of CallCont. In particular I got rid of the now-unused LetRhsFlag --- compiler/coreSyn/CoreUnfold.lhs | 39 +++++++------ compiler/simplCore/SimplUtils.lhs | 114 +++++++++++++++++++++---------------- compiler/simplCore/Simplify.lhs | 23 +++++--- 3 files changed, 101 insertions(+), 75 deletions(-) diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index 1bc945d..7670060 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -27,7 +27,7 @@ module CoreUnfold ( couldBeSmallEnoughToInline, certainlyWillInline, smallEnoughToInline, - callSiteInline, CallContInfo(..) + callSiteInline, CallCtxt(..) ) where @@ -513,19 +513,25 @@ callSiteInline :: DynFlags -> Id -- The Id -> Bool -- True if there are are no arguments at all (incl type args) -> [Bool] -- One for each value arg; True if it is interesting - -> CallContInfo -- True <=> continuation is interesting + -> CallCtxt -- True <=> continuation is interesting -> Maybe CoreExpr -- Unfolding, if any -data CallContInfo = BoringCont - | InterestingCont -- Somewhat interesting - | CaseCont -- Very interesting; the argument of a case - -- that decomposes its scrutinee +data CallCtxt = BoringCtxt -instance Outputable CallContInfo where - ppr BoringCont = ptext SLIT("BoringCont") - ppr InterestingCont = ptext SLIT("InterestingCont") - ppr CaseCont = ptext SLIT("CaseCont") + | ArgCtxt Bool -- We're somewhere in the RHS of function with rules + -- => be keener to inline + Int -- We *are* the argument of a function with this arg discount + -- => be keener to inline + -- INVARIANT: ArgCtxt False 0 ==> BoringCtxt + + | CaseCtxt -- We're the scrutinee of a case + -- that decomposes its scrutinee + +instance Outputable CallCtxt where + ppr BoringCtxt = ptext SLIT("BoringCtxt") + ppr (ArgCtxt _ _) = ptext SLIT("ArgCtxt") + ppr CaseCtxt = ptext SLIT("CaseCtxt") callSiteInline dflags active_inline id lone_variable arg_infos cont_info = case idUnfolding id of { @@ -588,17 +594,18 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info interesting_saturated_call = case cont_info of - BoringCont -> not is_top && n_vals_wanted > 0 -- Note [Nested functions] - CaseCont -> not lone_variable || not is_value -- Note [Lone variables] - InterestingCont -> n_vals_wanted > 0 + BoringCtxt -> not is_top && n_vals_wanted > 0 -- Note [Nested functions] + CaseCtxt -> not lone_variable || not is_value -- Note [Lone variables] + ArgCtxt {} -> True + -- Was: n_vals_wanted > 0; but see test eyeball/inline1.hs small_enough = (size - discount) <= opt_UF_UseThreshold discount = computeDiscount n_vals_wanted arg_discounts res_discount' arg_infos res_discount' = case cont_info of - BoringCont -> 0 - CaseCont -> res_discount - InterestingCont -> 4 `min` res_discount + BoringCtxt -> 0 + CaseCtxt -> res_discount + ArgCtxt _ _ -> 4 `min` res_discount -- res_discount can be very large when a function returns -- construtors; but we only want to invoke that large discount -- when there's a case continuation. diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 6739aaf..724612e 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -20,7 +20,7 @@ module SimplUtils ( activeInline, activeRule, inlineMode, -- The continuation type - SimplCont(..), DupFlag(..), LetRhsFlag(..), + SimplCont(..), DupFlag(..), ArgInfo(..), contIsDupable, contResultType, contIsTrivial, contArgs, dropArgs, countValArgs, countArgs, splitInlineCont, mkBoringStop, mkLazyArgStop, mkRhsStop, contIsRhsOrArg, @@ -93,8 +93,7 @@ Key points: data SimplCont = Stop -- An empty context, or hole, [] OutType -- Type of the result - LetRhsFlag - Bool -- True <=> There is something interesting about + CallCtxt -- True <=> There is something interesting about -- the context, and hence the inliner -- should be a bit keener (see interestingCallContext) -- Specifically: @@ -123,22 +122,28 @@ data SimplCont | StrictArg -- e C OutExpr OutType -- e and its type - (Bool,[Bool]) -- Whether the function at the head of e has rules, - SimplCont -- plus strictness flags for further args - -data LetRhsFlag = AnArg -- It's just an argument not a let RHS - | AnRhs -- It's the RHS of a let (so please float lets out of big lambdas) - -instance Outputable LetRhsFlag where - ppr AnArg = ptext SLIT("arg") - ppr AnRhs = ptext SLIT("rhs") + CallCtxt -- Whether *this* argument position is interesting + ArgInfo -- Whether the function at the head of e has rules, etc + SimplCont -- plus strictness flags for *further* args + +data ArgInfo + = ArgInfo { + ai_rules :: Bool, -- Function has rules (recursively) + -- => be keener to inline in all args + ai_strs :: [Bool], -- Strictness of arguments + -- Usually infinite, but if it is finite it guarantees + -- that the function diverges after being given + -- that number of args + ai_discs :: [Int] -- Discounts for arguments; non-zero => be keener to inline + -- Always infinite + } instance Outputable SimplCont where - ppr (Stop ty is_rhs _) = ptext SLIT("Stop") <> brackets (ppr is_rhs) <+> ppr ty + ppr (Stop ty _) = ptext SLIT("Stop") <+> ppr ty ppr (ApplyTo dup arg se cont) = ((ptext SLIT("ApplyTo") <+> ppr dup <+> pprParendExpr arg) {- $$ nest 2 (pprSimplEnv se) -}) $$ ppr cont ppr (StrictBind b _ _ _ cont) = (ptext SLIT("StrictBind") <+> ppr b) $$ ppr cont - ppr (StrictArg f _ _ cont) = (ptext SLIT("StrictArg") <+> ppr f) $$ ppr cont + ppr (StrictArg f _ _ _ cont) = (ptext SLIT("StrictArg") <+> ppr f) $$ ppr cont ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$ (nest 4 (ppr alts)) $$ ppr cont ppr (CoerceIt co cont) = (ptext SLIT("CoerceIt") <+> ppr co) $$ ppr cont @@ -153,13 +158,13 @@ instance Outputable DupFlag where ------------------- mkBoringStop :: OutType -> SimplCont -mkBoringStop ty = Stop ty AnArg False +mkBoringStop ty = Stop ty BoringCtxt -mkLazyArgStop :: OutType -> Bool -> SimplCont -mkLazyArgStop ty has_rules = Stop ty AnArg has_rules +mkLazyArgStop :: OutType -> CallCtxt -> SimplCont +mkLazyArgStop ty cci = Stop ty cci mkRhsStop :: OutType -> SimplCont -mkRhsStop ty = Stop ty AnRhs False +mkRhsStop ty = Stop ty BoringCtxt ------------------- contIsRhsOrArg (Stop {}) = True @@ -184,8 +189,8 @@ contIsTrivial other = False ------------------- contResultType :: SimplCont -> OutType -contResultType (Stop to_ty _ _) = to_ty -contResultType (StrictArg _ _ _ cont) = contResultType cont +contResultType (Stop to_ty _) = to_ty +contResultType (StrictArg _ _ _ _ cont) = contResultType cont contResultType (StrictBind _ _ _ _ cont) = contResultType cont contResultType (ApplyTo _ _ _ cont) = contResultType cont contResultType (CoerceIt _ cont) = contResultType cont @@ -226,9 +231,9 @@ splitInlineCont :: SimplCont -> Maybe (SimplCont, SimplCont) splitInlineCont (ApplyTo dup (Type ty) se c) | Just (c1, c2) <- splitInlineCont c = Just (ApplyTo dup (Type ty) se c1, c2) -splitInlineCont cont@(Stop ty _ _) = Just (mkBoringStop ty, cont) +splitInlineCont cont@(Stop ty _) = Just (mkBoringStop ty, cont) splitInlineCont cont@(StrictBind bndr _ _ se _) = Just (mkBoringStop (substTy se (idType bndr)), cont) -splitInlineCont cont@(StrictArg _ fun_ty _ _) = Just (mkBoringStop (funArgTy fun_ty), cont) +splitInlineCont cont@(StrictArg _ fun_ty _ _ _) = Just (mkBoringStop (funArgTy fun_ty), cont) splitInlineCont other = Nothing -- NB: the calculation of the type for mkBoringStop is an annoying -- duplication of the same calucation in mkDupableCont @@ -304,23 +309,26 @@ default case. \begin{code} -interestingCallContext :: SimplCont -> CallContInfo +interestingCallContext :: SimplCont -> CallCtxt interestingCallContext cont = interesting cont where + interestingCtxt = ArgCtxt False 2 -- Give *some* incentive! + interesting (Select _ bndr _ _ _) - | isDeadBinder bndr = CaseCont - | otherwise = InterestingCont + | isDeadBinder bndr = CaseCtxt + | otherwise = interestingCtxt - interesting (ApplyTo {}) = InterestingCont - -- Can happen if we have (coerce t (f x)) y - -- Perhaps True is a bit over-keen, but I've - -- seen (coerce f) x, where f has an INLINE prag, - -- So we have to give some motivation for inlining it - interesting (StrictArg {}) = InterestingCont - interesting (StrictBind {}) = InterestingCont - interesting (Stop ty _ yes) = if yes then InterestingCont else BoringCont - interesting (CoerceIt _ cont) = interesting cont + interesting (ApplyTo {}) = interestingCtxt + -- Can happen if we have (coerce t (f x)) y + -- Perhaps interestingCtxt is a bit over-keen, but I've + -- seen (coerce f) x, where f has an INLINE prag, + -- So we have to give some motivation for inlining it + + interesting (StrictArg _ _ cci _ _) = cci + interesting (StrictBind {}) = BoringCtxt + interesting (Stop ty cci) = cci + interesting (CoerceIt _ cont) = interesting cont -- If this call is the arg of a strict function, the context -- is a bit interesting. If we inline here, we may get useful -- evaluation information to avoid repeated evals: e.g. @@ -341,21 +349,24 @@ interestingCallContext cont mkArgInfo :: Id -> Int -- Number of value args -> SimplCont -- Context of the cal - -> (Bool, [Bool]) -- Arg info --- The arg info consists of --- * A Bool indicating if the function has rules (recursively) --- * A [Bool] indicating strictness for each arg --- The [Bool] is usually infinite, but if it is finite it --- guarantees that the function diverges after being given --- that number of args + -> ArgInfo mkArgInfo fun n_val_args call_cont - = (interestingArgContext fun call_cont, fun_stricts) + = ArgInfo { ai_rules = interestingArgContext fun call_cont + , ai_strs = arg_stricts + , ai_discs = arg_discounts } where - vanilla_stricts, fun_stricts :: [Bool] + vanilla_discounts, arg_discounts :: [Int] + vanilla_discounts = repeat 0 + arg_discounts = case idUnfolding fun of + CoreUnfolding _ _ _ _ (UnfoldIfGoodArgs _ discounts _ _) + -> discounts ++ vanilla_discounts + other -> vanilla_discounts + + vanilla_stricts, arg_stricts :: [Bool] vanilla_stricts = repeat False - fun_stricts + arg_stricts = case splitStrictSig (idNewStrictness fun) of (demands, result_info) | not (demands `lengthExceeds` n_val_args) @@ -394,12 +405,15 @@ interestingArgContext :: Id -> SimplCont -> Bool interestingArgContext fn call_cont = idHasRules fn || go call_cont where - go (Select {}) = False - go (ApplyTo {}) = False - go (StrictArg {}) = True - go (StrictBind {}) = False -- ?? - go (CoerceIt _ c) = go c - go (Stop _ _ interesting) = interesting + go (Select {}) = False + go (ApplyTo {}) = False + go (StrictArg _ _ cci _ _) = interesting cci + go (StrictBind {}) = False -- ?? + go (CoerceIt _ c) = go c + go (Stop _ cci) = interesting cci + + interesting (ArgCtxt rules _) = rules + interesting other = False \end{code} diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 693f1a2..2cdc44a 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -29,7 +29,7 @@ import DataCon ( dataConRepStrictness, dataConUnivTyVars ) import CoreSyn import NewDemand ( isStrictDmd ) import PprCore ( pprParendExpr, pprCoreExpr ) -import CoreUnfold ( mkUnfolding, callSiteInline ) +import CoreUnfold ( mkUnfolding, callSiteInline, CallCtxt(..) ) import CoreUtils import Rules ( lookupRule ) import BasicTypes ( isMarkedStrict ) @@ -764,7 +764,7 @@ rebuild env expr cont Stop {} -> return (env, expr) CoerceIt co cont -> rebuild env (mkCoerce co expr) cont Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont - StrictArg fun ty info cont -> rebuildCall env (fun `App` expr) (funResultTy ty) info cont + StrictArg fun ty _ info cont -> rebuildCall env (fun `App` expr) (funResultTy ty) info cont StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr ; simplLam env' bs body cont } ApplyTo _ arg se cont -> do { arg' <- simplExpr (se `setInScope` env) arg @@ -1054,10 +1054,10 @@ completeCall env var cont rebuildCall :: SimplEnv -> OutExpr -> OutType -- Function and its type - -> (Bool, [Bool]) -- See SimplUtils.mkArgInfo + -> ArgInfo -> SimplCont -> SimplM (SimplEnv, OutExpr) -rebuildCall env fun fun_ty (has_rules, []) cont +rebuildCall env fun fun_ty (ArgInfo { ai_strs = [] }) cont -- When we run out of strictness args, it means -- that the call is definitely bottom; see SimplUtils.mkArgInfo -- Then we want to discard the entire strict continuation. E.g. @@ -1080,11 +1080,13 @@ rebuildCall env fun fun_ty info (ApplyTo _ (Type arg_ty) se cont) = do { ty' <- simplType (se `setInScope` env) arg_ty ; rebuildCall env (fun `App` Type ty') (applyTy fun_ty ty') info cont } -rebuildCall env fun fun_ty (has_rules, str:strs) (ApplyTo _ arg arg_se cont) +rebuildCall env fun fun_ty + (ArgInfo { ai_rules = has_rules, ai_strs = str:strs, ai_discs = disc:discs }) + (ApplyTo _ arg arg_se cont) | str || isStrictType arg_ty -- Strict argument = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ simplExprF (arg_se `setFloats` env) arg - (StrictArg fun fun_ty (has_rules, strs) cont) + (StrictArg fun fun_ty cci arg_info' cont) -- Note [Shadowing] | otherwise -- Lazy argument @@ -1093,10 +1095,13 @@ rebuildCall env fun fun_ty (has_rules, str:strs) (ApplyTo _ arg arg_se cont) -- have to be very careful about bogus strictness through -- floating a demanded let. = do { arg' <- simplExprC (arg_se `setInScope` env) arg - (mkLazyArgStop arg_ty has_rules) - ; rebuildCall env (fun `App` arg') res_ty (has_rules, strs) cont } + (mkLazyArgStop arg_ty cci) + ; rebuildCall env (fun `App` arg') res_ty arg_info' cont } where (arg_ty, res_ty) = splitFunTy fun_ty + arg_info' = ArgInfo { ai_rules = has_rules, ai_strs = strs, ai_discs = discs } + cci | has_rules || disc > 0 = ArgCtxt has_rules disc -- Be keener here + | otherwise = BoringCtxt -- Nothing interesting rebuildCall env fun fun_ty info cont = rebuild env fun cont @@ -1752,7 +1757,7 @@ mkDupableCont env cont@(StrictBind bndr _ _ se _) = return (env, mkBoringStop (substTy se (idType bndr)), cont) -- See Note [Duplicating strict continuations] -mkDupableCont env cont@(StrictArg _ fun_ty _ _) +mkDupableCont env cont@(StrictArg _ fun_ty _ _ _) = return (env, mkBoringStop (funArgTy fun_ty), cont) -- See Note [Duplicating strict continuations] -- 1.7.10.4