From: simonpj@microsoft.com Date: Mon, 22 May 2006 16:32:55 +0000 (+0000) Subject: Inline in a call argument if the caller has RULES X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=a2c92cccbdfdf295901e6c367c35bd4b2b0288e0 Inline in a call argument if the caller has RULES This is an experimental change suggested by Roman. Consider {-# INLINE f #-} f x y = ... ....(g (f a b))... where g has RULES. Then we'd like to inline f, even though the context of the call is otherwise 100% boring -- g is lazy and we know nothing about x and y. This patch just records in the continuation that f has rules. And does so somewhat recursively...e.g. ...(g (h (f a b)))... where g has rules. --- diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 32ad40c..265ded6 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -15,8 +15,9 @@ module SimplUtils ( SimplCont(..), DupFlag(..), LetRhsFlag(..), contIsDupable, contResultType, countValArgs, countArgs, pushContArgs, - mkBoringStop, mkRhsStop, contIsRhs, contIsRhsOrArg, - getContArgs, interestingCallContext, interestingArg, isStrictType + mkBoringStop, mkLazyArgStop, mkRhsStop, contIsRhs, contIsRhsOrArg, + getContArgs, interestingCallContext, interestingArgContext, + interestingArg, isStrictType ) where @@ -29,16 +30,16 @@ import StaticFlags ( opt_UF_UpdateInPlace, opt_SimplNoPreInlining, opt_RulesOff ) import CoreSyn import CoreFVs ( exprFreeVars ) -import CoreUtils ( cheapEqExpr, exprType, exprIsTrivial, exprIsCheap, +import CoreUtils ( cheapEqExpr, exprType, exprIsTrivial, etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce2, findDefault, exprOkForSpeculation, exprIsHNF, mergeAlts ) import Literal ( mkStringLit ) import CoreUnfold ( smallEnoughToInline ) import MkId ( eRROR_ID ) -import Id ( idType, isDataConWorkId, idOccInfo, isDictId, +import Id ( Id, idType, isDataConWorkId, idOccInfo, isDictId, isDeadBinder, idNewDemandInfo, isExportedId, - idUnfolding, idNewStrictness, idInlinePragma, + idUnfolding, idNewStrictness, idInlinePragma, idHasRules ) import NewDemand ( isStrictDmd, isBotRes, splitStrictSig ) import SimplMonad @@ -63,11 +64,16 @@ import Outputable \begin{code} data SimplCont -- Strict contexts - = Stop OutType -- Type of the result + = Stop OutType -- Type of the result LetRhsFlag - Bool -- True <=> This is the RHS of a thunk whose type suggests - -- that update-in-place would be possible - -- (This makes the inliner a little keener.) + Bool -- True <=> There is something interesting about + -- the context, and hence the inliner + -- should be a bit keener (see interestingCallContext) + -- Two cases: + -- (a) This is the RHS of a thunk whose type suggests + -- that update-in-place would be possible + -- (b) This is an argument of a function that has RULES + -- Inlining the call might allow the rule to fire | CoerceIt OutType -- The To-type, simplified SimplCont @@ -86,7 +92,7 @@ data SimplCont -- Strict contexts | ArgOf LetRhsFlag -- An arbitrary strict context: the argument -- of a strict function, or a primitive-arg fn -- or a PrimOp - -- No DupFlag because we never duplicate it + -- No DupFlag, because we never duplicate it OutType -- arg_ty: type of the argument itself OutType -- cont_ty: the type of the expression being sought by the context -- f (error "foo") ==> coerce t (error "foo") @@ -120,9 +126,14 @@ instance Outputable DupFlag where ------------------- -mkBoringStop, mkRhsStop :: OutType -> SimplCont -mkBoringStop ty = Stop ty AnArg (canUpdateInPlace ty) -mkRhsStop ty = Stop ty AnRhs (canUpdateInPlace ty) +mkBoringStop :: OutType -> SimplCont +mkBoringStop ty = Stop ty AnArg False + +mkLazyArgStop :: OutType -> Bool -> SimplCont +mkLazyArgStop ty has_rules = Stop ty AnArg (canUpdateInPlace ty || has_rules) + +mkRhsStop :: OutType -> SimplCont +mkRhsStop ty = Stop ty AnRhs (canUpdateInPlace ty) contIsRhs :: SimplCont -> Bool contIsRhs (Stop _ AnRhs _) = True @@ -382,7 +393,7 @@ interestingCallContext some_args some_val_args cont -- seen (coerce f) x, where f has an INLINE prag, -- So we have to give some motivaiton for inlining it interesting (ArgOf _ _ _ _) = some_val_args - interesting (Stop ty _ upd_in_place) = some_val_args && upd_in_place + interesting (Stop ty _ interesting) = some_val_args && interesting 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 @@ -401,6 +412,33 @@ interestingCallContext some_args some_val_args cont ------------------- +interestingArgContext :: Id -> SimplCont -> Bool +-- If the argument has form (f x y), where x,y are boring, +-- and f is marked INLINE, then we don't want to inline f. +-- But if the context of the argument is +-- g (f x y) +-- where g has rules, then we *do* want to inline f, in case it +-- exposes a rule that might fire. Similarly, if the context is +-- h (g (f x x)) +-- where h has rules, then we do want to inline f. +-- The interesting_arg_ctxt flag makes this happen; if it's +-- set, the inliner gets just enough keener to inline f +-- regardless of how boring f's arguments are, if it's marked INLINE +-- +-- The alternative would be to *always* inline an INLINE function, +-- regardless of how boring its context is; but that seems overkill +-- For example, it'd mean that wrapper functions were always inlined +interestingArgContext fn cont + = idHasRules fn || go cont + where + go (InlinePlease c) = go c + go (Select {}) = False + go (ApplyTo {}) = False + go (ArgOf {}) = True + go (CoerceIt _ c) = go c + go (Stop _ _ interesting) = interesting + +------------------- canUpdateInPlace :: Type -> Bool -- Consider let x = in ... -- If returns an explicit constructor, we might be able diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index dd2a22b..329d326 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -15,11 +15,11 @@ import SimplMonad import SimplEnv import SimplUtils ( mkCase, mkLam, SimplCont(..), DupFlag(..), LetRhsFlag(..), - mkRhsStop, mkBoringStop, pushContArgs, + mkRhsStop, mkBoringStop, mkLazyArgStop, pushContArgs, contResultType, countArgs, contIsDupable, contIsRhsOrArg, getContArgs, interestingCallContext, interestingArg, isStrictType, preInlineUnconditionally, postInlineUnconditionally, - inlineMode, activeInline, activeRule + interestingArgContext, inlineMode, activeInline, activeRule ) import Id ( Id, idType, idInfo, idArity, isDataConWorkId, idUnfolding, setIdUnfolding, isDeadBinder, @@ -923,7 +923,8 @@ completeCall env var occ_info cont (args, call_cont, inline_call) = getContArgs chkr var cont fn_ty = idType var in - simplifyArgs env fn_ty args (contResultType call_cont) $ \ env args -> + simplifyArgs env fn_ty (interestingArgContext var call_cont) args + (contResultType call_cont) $ \ env args -> -- Next, look for rules or specialisations that match -- @@ -976,11 +977,9 @@ completeCall env var occ_info cont -- Next, look for an inlining let arg_infos = [ interestingArg arg | arg <- args, isValArg arg] - interesting_cont = interestingCallContext (notNull args) (notNull arg_infos) call_cont - active_inline = activeInline env var occ_info maybe_inline = callSiteInline dflags active_inline inline_call occ_info var arg_infos interesting_cont @@ -1053,6 +1052,7 @@ makeThatCall env var fun args cont simplifyArgs :: SimplEnv -> OutType -- Type of the function + -> Bool -- True if the fn has RULES -> [(InExpr, SimplEnv, Bool)] -- Details of the arguments -> OutType -- Type of the continuation -> (SimplEnv -> [OutExpr] -> SimplM FloatsWithExpr) @@ -1083,19 +1083,19 @@ simplifyArgs :: SimplEnv -- discard the entire application and replace it with (error "foo"). Getting -- all this at once is TOO HARD! -simplifyArgs env fn_ty args cont_ty thing_inside +simplifyArgs env fn_ty has_rules args cont_ty thing_inside = go env fn_ty args thing_inside where go env fn_ty [] thing_inside = thing_inside env [] - go env fn_ty (arg:args) thing_inside = simplifyArg env fn_ty arg cont_ty $ \ env arg' -> + go env fn_ty (arg:args) thing_inside = simplifyArg env fn_ty has_rules arg cont_ty $ \ env arg' -> go env (applyTypeToArg fn_ty arg') args $ \ env args' -> thing_inside env (arg':args') -simplifyArg env fn_ty (Type ty_arg, se, _) cont_ty thing_inside +simplifyArg env fn_ty has_rules (Type ty_arg, se, _) cont_ty thing_inside = simplType (setInScope se env) ty_arg `thenSmpl` \ new_ty_arg -> thing_inside env (Type new_ty_arg) -simplifyArg env fn_ty (val_arg, arg_se, is_strict) cont_ty thing_inside +simplifyArg env fn_ty has_rules (val_arg, arg_se, is_strict) cont_ty thing_inside | is_strict = simplStrictArg AnArg env val_arg arg_se arg_ty cont_ty thing_inside @@ -1105,8 +1105,8 @@ simplifyArg env fn_ty (val_arg, arg_se, is_strict) cont_ty thing_inside -- have to be very careful about bogus strictness through -- floating a demanded let. = simplExprC (setInScope arg_se env) val_arg - (mkBoringStop arg_ty) `thenSmpl` \ arg1 -> - thing_inside env arg1 + (mkLazyArgStop arg_ty has_rules) `thenSmpl` \ arg1 -> + thing_inside env arg1 where arg_ty = funArgTy fn_ty