[Git][ghc/ghc][wip/andreask/deep_discounts] A bit of cleanup
Andreas Klebinger (@AndreasK)
gitlab at gitlab.haskell.org
Thu Aug 11 22:12:39 UTC 2022
Andreas Klebinger pushed to branch wip/andreask/deep_discounts at Glasgow Haskell Compiler / GHC
Commits:
9750d9e7 by Andreas Klebinger at 2022-08-12T00:12:10+02:00
A bit of cleanup
- - - - -
4 changed files:
- compiler/GHC/Core.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Seq.hs
- compiler/GHC/Core/Unfold.hs
Changes:
=====================================
compiler/GHC/Core.hs
=====================================
@@ -1394,7 +1394,7 @@ data ArgDiscount
, ad_con_discount :: !(ConMap ConDiscount) -- ^ Discounts for specific constructors
}
-- A discount for the use of a function.
- | FunDisc { ad_seq_discount :: !Int, ad_fun :: Id}
+ | FunDisc { ad_seq_discount :: !Int, ad_fun :: !Name}
| NoSeqUse
deriving Eq
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -907,14 +907,6 @@ interestingArg env e =
| 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)
=====================================
compiler/GHC/Core/Seq.hs
=====================================
@@ -24,6 +24,7 @@ import GHC.Core.Type( seqType, isTyVar )
import GHC.Core.Coercion( seqCo )
import GHC.Types.Id( idInfo )
import GHC.Utils.Misc (seqList)
+import GHC.Types.Unique.FM (seqEltsUFM)
-- | Evaluate all the fields of the 'IdInfo' that are generally demanded by the
-- compiler
@@ -113,5 +114,12 @@ seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top,
seqUnfolding _ = ()
seqGuidance :: UnfoldingGuidance -> ()
-seqGuidance (UnfIfGoodArgs ns n b) = n `seq` (seqList ns ()) `seq` b `seq` ()
+seqGuidance (UnfIfGoodArgs ns n b) = n `seq` (seqList (map seqArgDiscount ns) ()) `seq` b `seq` ()
seqGuidance _ = ()
+
+seqArgDiscount :: ArgDiscount -> ()
+seqArgDiscount (DiscSeq !_ sub_args) = seqEltsUFM seqConDiscount sub_args
+seqArgDiscount !_ = ()
+
+seqConDiscount :: ConDiscount -> ()
+seqConDiscount (ConDiscount !_ !_ sub_args) = seqList (map seqArgDiscount sub_args) ()
\ No newline at end of file
=====================================
compiler/GHC/Core/Unfold.hs
=====================================
@@ -62,13 +62,11 @@ import GHC.Types.Tickish
import qualified Data.ByteString as BS
import Data.List (isPrefixOf)
import GHC.Types.Unique.FM
--- import GHC.Utils.Trace
import Data.Maybe
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 (pprTraceDebug)
@@ -262,8 +260,7 @@ calcUnfoldingGuidance opts is_top_bottoming (Tick t expr)
| not (tickishIsCode t) -- non-code ticks don't matter for unfolding
= calcUnfoldingGuidance opts is_top_bottoming expr
calcUnfoldingGuidance opts is_top_bottoming expr
- = -- (\r -> pprTrace "calcUnfoldingGuidance" (ppr expr $$ ppr r $$ ppr (sizeExpr opts bOMB_OUT_SIZE val_bndrs body) $$ ppr r $$ ppr is_top_bottoming) r) $
- case sizeExpr opts bOMB_OUT_SIZE val_bndrs body of
+ = case sizeExpr opts bOMB_OUT_SIZE val_bndrs body of
TooBig -> UnfNever
SizeIs size cased_bndrs scrut_discount
| uncondInline expr n_val_bndrs size
@@ -275,10 +272,7 @@ calcUnfoldingGuidance opts is_top_bottoming expr
-> UnfNever -- See Note [Do not inline top-level bottoming functions]
| otherwise
- ->
- -- (if not (interesting_cased cased_bndrs) then id else pprTrace "UnfWhenDiscount" (ppr cased_bndrs))
-
- UnfIfGoodArgs { ug_args = map (mk_discount cased_bndrs) val_bndrs
+ -> UnfIfGoodArgs { ug_args = map (mk_discount cased_bndrs) val_bndrs
, ug_size = size
, ug_res = scrut_discount }
@@ -292,17 +286,6 @@ calcUnfoldingGuidance opts is_top_bottoming expr
mk_discount :: VarEnv ArgDiscount -> Id -> ArgDiscount
mk_discount cbs bndr = lookupWithDefaultVarEnv cbs NoSeqUse bndr
- -- foldl' combine NoSeqUse cbs
- -- where
- -- combine acc (bndr', use)
- -- | bndr == bndr' = acc `plus_disc` use
- -- | otherwise = acc
-
- -- plus_disc :: ArgDiscount -> ArgDiscount -> ArgDiscount
- -- plus_disc | isFunTy (idType bndr) = maxArgDiscount
- -- | otherwise = combineArgDiscount
- -- -- See Note [Function and non-function discounts]
-
{- Note [Inline unsafeCoerce]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We really want to inline unsafeCoerce, even when applied to boring
@@ -482,95 +465,84 @@ 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 depth_limit (mkUnVarSet top_args') expr
- in
- -- pprTrace "sizeExpr" (ppr expr) $
- -- pprTrace "sizeExpr2" (ppr result) $
- result
+ = size_up depth_limit (mkUnVarSet top_args') expr
where
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
+ size_up !depth !arg_comps (Cast e _) = size_up depth arg_comps e
+ size_up !depth arg_comps (Tick _ e) = size_up depth arg_comps e
+ size_up !_depth _arg_comps (Type _) = sizeZero -- Types cost nothing
+ size_up !_depth _arg_comps (Coercion _) = sizeZero
+ size_up !_depth _arg_comps (Lit lit) = sizeN (litSize lit)
+ size_up !_depth arg_comps (Var f) | isZeroBitId f = sizeZero
-- Make sure we get constructor discounts even
-- on nullary constructors
- | otherwise = size_up_call disc_args f [] 0
+ | otherwise = size_up_call arg_comps f [] 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 !depth arg_comps (App fun arg)
+ | isTyCoArg arg = size_up depth arg_comps fun
+ | otherwise = size_up depth arg_comps arg `addSizeNSD`
+ size_up_app depth arg_comps fun [arg] (if isZeroBitExpr arg then 1 else 0)
- 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 !depth arg_comps (Lam b e)
+ | isId b && not (isZeroBitId b) = lamScrutDiscount opts (size_up depth (delUnVarSet arg_comps b) e `addSizeN` 10)
+ | otherwise = size_up depth (delUnVarSet arg_comps b) e
- size_up !depth disc_args (Let (NonRec binder rhs) body)
- = let disc_args' = delUnVarSet disc_args binder
+ size_up !depth arg_comps (Let (NonRec binder rhs) body)
+ = let arg_comps' = delUnVarSet arg_comps binder
in
- size_up_rhs depth disc_args' (binder, rhs) `addSizeNSD`
- size_up depth disc_args' body `addSizeN`
+ size_up_rhs depth arg_comps' (binder, rhs) `addSizeNSD`
+ size_up depth arg_comps' body `addSizeN`
size_up_alloc binder
- size_up !depth disc_args (Let (Rec pairs) body)
+ size_up !depth arg_comps (Let (Rec pairs) body)
= let lhs_bnds = map fst pairs
- disc_args' = delUnVarSetList disc_args lhs_bnds
+ arg_comps' = delUnVarSetList arg_comps lhs_bnds
in
- foldr (addSizeNSD . (size_up_rhs depth disc_args'))
- (size_up depth disc_args' body `addSizeN` sum (map (size_up_alloc . fst) pairs))
+ foldr (addSizeNSD . (size_up_rhs depth arg_comps'))
+ (size_up depth arg_comps' body `addSizeN` sum (map (size_up_alloc . fst) pairs))
pairs
- size_up !depth disc_args (Case e _ _ alts)
+ size_up !depth arg_comps (Case e _ _ alts)
| null alts
- = size_up depth disc_args e -- case e of {} never returns, so take size of scrutinee
+ = size_up depth arg_comps e -- case e of {} never returns, so take size of scrutinee
- size_up !depth disc_args (Case e _ _ alts)
+ size_up !depth arg_comps (Case e _ _ alts)
-- Now alts is non-empty
- | Just v <- is_top_arg e -- We are scrutinising an argument variable
+ -- We are scrutinising an argument variable or a subcomponent thereof.
+ | Just v <- is_top_arg e
= let
- -- If the constructor is then apply a discount for that constructor that
- -- is equal to size_all_alts - size_this_alt.
- -- This means the size of the function will be considered the same as if
- -- we had replace the whole case with just the rhs of the alternative.
- -- Which is what we want.
- trim_size tot_size (Alt (DataAlt con) alt_bndrs _rhs) (SizeIs alt_size _ _) =
+ -- Compute size of alternatives
+ alt_sizes = map (size_up_alt depth (Just v) arg_comps) alts
+
+ -- Apply a discount for a given constructor that brings the size down to just
+ -- the size of the alternative.
+ alt_size_discount tot_size (Alt (DataAlt con) alt_bndrs _rhs) (SizeIs alt_size _ _) =
let trim_discount = max 10 $ tot_size - alt_size
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 depth (Just v) disc_args) alts
+ alt_size_discount _tot_size _ _alt_size = Nothing
+ -- Add up discounts from the alternatives
added_alt_sizes = (foldr1 addAltSize alt_sizes)
- max_alt_size = (foldr (maxSize bOMB_OUT_SIZE) 0 alt_sizes)
+ -- Compute size of the largest rhs
+ largest_alt_size = (foldr (maxSize bOMB_OUT_SIZE) 0 alt_sizes)
- -- alts_size tries to compute a good discount for
- -- the case when we are scrutinising an argument variable
+ -- alts_size tries to compute a good discount for
+ -- the case when we are scrutinising an argument variable or subcomponent thereof
alts_size (SizeIs tot tot_disc tot_scrut)
- -- Size of all alternatives combined
- max_alt_size
-
- = -- TODO: Perhaps worth having a default-alternative discount (we take the default branch)
- -- and "default" discout we apply if no other discount matched. (E.g the alternative was too big)
- -- Currently we only have the later
- -- Worst case we take the biggest alternative, so the discount is equivalent to eliminating all other
- -- alternatives.
- let default_alt_discount = 20 + tot - max_alt_size
- alt_discounts = unitUFM v $ DiscSeq default_alt_discount $ plusUFMList $ catMaybes $ zipWith (trim_size tot) alts alt_sizes
- in
+ largest_alt_size
+ = let default_alt_discount = 20 + tot - largest_alt_size
+ alt_discounts = unitUFM v $ DiscSeq default_alt_discount $ plusUFMList $ catMaybes $ zipWith (alt_size_discount tot) alts alt_sizes
+ in
SizeIs tot
(tot_disc
`plusDiscountEnv` (alt_discounts))
tot_scrut
- -- If the variable is known, we produce a
- -- discount that will take us back to 'max',
- -- the size of the largest alternative The
- -- 1+ is a little discount for reduced
- -- allocation in the caller
+ -- If the variable is known but we don't have a
+ -- specific constructor discount for it, we produce a
+ -- discount that will take us back to 'largest_alt_size',
+ -- the size of the largest alternative.
--
-- Notice though, that we return tot_disc,
-- the total discount from all branches. I
@@ -581,18 +553,18 @@ sizeExpr opts !bOMB_OUT_SIZE top_args' expr
-- Why foldr1? We might get TooBig already after the first few alternatives
-- in which case we don't have to look at the remaining ones.
alts_size added_alt_sizes -- alts is non-empty
- max_alt_size
+ largest_alt_size
-- Good to inline if an arg is scrutinised, because
-- that may eliminate allocation in the caller
-- And it eliminates the case itself
where
- is_top_arg (Var v) | v `elemUnVarSet` disc_args = Just v
+ is_top_arg (Var v) | v `elemUnVarSet` arg_comps = Just v
is_top_arg (Cast e _) = is_top_arg e
is_top_arg _ = Nothing
- 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
+ size_up !depth arg_comps (Case e _ _ alts) = size_up depth arg_comps e `addSizeNSD`
+ foldr (addAltSize . (size_up_alt depth Nothing arg_comps) ) case_size alts
where
case_size
| is_inline_scrut e, lengthAtMost alts 1 = sizeN (-10)
@@ -629,25 +601,25 @@ sizeExpr opts !bOMB_OUT_SIZE top_args' expr
| otherwise
= False
- size_up_rhs !depth !disc_args (bndr, rhs)
+ size_up_rhs !depth !arg_comps (bndr, rhs)
| Just join_arity <- isJoinId_maybe bndr
-- Skip arguments to join point
, (bndrs, body) <- collectNBinders join_arity rhs
- = size_up depth (delUnVarSetList disc_args bndrs) body
+ = size_up depth (delUnVarSetList arg_comps bndrs) body
| otherwise
- = size_up depth disc_args rhs
+ = size_up depth arg_comps rhs
------------
-- size_up_app is used when there's ONE OR MORE value args
- 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`
+ size_up_app depth !arg_comps (App fun arg) args voids
+ | isTyCoArg arg = size_up_app depth arg_comps fun args voids
+ | isZeroBitExpr arg = size_up_app depth arg_comps fun (arg:args) (voids + 1)
+ | otherwise = size_up depth arg_comps arg `addSizeNSD`
+ size_up_app depth arg_comps fun (arg:args) voids
+ size_up_app _depth arg_comps (Var fun) args voids = size_up_call arg_comps fun args voids
+ size_up_app depth arg_comps (Tick _ expr) args voids = size_up_app depth arg_comps expr args voids
+ size_up_app depth arg_comps (Cast expr _) args voids = size_up_app depth arg_comps expr args voids
+ size_up_app depth arg_comps other args voids = size_up depth arg_comps 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
@@ -655,27 +627,28 @@ sizeExpr opts !bOMB_OUT_SIZE top_args' expr
------------
size_up_call :: UnVarSet -> Id -> [CoreExpr] -> Int -> ExprSize
- size_up_call !disc_args fun val_args voids
+ size_up_call !arg_comps fun val_args voids
= case idDetails fun of
FCallId _ -> sizeN (callSize (length val_args) voids)
DataConWorkId dc -> conSize dc (length val_args)
PrimOpId op _ -> primOpSize op (length val_args)
- ClassOpId _ -> classOpSize opts disc_args val_args
- _ -> funSize opts disc_args fun (length val_args) voids
+ ClassOpId _ -> classOpSize opts arg_comps val_args
+ _ -> funSize opts arg_comps fun (length val_args) voids
------------
-- 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)
+ -- If so we simply ingore the case binders.
+ size_up_alt depth m_top_arg !arg_comps (Alt alt_con bndrs rhs)
| Just top_arg <- m_top_arg
, depth > 0
, DataAlt con <- alt_con
=
- let alt_size = size_up depth (extendUnVarSetList bndrs disc_args) rhs `addSizeN` 10
- -- let alt_size = size_up (disc_args) rhs `addSizeN` 10
+ let alt_size = size_up depth (extendUnVarSetList bndrs arg_comps) rhs `addSizeN` 10
+ -- let alt_size = size_up (arg_comps) rhs `addSizeN` 10
in asExprSize top_arg alt_size con bndrs
- size_up_alt depth _ disc_args (Alt _con bndrs rhs) = size_up depth (delUnVarSetList disc_args bndrs) rhs `addSizeN` 10
+ size_up_alt depth _ arg_comps (Alt _con bndrs rhs) = size_up depth (delUnVarSetList arg_comps bndrs) rhs `addSizeN` 10
-- Don't charge for args, so that wrappers look cheap
-- (See comments about wrappers with Case)
--
@@ -797,7 +770,7 @@ funSize opts !top_args fun n_val_args voids
-- See Note [Function and non-function discounts]
arg_discount | some_val_args && fun `elemUnVarSet` top_args
= -- pprTrace "mkFunSize" (ppr fun) $
- unitUFM fun (FunDisc (unfoldingFunAppDiscount opts) fun)
+ unitUFM fun (FunDisc (unfoldingFunAppDiscount opts) (idName fun))
| otherwise = mempty
-- If the function is an argument and is applied
-- to some values, give it an arg-discount
@@ -1026,13 +999,11 @@ plusDiscountEnv el er = plusUFM_C combineArgDiscount el er
classOpArgDiscount :: Int -> ArgDiscount
classOpArgDiscount n = SomeArgUse n
--- We computes the size of a case alternative.
--- Now we want to transfer to discount from scrutinizing the constructor binders
--- to the constructor discounts for the current scrutinee.
+-- After computing the discounts for an alternatives rhs we transfer discounts from the
+-- alt binders to the constructor specific discount of the scrutinee for the given constructor.
asExprSize :: Id -> ExprSize -> DataCon -> [Id] -> ExprSize
asExprSize _ TooBig _ _ = TooBig
asExprSize scrut (SizeIs n arg_discs s_d) con alt_bndrs =
- -- pprTrace "asExprSize" (ppr (scrut, (SizeIs n arg_discs s_d))) $
let (alt_discount_bags, top_discounts) = partitionWithKeyUFM (\k _v -> k `elem` map getUnique alt_bndrs) arg_discs
alt_discount_map = alt_discount_bags
alt_bndr_uses = map (\bndr -> lookupWithDefaultVarEnv alt_discount_map NoSeqUse bndr ) alt_bndrs :: [ArgDiscount]
@@ -1044,9 +1015,8 @@ mkConUse :: DataCon -> [ArgDiscount] -> ArgDiscount
mkConUse con uses =
DiscSeq
0
- -- We apply a penalty of 1 per case alternative, so here we apply a discount of 1 by eliminated
- -- case alternative.
- -- And then one more because we get rid of a conditional branch which is always good.
+ -- We apply a penalty of 1 per case alternative, so here we apply a discount of 1 per *eliminated*
+ -- case alternative. And then one more because we get rid of a conditional branch which is always good.
(unitUFM con (ConDiscount con (length uses) uses))
combineArgDiscount :: ArgDiscount -> ArgDiscount -> ArgDiscount
@@ -1058,7 +1028,9 @@ combineArgDiscount (DiscSeq d1 m1) (SomeArgUse d2) = DiscSeq (d1 + d2) m1
combineArgDiscount (DiscSeq d1 m1) (DiscSeq d2 m2) = DiscSeq (d1 + d2) (plusUFM_C combineMapEntry m1 m2)
-- See Note [Function and non-function discounts] why we need this
combineArgDiscount f1@(FunDisc d1 _f1) f2@(FunDisc d2 _f2) = if d1 > d2 then f1 else f2
-combineArgDiscount u1 u2 = pprPanic "Variable seemingly discounted as both function and constructor" (ppr u1 $$ ppr u2)
+-- This can happen either through shadowing or with things like unsafeCoerce. A good idea to warn for debug builds but we don't want to panic here.
+combineArgDiscount f1@(FunDisc _d _n) u2 = pprTraceDebug "Variable seemingly discounted as both function and constructor" (ppr f1 $$ ppr u2) f1
+combineArgDiscount u1 f2@(FunDisc _d _n) = pprTraceDebug "Variable seemingly discounted as both function and constructor" (ppr u1 $$ ppr f2) f2
combineMapEntry :: ConDiscount -> ConDiscount -> ConDiscount
combineMapEntry (ConDiscount c1 dc1 u1) (ConDiscount c2 dc2 u2) =
@@ -1609,16 +1581,24 @@ This kind of thing can occur if you have
which Roman did.
-
+Note [Minimum value discount]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We always give *some* benefit to value arguments.
+A discount of 10 per arg because we replace the arguments
+and another of 10 if it's some non-trivial value.
+However when computing unfolding guidance we might have come to
+the conclusion that certain argument values deservere little or no
+discount. But we want to chance of inlining to only ever increase as
+more is known about the argument to keep things more predictable. So
+we always give at least 10 discount if the argument is a value. No matter
+what the actual value is.
-}
computeDiscount :: [ArgDiscount] -> Int -> [ArgSummary] -> CallCtxt
-> Int
computeDiscount arg_discounts res_discount arg_infos cont_info
- =
- -- pprTrace "computeDiscount" (ppr arg_infos $$ ppr arg_discounts $$ ppr total_arg_discount) $
- 10 -- Discount of 10 because the result replaces the call
+ = 10 -- Discount of 10 because the result replaces the call
-- so we count 10 for the function itself
+ 10 * length actual_arg_discounts
@@ -1630,32 +1610,18 @@ computeDiscount arg_discounts res_discount arg_infos cont_info
actual_arg_discounts = zipWith mk_arg_discount arg_discounts arg_infos
total_arg_discount = sum actual_arg_discounts
- -- mk_arg_discount _ TrivArg = 0
- -- mk_arg_discount _ NonTrivArg = 10
- -- mk_arg_discount discount ValueArg = discount
-
--- Note [Minimum value discount]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- We always give *some* benefit to value arguments.
--- A discount of 10 per arg because we replace the arguments
--- and another of 10 if it's some non-trivial value.
--- However when computing unfolding guidance we might come to
--- the conclusion that inlining something if a certain argument
--- is let's say `Nothing` is pointless.
--- beyond
+ -- See Note [Minimum value discount]
mk_arg_discount :: ArgDiscount -> ArgSummary -> Int
mk_arg_discount _ TrivArg = 0
- mk_arg_discount NoSeqUse _ = 10
mk_arg_discount _ NonTrivArg = 10
- mk_arg_discount discount ValueArg = max (ad_seq_discount discount) 10
+ mk_arg_discount NoSeqUse _ = 10
+ mk_arg_discount discount ValueArg = max 10 (ad_seq_discount discount)
mk_arg_discount (DiscSeq seq_discount con_discounts) (ConArg con args)
-- There is a discount specific to this constructor, use that.
- -- BUT only use it if the specific one is larger than the generic one.
- -- Otherwise we might stop inlining something if the constructor becomes visible.
| Just (ConDiscount _ branch_dc arg_discounts) <- lookupUFM con_discounts con
= max 10 $ max seq_discount (branch_dc + (sum $ zipWith mk_arg_discount arg_discounts args))
-- Otherwise give it the generic seq discount
- | otherwise = seq_discount
+ | otherwise = max 10 seq_discount
mk_arg_discount (SomeArgUse d) ConArg{} = max 10 d
mk_arg_discount (FunDisc d _) (ConArg{})
-- How can this arise? With dictionary constructors for example.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9750d9e7275a23c9638be1ffc953a0caffdaa4b8
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9750d9e7275a23c9638be1ffc953a0caffdaa4b8
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/20220811/dc71db0f/attachment-0001.html>
More information about the ghc-commits
mailing list