[Git][ghc/ghc][wip/spj-unf-size] More
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Fri Oct 20 16:53:45 UTC 2023
Simon Peyton Jones pushed to branch wip/spj-unf-size at Glasgow Haskell Compiler / GHC
Commits:
84939df9 by Simon Peyton Jones at 2023-10-20T17:53:33+01:00
More
- - - - -
6 changed files:
- compiler/GHC/Core.hs
- compiler/GHC/Core/Opt/Simplify/Inline.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Ppr.hs
- compiler/GHC/Core/Seq.hs
- compiler/GHC/Core/Unfold.hs
Changes:
=====================================
compiler/GHC/Core.hs
=====================================
@@ -1408,7 +1408,7 @@ data CaseTree
-- nothing relies on non-empty-ness
| ScrutOf Id Int -- If this Id is bound to a value, apply this discount
-data AltTree = AT AltCon [Var] ExprTree
+data AltTree = AltTree AltCon [Var] ExprTree
{- Note [UnfoldingCache]
~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Core/Opt/Simplify/Inline.hs
=====================================
@@ -21,6 +21,8 @@ import GHC.Prelude
import GHC.Driver.Flags
+import GHC.Core.Opt.Simplify.Env
+import GHC.Core.Opt.Simplify.Utils
import GHC.Core
import GHC.Core.Unfold
import GHC.Types.Id
@@ -105,7 +107,7 @@ callSiteInline logger opts !case_depth id active_unfolding lone_variable arg_inf
CoreUnfolding { uf_tmpl = unf_template
, uf_cache = unf_cache
, uf_guidance = guidance }
- | active_unfolding -> tryUnfolding logger opts case_depth id lone_variable
+ | active_unf -> tryUnfolding logger opts case_depth id lone_variable
arg_infos cont_info unf_template
unf_cache guidance
| otherwise -> traceInline logger opts id "Inactive unfolding:" (ppr id) Nothing
@@ -113,6 +115,9 @@ callSiteInline logger opts !case_depth id active_unfolding lone_variable arg_inf
BootUnfolding -> Nothing
OtherCon {} -> Nothing
DFunUnfolding {} -> Nothing -- Never unfold a DFun
+ where
+ active_unf = activeUnfolding (seMode env) var
+
-- | Report the inlining of an identifier's RHS to the user, if requested.
traceInline :: Logger -> UnfoldingOpts -> Id -> String -> SDoc -> a -> a
@@ -228,7 +233,8 @@ needed on a per-module basis.
-}
-tryUnfolding :: Logger -> UnfoldingOpts -> Int -> Id -> Bool -> [ArgSummary] -> CallCtxt
+tryUnfolding :: Logger -> UnfoldingOpts -> Int
+ -> Id -> Bool -> [ArgSummary] -> CallCtxt
-> CoreExpr -> UnfoldingCache -> UnfoldingGuidance
-> Maybe CoreExpr
tryUnfolding logger opts !case_depth id lone_variable arg_infos
@@ -246,7 +252,7 @@ tryUnfolding logger opts !case_depth id lone_variable arg_infos
some_benefit = calc_some_benefit uf_arity
enough_args = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0)
- UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size }
+ UnfIfGoodArgs { ug_args = arg_bndrs, ug_tree = expr_tree }
| unfoldingVeryAggressive opts
-> traceInline logger opts id str (mk_doc some_benefit extra_doc True) (Just unf_template)
| is_wf && some_benefit && small_enough
@@ -260,9 +266,19 @@ tryUnfolding logger opts !case_depth id lone_variable arg_infos
depth_scaling = unfoldingCaseScaling opts
depth_penalty | case_depth <= depth_treshold = 0
| otherwise = (size * (case_depth - depth_treshold)) `div` depth_scaling
- adjusted_size = size + depth_penalty - discount
- small_enough = adjusted_size <= unfoldingUseThreshold opts
- discount = computeDiscount arg_discounts res_discount arg_infos cont_info
+
+ want_result
+ | LT <- arg_bndrs `compareLength` arg_infos
+ = True -- Over-saturated
+ | otherwise = case cont_info of
+ BoringCtxt -> False
+ _ -> True
+
+ context = IC { ic_bound = mkVarEnv (arg_bnds `zip` arg_infos)
+ , ic_free = xx
+ , ic_want_res = want_result }
+ size = depth_penalty `addSizeN` exprTreeSize context expr_tree
+ small_enough = adjusted_size `leqSize` unfoldingUseThreshold opts
extra_doc = vcat [ text "case depth =" <+> int case_depth
, text "depth based penalty =" <+> int depth_penalty
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -48,7 +48,7 @@ import qualified GHC.Prelude as Partial (head)
import GHC.Core
import GHC.Types.Literal ( isLitRubbish )
import GHC.Core.Opt.Simplify.Env
-import GHC.Core.Opt.Simplify.Inline
+-- import GHC.Core.Opt.Simplify.Inline
import GHC.Core.Opt.Stats ( Tick(..) )
import qualified GHC.Core.Subst
import GHC.Core.Ppr
@@ -577,9 +577,9 @@ contArgs cont
go args (CastIt _ k) = go args k
go args k = (False, reverse args, k)
- is_interesting arg se = interestingArg se arg
- -- Do *not* use short-cutting substitution here
- -- because we want to get as much IdInfo as possible
+ is_interesting arg se = exprSummary se arg
+ -- Do *not* use short-cutting substitution here
+ -- because we want to get as much IdInfo as possible
-- | Describes how the 'SimplCont' will evaluate the hole as a 'SubDemand'.
-- This can be more insightful than the limited syntactic context that
@@ -1002,23 +1002,23 @@ interestingArg env e = go env 0 e
conlike_unfolding = isConLikeUnfolding (idUnfolding v)
------------------------------
-idScrutInfo :: Id -> ScrutInfo
-idScrutInfo bndr
+idSummary :: SimplEnv -> Id -> ArgSummary
+idSummary env bndr
= case idUnfolding bndr of
OtherCon cs -> ScrutIsNot cs
DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }
| null bndrs
- -> ScrutIsCon (DataAlt con) (map exprScrutInfo args)
+ -> ScrutIsCon (DataAlt con) (map exprSummary args)
| otherwise
-> ScrutNoInfo
CoreUnfolding { uf_tmpl = e }
- -> exprScrutInfo e
+ -> exprSummary e
NoUnfolding -> ScrutNoInfo
BootUnfolding -> ScrutNoInfo
-exprScrutInfo :: CoreExpr -> ScrutInfo
+exprSummary :: SimplEnv -> CoreExpr -> ArgSummary
-- Very simple version of exprIsConApp_maybe
-exprScrutInfo e = go e []
+exprSummary env e = go e []
where
go (Cast e _) as = go e as
go (Tick _ e) as = go e as
@@ -1035,7 +1035,7 @@ exprScrutInfo e = go e []
go_var v as
| Just con <- isDataConWorkId_maybe v
- = ScrutIsCon (DataAlt con) (map exprScrutInfo as)
+ = ScrutIsCon (DataAlt con) (map (exprSummary env) as)
| Just rhs <- expandUnfolding_maybe (idUnfolding v)
= go rhs as
| otherwise
=====================================
compiler/GHC/Core/Ppr.hs
=====================================
@@ -638,7 +638,7 @@ instance Outputable CaseTree where
<+> brackets (sep (map ppr alts))
instance Outputable AltTree where
- ppr (AT con bs rhs) = ppr con <+> ppr bs <+> text "->" <+> ppr rhs
+ ppr (AltTree con bs rhs) = ppr con <+> ppr bs <+> text "->" <+> ppr rhs
instance Outputable Unfolding where
ppr NoUnfolding = text "No unfolding"
=====================================
compiler/GHC/Core/Seq.hs
=====================================
@@ -135,5 +135,5 @@ seqCT (ScrutOf x i) = x `seq` i `seq` ()
seqCT (CaseOf x alts) = x `seq` seqList seqAT alts
seqAT :: AltTree -> ()
-seqAT (AT con bs e) = con `seq` seqBndrs bs `seq` seqET e
+seqAT (AltTree con bs e) = con `seq` seqBndrs bs `seq` seqET e
=====================================
compiler/GHC/Core/Unfold.hs
=====================================
@@ -22,9 +22,8 @@ module GHC.Core.Unfold (
Unfolding, UnfoldingGuidance, -- Abstract types
ExprTree, exprTree, exprTreeSize,
-
- ArgSummary(..), nonTriv,
- CallCtxt(..),
+ ArgSummary(..), CallCtxt(..),
+ Size, leqSize, addSizeN,
UnfoldingOpts (..), defaultUnfoldingOpts,
updateCreationThreshold, updateUseThreshold,
@@ -56,7 +55,6 @@ import GHC.Builtin.Names
import GHC.Builtin.PrimOps
import GHC.Utils.Misc
-import GHC.Utils.Panic
import GHC.Utils.Outputable
import GHC.Data.Bag
@@ -166,23 +164,15 @@ updateReportPrefix n opts = opts { unfoldingReportPrefix = n }
********************************************************************* -}
data ArgSummary = ArgNoInfo
- | ArgIsCon AltCon [ArgInfo]
+ | ArgIsCon AltCon [ArgSummary]
| ArgIsNot [AltCon]
| ArgIsLam
-data ArgSummary = TrivArg -- Nothing interesting
- | NonTrivArg -- Arg has structure
- | ValueArg -- Arg is a con-app or PAP
- -- ..or con-like. Note [Conlike is interesting]
-
instance Outputable ArgSummary where
- ppr TrivArg = text "TrivArg"
- ppr NonTrivArg = text "NonTrivArg"
- ppr ValueArg = text "ValueArg"
-
-nonTriv :: ArgSummary -> Bool
-nonTriv TrivArg = False
-nonTriv _ = True
+ ppr ArgNoInfo = text "ArgNoInfo"
+ ppr ArgIsLam = text "ArgIsLam"
+ ppr (ArgIsCon c as) = ppr c <> ppr as
+ ppr (ArgIsNot cs) = text "ArgIsNot" <> ppr cs
data CallCtxt
= BoringCtxt
@@ -543,7 +533,7 @@ exprTree opts !bOMB_OUT_SIZE svars expr
where
alt_alt_tree :: Alt Var -> AltTree
alt_alt_tree (Alt con bs rhs)
- = AT con bs (exprTree opts bOMB_OUT_SIZE svars' rhs)
+ = AltTree con bs (exprTree opts bOMB_OUT_SIZE svars' rhs)
where
svars' = svars `extendVarSetList` bs
@@ -937,74 +927,82 @@ addSize :: Size -> Size -> Size
addSize (SSize n1) (SSize n2) = SSize (n1+n2)
addSize _ _ = STooBig
+addSizeN :: Int -> Size -> Size
+addSizeN n1 (SSize n2) = SSize (n1+n2)
+addSizeN _ STooBig = STooBig
+
leqSize :: Size -> Int -> Bool
leqSize STooBig _ = False
leqSize (SSize n) m = n <= m
-------------------------
-type UnfoldingInfo = IdEnv ArgInfo
- -- Domain is the bound vars of the function RHS
+data InlineContext
+ = IC { ic_free :: Id -> ArgSummary -- Current unfoldings for free variables
+ , ic_bound :: IdEnv ArgSummary -- Summaries for local variables
+ , ic_want_res :: Bool -- True <=> result is scrutinised/demanded
+ -- so apply result discount
+ }
-------------------------
-exprTreeSize :: UnfoldingInfo -- Unfolding
- -> Bool -- Apply result discount please
- -> ExprTree -> Size
-exprTreeSize _ _ TooBig = STooBig
-exprTreeSize unf want_res (SizeIs { et_size = size
- , et_cases = cases
- , et_ret = ret_discount })
- = foldr (addSize . caseTreeSize unf False)
+exprTreeSize :: InlineContext -> ExprTree -> Size
+exprTreeSize _ TooBig = STooBig
+exprTreeSize !ic (SizeIs { et_size = size
+ , et_cases = cases
+ , et_ret = ret_discount })
+ = foldr (addSize . caseTreeSize (ic { ic_want_res = False }))
(sizeN discounted_size) cases
where
- discounted_size | want_res = size - ret_discount
- | otherwise = size
+ discounted_size | ic_want_res ic = size - ret_discount
+ | otherwise = size
-caseTreeSize :: UnfoldingInfo -> Bool -> CaseTree -> Size
-caseTreeSize unf _ (ScrutOf bndr disc)
- = case lookupBndr unf bndr of
+caseTreeSize :: InlineContext -> CaseTree -> Size
+caseTreeSize ic (ScrutOf bndr disc)
+ = case lookupBndr ic bndr of
ArgNoInfo -> sizeN 0
ArgIsNot {} -> sizeN 0
ArgIsLam -> sizeN (-disc) -- Apply discount
ArgIsCon {} -> sizeN (-disc) -- Apply discount
-caseTreeSize unf want_res (CaseOf bndr alts)
- = case lookupBndr unf bndr of
- ArgNoInfo -> keptCaseSize unf want_res alts
- ArgIsLam -> keptCaseSize unf want_res alts
- ArgIsNot cons -> keptCaseSize unf want_res (trim_alts cons alts)
+caseTreeSize ic (CaseOf var alts)
+ = case lookupBndr ic var of
+ ArgNoInfo -> keptCaseSize ic alts
+ ArgIsLam -> keptCaseSize ic alts
+ ArgIsNot cons -> keptCaseSize ic (trim_alts cons alts)
ArgIsCon con args
- | Just (AT _ bs rhs) <- find_alt con alts
- , let unf' = extendVarEnvList unf (bs `zip` args) -- In DEFAULT case, bs is empty
- -> exprTreeSize unf' want_res rhs
+ | Just (AltTree _ bs rhs) <- find_alt con alts
+ , let ic' = ic { ic_bound = ic_bound ic `extendVarEnvList`
+ (bs `zip` args) }
+ -- In DEFAULT case, bs is empty, so extend is a no-op
+ -> exprTreeSize ic' rhs
| otherwise -- Happens for empty alternatives
- -> keptCaseSize unf want_res alts
+ -> keptCaseSize ic alts
find_alt :: AltCon -> [AltTree] -> Maybe AltTree
find_alt _ [] = Nothing
find_alt con (alt:alts)
- | AT DEFAULT _ _ <- alt = go alts (Just alt)
- | otherwise = go (alt:alts) Nothing
+ | AltTree DEFAULT _ _ <- alt = go alts (Just alt)
+ | otherwise = go (alt:alts) Nothing
where
go [] deflt = deflt
go (alt:alts) deflt
- | AT con' _ _ <- alt, con==con' = Just alt
- | otherwise = go alts deflt
+ | AltTree con' _ _ <- alt, con==con' = Just alt
+ | otherwise = go alts deflt
trim_alts :: [AltCon] -> [AltTree] -> [AltTree]
trim_alts _ [] = []
trim_alts acs (alt:alts)
- | AT con _ _ <- alt, con `elem` acs = trim_alts acs alts
- | otherwise = alt : trim_alts acs alts
+ | AltTree con _ _ <- alt, con `elem` acs = trim_alts acs alts
+ | otherwise = alt : trim_alts acs alts
-keptCaseSize :: UnfoldingInfo -> Bool -> [AltTree] -> Size
+keptCaseSize :: InlineContext -> [AltTree] -> Size
-- Size of a (retained) case expression
-keptCaseSize unf want_res alts
+keptCaseSize ic alts
= foldr (addSize . size_alt) (sizeN 0) alts
-- We make the case itself free, but charge for each alternative
-- If there are no alternatives (case e of {}), we get just the size of the scrutinee
where
size_alt :: AltTree -> Size
- size_alt (AT _ _ rhs) = sizeN 10 `addSize` exprTreeSize unf want_res rhs
+ size_alt (AltTree _ _ rhs) = sizeN 10 `addSize` exprTreeSize ic rhs
-- Add 10 for each alternative
-- Don't charge for args, so that wrappers look cheap
-- (See comments about wrappers with Case)
@@ -1013,8 +1011,8 @@ keptCaseSize unf want_res alts
-- find that giant case nests are treated as practically free
-- A good example is Foreign.C.Error.errnoToIOError
-lookupBndr :: UnfoldingInfo -> Id -> ArgInfo
-lookupBndr unf bndr
- | Just info <- lookupVarEnv unf bndr = info
- | otherwise = idArgInfo bndr
+lookupBndr :: InlineContext -> Id -> ArgSummary
+lookupBndr (IC { ic_bound = bound_env, ic_free = lookup_free }) var
+ | Just info <- lookupVarEnv bound_env var = info
+ | otherwise = lookup_free var
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/84939df9c836075860dc1a5fae85082a14626833
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/84939df9c836075860dc1a5fae85082a14626833
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/20231020/ab7163fa/attachment-0001.html>
More information about the ghc-commits
mailing list