[Git][ghc/ghc][wip/andreask/deep_discounts] Add a depth discount to nested argInfo/argGuidance
Andreas Klebinger (@AndreasK)
gitlab at gitlab.haskell.org
Sun Aug 7 20:06:50 UTC 2022
Andreas Klebinger pushed to branch wip/andreask/deep_discounts at Glasgow Haskell Compiler / GHC
Commits:
505d309c by Andreas Klebinger at 2022-08-07T22:06:19+02:00
Add a depth discount to nested argInfo/argGuidance
- - - - -
5 changed files:
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Unfold.hs
- compiler/GHC/Driver/Session.hs
- docs/users_guide/hints.rst
- docs/users_guide/using-optimisation.rst
Changes:
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -877,45 +877,59 @@ rule for (*) (df d) can fire. To do this
interestingArg :: SimplEnv -> CoreExpr -> ArgSummary
-- See Note [Interesting arguments]
interestingArg env e =
- -- pprTrace "interestingArg" (ppr e $$ ppr (go env 0 e)) $
- go env 0 e
- where
+ go env depth_limit 0 e
+ where
+ depth_limit = unfoldingMaxAppDepth . sm_uf_opts . seMode $ env
+
-- n is # value args to which the expression is applied
- go env n (Var v)
+ go :: SimplEnv -> Int -> Int -> CoreExpr -> ArgSummary
+ go _env 0 _n !_ = TrivArg
+ go env depth n (Var v)
= case substId env v of
- DoneId v' -> go_var n v'
- DoneEx e _ -> go (zapSubstEnv env) n e
- ContEx tvs cvs ids e -> go (setSubstEnv env tvs cvs ids) n e
+ DoneId v' -> go_var depth n v'
+ DoneEx e _ -> go (zapSubstEnv env) depth n e
+ ContEx tvs cvs ids e -> go (setSubstEnv env tvs cvs ids) depth n e
- go _ _ (Lit l)
+ go _ _depth _ (Lit l)
| isLitRubbish l = TrivArg -- Leads to unproductive inlining in WWRec, #20035
| otherwise = ValueArg
- go _ _ (Type _) = TrivArg
- go _ _ (Coercion _) = TrivArg
- go env n (App fn (Type _)) = go env n fn
- go env n (App fn arg)
- | ConArg con args <- fn_summary
- = if (isClassTyCon $ dataConTyCon con)
- then ValueArg
- else ConArg con (args ++ [go env 0 arg])
- | otherwise = fn_summary
- where
- fn_summary = go env (n+1) fn
-
- go env n (Tick _ a) = go env n a
- go env n (Cast e _) = go env n e
- go env n (Lam v e)
- | isTyVar v = go env n e
+ go _ _depth _ (Type _) = TrivArg
+ go _ _depth _ (Coercion _) = TrivArg
+ go env depth n (App fn (Type _)) = go env depth n fn
+ go env depth n e@(App _fn _arg)
+ | (fn,args,_ticks) <- collectArgsTicks (const True) e
+ = let args' = filter isValArg args
+ fn_summary = go env depth (n + length args') fn
+ arg_summaries = map (go env (depth-1) 0) args'
+ in case fn_summary of
+ ConArg con fn_args
+ | isClassTyCon (dataConTyCon con) -> ValueArg
+ | otherwise -> ConArg con (fn_args ++ arg_summaries)
+ _ -> fn_summary
+
+ -- | ConArg con args <- fn_summary
+ -- = if (isClassTyCon $ dataConTyCon con)
+ -- then ValueArg
+ -- else ConArg con (args ++ [go env (depth-1) 0 arg])
+ -- | otherwise = fn_summary
+ -- where
+ -- fn_summary = go env (depth-1) (n+1) fn
+
+ go env depth n (Tick _ a) = go env depth n a
+ go env depth n (Cast e _) = go env depth n e
+ go env depth n (Lam v e)
+ | isTyVar v = go env depth n e
| n>0 = NonTrivArg -- (\x.b) e is NonTriv
| otherwise = ValueArg
- go _ _ (Case {}) = NonTrivArg
- go env n (Let b e) = case go env' n e of
+ go _ _depth _ (Case {}) = NonTrivArg
+ go env depth n (Let b e) = case go env' depth n e of
ValueArg -> ValueArg
+ c at ConArg{} -> c
_ -> NonTrivArg
where
env' = env `addNewInScopeIds` bindersOf b
- go_var n v
+ go_var depth n v
| Just rhs <- maybeUnfoldingTemplate (idUnfolding v)
, (f, args, _ticks) <- collectArgsTicks (const True) rhs
, Var f' <- varView f
@@ -923,7 +937,7 @@ interestingArg env e =
, not (isClassTyCon $ dataConTyCon con)
=
-- pprTrace "ConArg1" (ppr $ ConArg con $ map (go env 0) args) $
- ConArg con $ map (go env 0) args
+ ConArg con $ map (go env (depth-1) 0) args
| Just con <- isDataConId_maybe v
= ConArg con []
=====================================
compiler/GHC/Core/Unfold.hs
=====================================
@@ -26,6 +26,7 @@ module GHC.Core.Unfold (
updateFunAppDiscount, updateDictDiscount,
updateVeryAggressive, updateCaseScaling,
updateCaseThreshold, updateReportPrefix,
+ updateMaxAppDepth, updateMaxGuideDepth,
ArgSummary(..),
@@ -67,7 +68,7 @@ import GHC.Types.Var.Env
import GHC.Utils.Panic.Plain (assert)
import GHC.Utils.Panic (pprPanic)
import GHC.Data.Graph.UnVar
-import GHC.Utils.Trace (pprTrace)
+-- import GHC.Utils.Trace (pprTrace)
@@ -96,6 +97,15 @@ data UnfoldingOpts = UnfoldingOpts
, unfoldingReportPrefix :: !(Maybe String)
-- ^ Only report inlining decisions for names with this prefix
+
+ , unfoldingMaxAppDepth :: !Int
+ -- ^ When considering unfolding a definition look this deep
+ -- into the applied argument.
+
+ , unfoldingMaxGuideDepth :: !Int
+ -- ^ When creating unfolding guidance look this deep into
+ -- nested argument use.
+
}
defaultUnfoldingOpts :: UnfoldingOpts
@@ -130,6 +140,9 @@ defaultUnfoldingOpts = UnfoldingOpts
-- Don't filter inlining decision reports
, unfoldingReportPrefix = Nothing
+
+ , unfoldingMaxAppDepth = 20
+ , unfoldingMaxGuideDepth = 20
}
-- Helpers for "GHC.Driver.Session"
@@ -159,6 +172,12 @@ updateCaseScaling n opts = opts { unfoldingCaseScaling = n }
updateReportPrefix :: Maybe String -> UnfoldingOpts -> UnfoldingOpts
updateReportPrefix n opts = opts { unfoldingReportPrefix = n }
+updateMaxAppDepth :: Int -> UnfoldingOpts -> UnfoldingOpts
+updateMaxAppDepth n opts = opts { unfoldingMaxAppDepth = n }
+
+updateMaxGuideDepth :: Int -> UnfoldingOpts -> UnfoldingOpts
+updateMaxGuideDepth n opts = opts { unfoldingMaxGuideDepth = n }
+
{-
Note [Occurrence analysis of unfoldings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -471,52 +490,53 @@ sizeExpr :: UnfoldingOpts
-- Forcing bOMB_OUT_SIZE early prevents repeated
-- unboxing of the Int argument.
sizeExpr opts !bOMB_OUT_SIZE top_args' expr
- = let result = size_up (mkUnVarSet top_args') expr
+ = let result = size_up depth_limit (mkUnVarSet top_args') expr
in
-- pprTrace "sizeExpr" (ppr expr) $
-- pprTrace "sizeExpr2" (ppr result) $
result
where
- size_up :: UnVarSet -> Expr Var -> ExprSize
- size_up !disc_args (Cast e _) = size_up disc_args e
- size_up disc_args (Tick _ e) = size_up disc_args e
- size_up _disc_args (Type _) = sizeZero -- Types cost nothing
- size_up _disc_args (Coercion _) = sizeZero
- size_up _disc_args (Lit lit) = sizeN (litSize lit)
- size_up disc_args (Var f) | isZeroBitId f = sizeZero
+ depth_limit = unfoldingMaxGuideDepth opts
+ size_up :: Int -> UnVarSet -> Expr Var -> ExprSize
+ size_up !depth !disc_args (Cast e _) = size_up depth disc_args e
+ size_up !depth disc_args (Tick _ e) = size_up depth disc_args e
+ size_up !_depth _disc_args (Type _) = sizeZero -- Types cost nothing
+ size_up !_depth _disc_args (Coercion _) = sizeZero
+ size_up !_depth _disc_args (Lit lit) = sizeN (litSize lit)
+ size_up !_depth disc_args (Var f) | isZeroBitId f = sizeZero
-- Make sure we get constructor discounts even
-- on nullary constructors
| otherwise = size_up_call disc_args f [] 0
- size_up disc_args (App fun arg)
- | isTyCoArg arg = size_up disc_args fun
- | otherwise = size_up disc_args arg `addSizeNSD`
- size_up_app disc_args fun [arg] (if isZeroBitExpr arg then 1 else 0)
+ size_up !depth disc_args (App fun arg)
+ | isTyCoArg arg = size_up depth disc_args fun
+ | otherwise = size_up depth disc_args arg `addSizeNSD`
+ size_up_app depth disc_args fun [arg] (if isZeroBitExpr arg then 1 else 0)
- size_up disc_args (Lam b e)
- | isId b && not (isZeroBitId b) = lamScrutDiscount opts (size_up (delUnVarSet disc_args b) e `addSizeN` 10)
- | otherwise = size_up (delUnVarSet disc_args b) e
+ size_up !depth disc_args (Lam b e)
+ | isId b && not (isZeroBitId b) = lamScrutDiscount opts (size_up depth (delUnVarSet disc_args b) e `addSizeN` 10)
+ | otherwise = size_up depth (delUnVarSet disc_args b) e
- size_up disc_args (Let (NonRec binder rhs) body)
+ size_up !depth disc_args (Let (NonRec binder rhs) body)
= let disc_args' = delUnVarSet disc_args binder
in
- size_up_rhs disc_args' (binder, rhs) `addSizeNSD`
- size_up disc_args' body `addSizeN`
+ size_up_rhs depth disc_args' (binder, rhs) `addSizeNSD`
+ size_up depth disc_args' body `addSizeN`
size_up_alloc binder
- size_up disc_args (Let (Rec pairs) body)
+ size_up !depth disc_args (Let (Rec pairs) body)
= let lhs_bnds = map fst pairs
disc_args' = delUnVarSetList disc_args lhs_bnds
in
- foldr (addSizeNSD . (size_up_rhs disc_args'))
- (size_up disc_args' body `addSizeN` sum (map (size_up_alloc . fst) pairs))
+ foldr (addSizeNSD . (size_up_rhs depth disc_args'))
+ (size_up depth disc_args' body `addSizeN` sum (map (size_up_alloc . fst) pairs))
pairs
- size_up disc_args (Case e _ _ alts)
+ size_up !depth disc_args (Case e _ _ alts)
| null alts
- = size_up disc_args e -- case e of {} never returns, so take size of scrutinee
+ = size_up depth disc_args e -- case e of {} never returns, so take size of scrutinee
- size_up disc_args (Case e _ _ alts)
+ size_up !depth disc_args (Case e _ _ alts)
-- Now alts is non-empty
| Just v <- is_top_arg e -- We are scrutinising an argument variable
= let
@@ -530,7 +550,7 @@ sizeExpr opts !bOMB_OUT_SIZE top_args' expr
in Just (unitUFM con (ConDiscount con trim_discount (map (const NoSeqUse) alt_bndrs)))
trim_size _tot_size _ _alt_size = Nothing
- alt_sizes = map (size_up_alt (Just v) disc_args) alts
+ alt_sizes = map (size_up_alt depth (Just v) disc_args) alts
added_alt_sizes = (foldr1 addAltSize alt_sizes)
max_alt_size = (foldr (maxSize bOMB_OUT_SIZE) 0 alt_sizes)
@@ -579,8 +599,8 @@ sizeExpr opts !bOMB_OUT_SIZE top_args' expr
is_top_arg _ = Nothing
- size_up disc_args (Case e _ _ alts) = size_up disc_args e `addSizeNSD`
- foldr (addAltSize . (size_up_alt Nothing disc_args) ) case_size alts
+ size_up !depth disc_args (Case e _ _ alts) = size_up depth disc_args e `addSizeNSD`
+ foldr (addAltSize . (size_up_alt depth Nothing disc_args) ) case_size alts
where
case_size
| is_inline_scrut e, lengthAtMost alts 1 = sizeN (-10)
@@ -617,25 +637,25 @@ sizeExpr opts !bOMB_OUT_SIZE top_args' expr
| otherwise
= False
- size_up_rhs !disc_args (bndr, rhs)
+ size_up_rhs !depth !disc_args (bndr, rhs)
| Just join_arity <- isJoinId_maybe bndr
-- Skip arguments to join point
, (bndrs, body) <- collectNBinders join_arity rhs
- = size_up (delUnVarSetList disc_args bndrs) body
+ = size_up depth (delUnVarSetList disc_args bndrs) body
| otherwise
- = size_up disc_args rhs
+ = size_up depth disc_args rhs
------------
-- size_up_app is used when there's ONE OR MORE value args
- size_up_app !disc_args (App fun arg) args voids
- | isTyCoArg arg = size_up_app disc_args fun args voids
- | isZeroBitExpr arg = size_up_app disc_args fun (arg:args) (voids + 1)
- | otherwise = size_up disc_args arg `addSizeNSD`
- size_up_app disc_args fun (arg:args) voids
- size_up_app disc_args (Var fun) args voids = size_up_call disc_args fun args voids
- size_up_app disc_args (Tick _ expr) args voids = size_up_app disc_args expr args voids
- size_up_app disc_args (Cast expr _) args voids = size_up_app disc_args expr args voids
- size_up_app disc_args other args voids = size_up disc_args other `addSizeN`
+ size_up_app depth !disc_args (App fun arg) args voids
+ | isTyCoArg arg = size_up_app depth disc_args fun args voids
+ | isZeroBitExpr arg = size_up_app depth disc_args fun (arg:args) (voids + 1)
+ | otherwise = size_up depth disc_args arg `addSizeNSD`
+ size_up_app depth disc_args fun (arg:args) voids
+ size_up_app _depth disc_args (Var fun) args voids = size_up_call disc_args fun args voids
+ size_up_app depth disc_args (Tick _ expr) args voids = size_up_app depth disc_args expr args voids
+ size_up_app depth disc_args (Cast expr _) args voids = size_up_app depth disc_args expr args voids
+ size_up_app depth disc_args other args voids = size_up depth disc_args other `addSizeN`
callSize (length args) voids
-- if the lhs is not an App or a Var, or an invisible thing like a
-- Tick or Cast, then we should charge for a complete call plus the
@@ -652,16 +672,18 @@ sizeExpr opts !bOMB_OUT_SIZE top_args' expr
_ -> funSize opts disc_args fun (length val_args) voids
------------
- -- size_up_alt :: Maybe Id -> [Id] -> Alt Var -> ExprSize
- size_up_alt m_top_arg !disc_args (Alt alt_con bndrs rhs)
+ -- Take into acount the binders of scrutinized argument binders
+ -- But not too deeply! Hence we check if we exhausted depth.
+ size_up_alt depth m_top_arg !disc_args (Alt alt_con bndrs rhs)
| Just top_arg <- m_top_arg
+ , depth > 0
, DataAlt con <- alt_con
=
- let alt_size = size_up (extendUnVarSetList bndrs disc_args) rhs `addSizeN` 10
+ let alt_size = size_up depth (extendUnVarSetList bndrs disc_args) rhs `addSizeN` 10
-- let alt_size = size_up (disc_args) rhs `addSizeN` 10
in asExprSize top_arg alt_size con bndrs
- size_up_alt _ disc_args (Alt _con bndrs rhs) = size_up (delUnVarSetList disc_args bndrs) rhs `addSizeN` 10
+ size_up_alt depth _ disc_args (Alt _con bndrs rhs) = size_up depth (delUnVarSetList disc_args bndrs) rhs `addSizeN` 10
-- Don't charge for args, so that wrappers look cheap
-- (See comments about wrappers with Case)
--
@@ -1006,9 +1028,6 @@ data ExprSize
plusDiscountEnv :: VarEnv ArgDiscount -> VarEnv ArgDiscount -> VarEnv ArgDiscount
plusDiscountEnv el er = plusUFM_C combineArgDiscount el er
-todoArgDiscount :: Int -> ArgDiscount
-todoArgDiscount n = SomeArgUse n
-
-- TODO: Might be worth giving this a larger discount if the type class is known.
-- So that `f @T $d x = opDoStuff @T $d x ` applied to `f @Bool $dC_$Bool` is likely
-- to inline turning the unknown into a known call.
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -2813,6 +2813,10 @@ dynamic_flags_deps = [
(intSuffix (\n d -> d { unfoldingOpts = updateCaseThreshold n (unfoldingOpts d)}))
, make_ord_flag defFlag "funfolding-case-scaling"
(intSuffix (\n d -> d { unfoldingOpts = updateCaseScaling n (unfoldingOpts d)}))
+ , make_ord_flag defFlag "funfolding-max-arg-depth"
+ (intSuffix (\n d -> d { unfoldingOpts = updateMaxAppDepth n (unfoldingOpts d)}))
+ , make_ord_flag defFlag "funfolding-max-guide-depth"
+ (intSuffix (\n d -> d { unfoldingOpts = updateMaxGuideDepth n (unfoldingOpts d)}))
, make_dep_flag defFlag "funfolding-keeness-factor"
(floatSuffix (\_ d -> d))
=====================================
docs/users_guide/hints.rst
=====================================
@@ -404,6 +404,7 @@ decision about inlining a specific binding.
* :ghc-flag:`-funfolding-case-scaling=⟨n⟩`
* :ghc-flag:`-funfolding-dict-discount=⟨n⟩`
* :ghc-flag:`-funfolding-fun-discount=⟨n⟩`
+* :ghc-flag:`-funfolding-max-app-depth=⟨n⟩`
Should the simplifier run out of ticks because of a inlining loop
users are encouraged to try decreasing :ghc-flag:`-funfolding-case-threshold=⟨n⟩`
=====================================
docs/users_guide/using-optimisation.rst
=====================================
@@ -1651,6 +1651,60 @@ by saying ``-fno-wombat``.
while still allowing GHC to compile modules containing such inlining loops.
+.. ghc-flag:: -funfolding-max-arg-depth=⟨n⟩
+ :shortdesc: *default: 20.* Don't look deepter than `n` levels into function arguments.
+ :type: dynamic
+ :category:
+
+ :default: 20
+
+ .. index::
+ single: inlining, controlling
+ single: unfolding, controlling
+
+ If we have a function application `f (Succ (Succ Zero))` with the function `f`:
+
+ .. code-block:: haskell
+ f x =
+ case x of
+ Zero -> 0
+ Succ y -> case y of
+ Zero -> 1
+ Succ z -> case z of
+ Zero -> 2
+ _ -> error "Large"
+
+ Then GHC can consider the nested use of the argument when making inlining decisions.
+ However inspecting deeply nested arguments can be costly in terms of compile time overhead.
+ So we restrict inspection of the argument to a certain depth.
+
+.. ghc-flag:: -funfolding-max-guide-depth=⟨n⟩
+ :shortdesc: *default: 20.* Don't look deepter than `n` levels into a functions use of it's arguments.
+ :type: dynamic
+ :category:
+
+ :default: 20
+
+ .. index::
+ single: inlining, controlling
+ single: unfolding, controlling
+
+ If we have a function f:
+
+ .. code-block:: haskell
+ f x =
+ case x of
+ Zero -> 0
+ Succ y -> case y of
+ Zero -> 1
+ Succ z -> case z of
+ Zero -> 2
+ _ -> error "Large"
+
+ GHC can consider the nested use of the argument when making inlining decisions.
+ However looking deeply into nested argument use can be costly in terms of compile time overhead.
+ So we restrict inspection of nested argument use to a certain level of nesting.
+
.. ghc-flag:: -fworker-wrapper
:shortdesc: Enable the worker/wrapper transformation.
:type: dynamic
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/505d309c272350b14213e14cfc9f92b72245a5b3
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/505d309c272350b14213e14cfc9f92b72245a5b3
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20220807/6842b4bd/attachment-0001.html>
More information about the ghc-commits
mailing list