[Git][ghc/ghc][wip/spj-unf-size] 2 commits: White space
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Wed Oct 25 20:23:59 UTC 2023
Simon Peyton Jones pushed to branch wip/spj-unf-size at Glasgow Haskell Compiler / GHC
Commits:
9ae2e8bb by Simon Peyton Jones at 2023-10-25T08:49:52+01:00
White space
- - - - -
417d47c6 by Simon Peyton Jones at 2023-10-25T21:23:37+01:00
Simplify size calculations
- - - - -
6 changed files:
- compiler/GHC/Core.hs
- compiler/GHC/Core/Opt/Simplify/Inline.hs
- compiler/GHC/Core/Ppr.hs
- compiler/GHC/Core/Seq.hs
- compiler/GHC/Core/Subst.hs
- compiler/GHC/Core/Unfold.hs
Changes:
=====================================
compiler/GHC/Core.hs
=====================================
@@ -1397,11 +1397,10 @@ data UnfoldingGuidance
| UnfNever -- The RHS is big, so don't inline it
data ExprTree
- = TooBig
- | SizeIs { et_size :: {-# UNPACK #-} !Int
- , et_ret :: {-# UNPACK #-} !Int
- -- ^ Discount when result is scrutinised
- , et_cases :: Bag CaseTree
+ = ExprTree { et_tot :: {-# UNPACK #-} !Int -- ^ Size of whole tree
+ , et_size :: {-# UNPACK #-} !Int -- ^ Size of the bit apart from et_cases
+ , et_ret :: {-# UNPACK #-} !Int -- ^ Discount when result is scrutinised
+ , et_cases :: Bag CaseTree
}
data CaseTree
=====================================
compiler/GHC/Core/Opt/Simplify/Inline.hs
=====================================
@@ -222,11 +222,11 @@ tryUnfolding logger env fn cont unf_template unf_cache guidance
where
n_bndrs = length arg_bndrs
some_benefit = calc_some_benefit n_bndrs
- small_enough = adjusted_size `leqSize` unfoldingUseThreshold opts
- adjusted_size = adjustSize adjust_size rhs_size
+ small_enough = adjusted_size <= unfoldingUseThreshold opts
+ rhs_size = exprTreeSize context expr_tree
+ adjusted_size = rhs_size - call_size + depth_penalty
-------- Compute the size of the ExprTree in this context -----------
- rhs_size = exprTreeSize context expr_tree
want_result
| n_bndrs < n_val_args = True -- Over-saturated
| otherwise = case cont_info of
@@ -254,9 +254,7 @@ tryUnfolding logger env fn cont unf_template unf_cache guidance
-> exprSummary env expr
_ -> ArgNoInfo
- -------- adjust_size ----------------
- adjust_size size = size - call_size + depth_penalty size
-
+ -------- Size adjustements ----------------
-- Subtract size of the call, because the result replaces the call
-- We count 10 for the function itself, 10 for each arg supplied,
call_size = 10 + 10*n_val_args
@@ -266,9 +264,9 @@ tryUnfolding logger env fn cont unf_template unf_cache guidance
depth_threshold = unfoldingCaseThreshold opts
depth_scaling = unfoldingCaseScaling opts
- depth_penalty size
+ depth_penalty
| case_depth <= depth_threshold = 0
- | otherwise = (size * (case_depth - depth_threshold)) `div` depth_scaling
+ | otherwise = (rhs_size * (case_depth - depth_threshold)) `div` depth_scaling
extra_doc = vcat [ text "size =" <+> ppr rhs_size
, text "case depth =" <+> int case_depth
=====================================
compiler/GHC/Core/Ppr.hs
=====================================
@@ -628,9 +628,9 @@ instance Outputable UnfoldingGuidance where
ppr et ]
instance Outputable ExprTree where
- ppr TooBig = text "TooBig"
- ppr (SizeIs { et_size = size, et_ret = ret, et_cases = cases })
- = int size <> char '/' <> int ret <> brackets (sep (map ppr (bagToList cases)))
+ ppr (ExprTree { et_tot = tot, et_size = size, et_ret = ret, et_cases = cases })
+ = int tot <> char '/' <> int size <> char '/' <> int ret
+ <> brackets (sep (map ppr (bagToList cases)))
instance Outputable CaseTree where
ppr (ScrutOf x n) = ppr x <> colon <> int n
=====================================
compiler/GHC/Core/Seq.hs
=====================================
@@ -126,9 +126,8 @@ seqGuidance (UnfIfGoodArgs bs et) = seqBndrs bs `seq` seqET et
seqGuidance _ = ()
seqET :: ExprTree -> ()
-seqET TooBig = ()
-seqET (SizeIs { et_size = size, et_cases = cases, et_ret = ret })
- = size `seq` ret `seq` seqBag seqCT cases
+seqET (ExprTree { et_tot = tot, et_size = size, et_cases = cases, et_ret = ret })
+ = tot `seq` size `seq` ret `seq` seqBag seqCT cases
seqCT :: CaseTree -> ()
seqCT (ScrutOf x i) = x `seq` i `seq` ()
=====================================
compiler/GHC/Core/Subst.hs
=====================================
@@ -540,17 +540,22 @@ substGuidance subst guidance
substExprTree :: IdSubstEnv -> ExprTree -> ExprTree
-- ExprTrees have free Ids, and so must be substituted
-- But Ids /only/ not tyvars, so substitution is very simple
-substExprTree _ TooBig = TooBig
-substExprTree id_env (SizeIs { et_size = size
- , et_cases = cases
- , et_ret = ret_discount })
- = case extra_size of
- STooBig -> TooBig
- SSize extra -> SizeIs { et_size = size + extra
- , et_cases = cases'
- , et_ret = ret_discount }
+--
+-- We might be substituting a big tree in place of a variable
+-- but we don't account for that in the size: I think it doesn't
+-- matter, and the ExprTree will be refreshed soon enough.
+substExprTree id_env (ExprTree { et_tot = tot
+ , et_size = size
+ , et_cases = cases
+ , et_ret = ret_discount })
+ = ExprTree { et_tot = tot
+ , et_size = size + extra_size
+ , et_cases = cases'
+ , et_ret = ret_discount }
where
- (extra_size, cases') = foldr subst_ct (sizeZero, emptyBag) cases
+ (extra_size, cases') = foldr subst_ct (0, emptyBag) cases
+ -- The extra_size is just in case we substitute a non-variable for
+ -- for a variable, in which case a CaseOf won't work. Unlikely.
subst_ct :: CaseTree -> (Size, Bag CaseTree) -> (Size, Bag CaseTree)
subst_ct (ScrutOf v d) (n, cts)
@@ -561,22 +566,17 @@ substExprTree id_env (SizeIs { et_size = size
subst_ct (CaseOf v case_bndr alts) (n, cts)
= case lookupVarEnv id_env v of
Just (Var v') -> (n, CaseOf v' case_bndr alts' `consBag` cts)
- _ -> (n `addSize` extra, cts)
+ _ -> (n + extra, cts)
where
id_env' = id_env `delVarEnv` case_bndr
alts' = map (subst_alt id_env') alts
- extra = keptCaseSize boringInlineContext case_bndr alts
+ extra = keptCaseSize alts
subst_alt id_env (AltTree con bs rhs)
= AltTree con bs (substExprTree id_env' rhs)
where
id_env' = id_env `delVarEnvList` bs
-boringInlineContext :: InlineContext
-boringInlineContext = IC { ic_free = \_ -> ArgNoInfo
- , ic_bound = emptyVarEnv
- , ic_want_res = False }
-
------------------
substIdOcc :: Subst -> Id -> Id
-- These Ids should not be substituted to non-Ids
=====================================
compiler/GHC/Core/Unfold.hs
=====================================
@@ -24,8 +24,7 @@ module GHC.Core.Unfold (
exprTreeWillInline, couldBeSmallEnoughToInline,
ArgSummary(..), hasArgInfo,
- Size(..), leqSize, addSizeN, addSize, adjustSize, sizeZero,
- InlineContext(..),
+ Size, InlineContext(..),
UnfoldingOpts (..), defaultUnfoldingOpts,
updateCreationThreshold, updateUseThreshold,
@@ -277,10 +276,9 @@ calcUnfoldingGuidance opts is_top_bottoming (Tick t expr)
= calcUnfoldingGuidance opts is_top_bottoming expr
calcUnfoldingGuidance opts is_top_bottoming expr
= case exprTree opts val_bndrs body of
- TooBig -> UnfNever
- et@(SizeIs { et_size = size, et_cases = cases })
- | not (any is_case cases)
- , uncondInline expr n_val_bndrs size
+ Nothing -> UnfNever
+ Just et@(ExprTree { et_size = tot })
+ | uncondInline expr n_val_bndrs tot
-> UnfWhen { ug_unsat_ok = unSaturatedOk
, ug_boring_ok = boringCxtOk
, ug_arity = n_val_bndrs } -- Note [INLINE for small functions]
@@ -296,18 +294,15 @@ calcUnfoldingGuidance opts is_top_bottoming expr
val_bndrs = filter isId bndrs
n_val_bndrs = length val_bndrs
- is_case (CaseOf {}) = True
- is_case (ScrutOf {}) = False
-
-
couldBeSmallEnoughToInline :: UnfoldingOpts -> Int -> CoreExpr -> Bool
-- We use 'couldBeSmallEnoughToInline' to avoid exporting inlinings that
-- we ``couldn't possibly use'' on the other side. Can be overridden
-- w/flaggery. Just the same as smallEnoughToInline, except that it has no
-- actual arguments.
couldBeSmallEnoughToInline opts threshold rhs
- = exprTreeWillInline threshold $
- exprTree opts [] body
+ = case exprTree opts [] body of
+ Nothing -> False
+ Just et -> exprTreeWillInline threshold et
where
(_, body) = collectBinders rhs
@@ -504,13 +499,14 @@ Wrinkles:
* We must be careful about recording enormous functions, with very wide or very
deep case trees. (This can happen with Generics; e.g. test T5642.) We limit
- both with UnfoldingOpts, and
+ both with UnfoldingOpts.
-}
type ETVars = (VarSet,VarSet) -- (avs, lvs)
-- See Note [Constructing an ExprTree]
-exprTree :: UnfoldingOpts -> [Var] -> CoreExpr -> ExprTree
+exprTree :: UnfoldingOpts -> [Var] -> CoreExpr -> Maybe ExprTree
+-- Nothing => too big
-- Note [Computing the size of an expression]
exprTree opts args expr
@@ -526,27 +522,27 @@ exprTree opts args expr
ok_case case_depth n_alts -- Case is not too deep, nor too wide
= case_depth > 0 && n_alts <= max_width
- et_add = etAdd bOMB_OUT_SIZE
- et_add_alt = etAddAlt bOMB_OUT_SIZE
+ et_add = metAdd bOMB_OUT_SIZE
+ et_add_alt = metAddAlt bOMB_OUT_SIZE
- go :: Int -> ETVars -> CoreExpr -> ExprTree
+ go :: Int -> ETVars -> CoreExpr -> Maybe ExprTree
-- cd is the unused case depth; decreases toward zero
-- (avs,lvs): see Note [Constructing an ExprTree]
go cd vs (Cast e _) = go cd vs e
go cd vs (Tick _ e) = go cd vs e
- go _ _ (Type _) = exprTreeN 0
- go _ _ (Coercion _) = exprTreeN 0
- go _ _ (Lit lit) = exprTreeN (litSize lit)
+ go _ _ (Type _) = Just (exprTreeN 0)
+ go _ _ (Coercion _) = Just (exprTreeN 0)
+ go _ _ (Lit lit) = Just (exprTreeN (litSize lit))
go cd vs (Case e b _ as) = go_case cd vs e b as
go cd vs (Let bind body) = go_let cd vs bind body
go cd vs (Lam b e) = go_lam cd vs b e
go cd vs e@(App {}) = go_app cd vs e
- go _ vs (Var f) = callTree opts vs f [] 0
+ go _ vs (Var f) = Just (callTree opts vs f [] 0)
-- Use callTree to ensure we get constructor
-- discounts even on nullary constructors
-------------------
go_lam cd vs bndr body
- | isId bndr, not (isZeroBitId bndr) = go cd vs' body `et_add` lamSize opts
+ | isId bndr, not (isZeroBitId bndr) = go cd vs' body `et_add` Just (lamSize opts)
| otherwise = go cd vs' body
where
vs' = vs `add_lv` bndr
@@ -564,7 +560,7 @@ exprTree opts args expr
-------------------
go_app cd vs e = lgo e [] 0
where
- lgo :: CoreExpr -> [CoreExpr] -> Int -> ExprTree
+ lgo :: CoreExpr -> [CoreExpr] -> Int -> Maybe ExprTree
-- args: all the value args
-- voids: counts the zero-bit arguments; don't charge for these
-- This makes a difference in ST-heavy code which does a lot
@@ -574,11 +570,11 @@ exprTree opts args expr
| isZeroBitArg arg = lgo fun (arg:args) (voids+1)
| otherwise = go cd vs arg `et_add`
lgo fun (arg:args) voids
- lgo (Var fun) args voids = callTree opts vs fun args voids
+ lgo (Var fun) args voids = Just (callTree opts vs fun args voids)
lgo (Tick _ expr) args voids = lgo expr args voids
lgo (Cast expr _) args voids = lgo expr args voids
lgo other args voids = vanillaCallSize (length args) voids
- `etAddN` go cd vs other
+ `metAddN` go cd vs other
-- 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
-- size of the lhs itself.
@@ -590,7 +586,7 @@ exprTree opts args expr
-- Skip arguments to join point
= go cd (vs `add_lvs` bndrs) body
| otherwise
- = size_up_alloc bndr `etAddN` go cd vs rhs
+ = size_up_alloc bndr `metAddN` go cd vs rhs
-- Cost to allocate binding with given binder
size_up_alloc bndr
@@ -602,7 +598,7 @@ exprTree opts args expr
= 10
-----------------------------
- go_case :: Int -> ETVars -> CoreExpr -> Id -> [CoreAlt] -> ExprTree
+ go_case :: Int -> ETVars -> CoreExpr -> Id -> [CoreAlt] -> Maybe ExprTree
-- Empty case
go_case cd vs scrut _ [] = go cd vs scrut
-- case e of {} never returns, so take size of scrutinee
@@ -612,15 +608,17 @@ exprTree opts args expr
| Just v <- recordCaseOf vs scrut
= go cd vs scrut `et_add`
(if ok_case cd n_alts
- then etOneCase (CaseOf v b (map (alt_alt_tree v) alts))
- else etOneCase (ScrutOf v (10 * n_alts)) `et_add`
+ then do { alts' <- mapM (alt_alt_tree v) alts
+ ; etCaseOf bOMB_OUT_SIZE v b alts' }
+ else Just (etScrutOf v (10 * n_alts)) `et_add`
go_alts cd vs b alts)
where
cd1 = cd - 1
n_alts = length alts
- alt_alt_tree :: Id -> Alt Var -> AltTree
+ alt_alt_tree :: Id -> Alt Var -> Maybe AltTree
alt_alt_tree v (Alt con bs rhs)
- = AltTree con val_bs (10 `etAddN` go cd1 (add_alt_bndrs v val_bs) rhs)
+ = do { rhs <- 10 `metAddN` go cd1 (add_alt_bndrs v val_bs) rhs
+ ; return (AltTree con val_bs rhs) }
where
val_bs = filter isId bs
@@ -631,17 +629,17 @@ exprTree opts args expr
-- Don't record a CaseOf
go_case cd vs scrut b alts -- alts is non-empty
- = caseSize scrut alts `etAddN` -- A bit odd that this is only in one branch
+ = caseSize scrut alts `metAddN` -- A bit odd that this is only in one branch
go cd vs scrut `et_add`
go_alts cd vs b alts
- go_alts :: Int -> ETVars -> Id -> [CoreAlt] -> ExprTree
+ go_alts :: Int -> ETVars -> Id -> [CoreAlt] -> Maybe ExprTree
go_alts cd vs b alts = foldr1 et_add_alt (map alt_expr_tree alts)
where
cd1 = cd - 1
- alt_expr_tree :: Alt Var -> ExprTree
+ alt_expr_tree :: Alt Var -> Maybe ExprTree
alt_expr_tree (Alt _con bs rhs)
- = 10 `etAddN` go cd1 (vs `add_lvs` (b:bs)) rhs
+ = 10 `metAddN` go cd1 (vs `add_lvs` (b:bs)) rhs
-- Don't charge for bndrs, so that wrappers look cheap
-- (See comments about wrappers with Case)
-- Don't forget to add the case binder, b, to lvs.
@@ -650,7 +648,7 @@ exprTree opts args expr
-- find that giant case nests are treated as practically free
-- A good example is Foreign.C.Error.errnoToIOError
-caseSize :: CoreExpr -> [CoreAlt] -> Int
+caseSize :: CoreExpr -> [CoreAlt] -> Size
caseSize scrut alts
| is_inline_scrut scrut, lengthAtMost alts 1 = -10
| otherwise = 0
@@ -716,7 +714,7 @@ isZeroBitId id = assertPpr (not (isJoinId id)) (ppr id) $
-- | Finds a nominal size of a string literal.
-litSize :: Literal -> Int
+litSize :: Literal -> Size
-- Used by GHC.Core.Unfold.exprTree
litSize (LitNumber LitNumBigNat _) = 100
litSize (LitString str) = 10 + 10 * ((BS.length str + 3) `div` 4)
@@ -763,7 +761,7 @@ classOpSize opts vs fn val_args voids
, Just dict <- recordCaseOf vs arg1
= warnPprTrace (not (isId dict)) "classOpSize" (ppr fn <+> ppr val_args) $
vanillaCallSize (length val_args) voids `etAddN`
- etOneCase (ScrutOf dict (unfoldingDictDiscount opts))
+ etScrutOf dict (unfoldingDictDiscount opts)
-- If the class op is scrutinising a lambda bound dictionary then
-- give it a discount, to encourage the inlining of this function
-- The actual discount is rather arbitrarily chosen
@@ -776,9 +774,9 @@ funSize :: UnfoldingOpts -> ETVars -> Id -> Int -> Int -> ExprTree
funSize opts (avs,_) fun n_val_args voids
| fun `hasKey` buildIdKey = etZero -- Wwant to inline applications of build/augment
| fun `hasKey` augmentIdKey = etZero -- so we give size zero to the whole call
- | otherwise = SizeIs { et_size = size
- , et_cases = cases
- , et_ret = res_discount }
+ | otherwise = ExprTree { et_tot = size, et_size = size
+ , et_cases = cases
+ , et_ret = res_discount }
where
size | n_val_args == 0 = 0 -- Naked variable counts zero
| otherwise = vanillaCallSize n_val_args voids
@@ -798,8 +796,9 @@ funSize opts (avs,_) fun n_val_args voids
lamSize :: UnfoldingOpts -> ExprTree
-- Does not include the size of the body, just the lambda itself
-lamSize opts = SizeIs { et_size = 10, et_cases = emptyBag
- , et_ret = unfoldingFunAppDiscount opts }
+lamSize opts = ExprTree { et_size = 10, et_tot = 10
+ , et_cases = emptyBag
+ , et_ret = unfoldingFunAppDiscount opts }
conSize :: DataCon -> Int -> ExprTree
-- Does not need to include the size of the arguments themselves
@@ -807,7 +806,8 @@ conSize dc n_val_args
| isUnboxedTupleDataCon dc
= etZero -- See Note [Unboxed tuple size and result discount]
| otherwise -- See Note [Constructor size and result discount]
- = SizeIs { et_size = size, et_cases = emptyBag, et_ret = 10 }
+ = ExprTree { et_size = size, et_tot = size
+ , et_cases = emptyBag, et_ret = 10 }
where
size | n_val_args == 0 = 0 -- Like variables
| otherwise = 10
@@ -981,47 +981,70 @@ Code for manipulating sizes
-}
---------------------------------------
--- | The "expression tree"; an abstraction of the RHS of the function
-exprTreeN :: Int -> ExprTree
-exprTreeN n = SizeIs { et_size = n, et_cases = emptyBag, et_ret = 0 }
+metAddN :: Int -> Maybe ExprTree -> Maybe ExprTree
+metAddN _ Nothing = Nothing
+metAddN n (Just et) = Just (n `etAddN` et)
etAddN :: Int -> ExprTree -> ExprTree
-etAddN _ TooBig = TooBig
-etAddN n1 (SizeIs { et_size = n2, et_cases = c2, et_ret = ret2 })
- = SizeIs { et_size = n1+n2, et_cases = c2, et_ret = ret2 }
+-- Does not account for et_tot geting too big, but that doesn't
+-- matter; the extra increment is always small, and we never get
+-- a long cascade of etAddNs
+etAddN n1 (ExprTree { et_tot = t2, et_size = n2, et_cases = c2, et_ret = ret2 })
+ = ExprTree { et_tot = n1+t2, et_size = n1+n2, et_cases = c2, et_ret = ret2 }
-etAdd :: Int -> ExprTree -> ExprTree -> ExprTree
+metAdd :: Size -> Maybe ExprTree -> Maybe ExprTree -> Maybe ExprTree
-- Takes return value from the right hand argument
-etAdd _ TooBig _ = TooBig
-etAdd _ _ TooBig = TooBig
-etAdd bOMB_OUT_SIZE (SizeIs { et_size = n1, et_cases = c1, et_ret = _ret1 })
- (SizeIs { et_size = n2, et_cases = c2, et_ret = ret2 })
- | n12 >= bOMB_OUT_SIZE = TooBig
- | otherwise = SizeIs { et_size = n12
- , et_cases = c1 `unionBags` c2
- , et_ret = ret2 }
- where
- n12 = n1 + n2
-
-etAddAlt :: Int -> ExprTree -> ExprTree -> ExprTree
--- etAddalt is used to add the sizes of case alternatives
-etAddAlt _ TooBig _ = TooBig
-etAddAlt _ _ TooBig = TooBig
-etAddAlt bOMB_OUT_SIZE (SizeIs { et_size = n1, et_cases = c1, et_ret = ret1 })
- (SizeIs { et_size = n2, et_cases = c2, et_ret = ret2 })
- | n12 >= bOMB_OUT_SIZE = TooBig
- | otherwise = SizeIs { et_size = n12
- , et_cases = c1 `unionBags` c2
- , et_ret = ret1 + ret2 }
- -- et_ret: see Note [etAddAlt result discounts]
- where
- n12 = n1 + n2
+metAdd _ Nothing _ = Nothing
+metAdd _ _ Nothing = Nothing
+metAdd bOMB_OUT_SIZE (Just et1) (Just et2)
+ | ExprTree { et_tot = t1, et_size = n1, et_cases = c1, et_ret = _ret1 } <- et1
+ , ExprTree { et_tot = t2, et_size = n2, et_cases = c2, et_ret = ret2 } <- et2
+ , let t12 = t1 + t2
+ = if t12 >= bOMB_OUT_SIZE
+ then Nothing
+ else Just (ExprTree { et_tot = t12
+ , et_size = n1 + n2
+ , et_cases = c1 `unionBags` c2
+ , et_ret = ret2 })
+
+metAddAlt :: Size -> Maybe ExprTree -> Maybe ExprTree -> Maybe ExprTree
+-- Adds return discounts from both args
+metAddAlt _ Nothing _ = Nothing
+metAddAlt _ _ Nothing = Nothing
+metAddAlt bOMB_OUT_SIZE (Just et1) (Just et2)
+ | ExprTree { et_tot = t1, et_size = n1, et_cases = c1, et_ret = ret1 } <- et1
+ , ExprTree { et_tot = t2, et_size = n2, et_cases = c2, et_ret = ret2 } <- et2
+ , let t12 = t1 + t2
+ = if t12 >= bOMB_OUT_SIZE
+ then Nothing
+ else Just (ExprTree { et_tot = t12
+ , et_size = n1 + n2
+ , et_cases = c1 `unionBags` c2
+ , et_ret = ret1 + ret2 })
+
+
+-- | The "expression tree"; an abstraction of the RHS of the function
+exprTreeN :: Int -> ExprTree
+exprTreeN n = ExprTree { et_size = n, et_tot = n, et_cases = emptyBag, et_ret = 0 }
etZero :: ExprTree
-etZero = SizeIs { et_size = 0, et_cases = emptyBag, et_ret = 0 }
+etZero = ExprTree { et_tot = 0, et_size = 0, et_cases = emptyBag, et_ret = 0 }
+
+etCaseOf :: Int -> Id -> Id -> [AltTree] -> Maybe ExprTree
+-- 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
+etCaseOf bOMB_OUT_SIZE scrut case_bndr alts
+ | tot >= bOMB_OUT_SIZE = Nothing
+ | otherwise = Just (ExprTree { et_tot = tot, et_size = 0, et_ret = 0
+ , et_cases = unitBag case_tree })
+ where
+ case_tree = CaseOf scrut case_bndr alts
+ tot = foldl' add_alt 0 alts
+ add_alt n (AltTree _ _ (ExprTree { et_tot = tot })) = n+tot
-etOneCase :: CaseTree -> ExprTree
-etOneCase ct = SizeIs { et_size = 0, et_cases = unitBag ct, et_ret = 0 }
+etScrutOf :: Id -> Int -> ExprTree
+etScrutOf v d = ExprTree { et_tot = 0, et_size = 0, et_ret = 0
+ , et_cases = unitBag (ScrutOf v d) }
{- *********************************************************************
* *
@@ -1030,8 +1053,9 @@ etOneCase ct = SizeIs { et_size = 0, et_cases = unitBag ct, et_ret = 0 }
* *
********************************************************************* -}
-data Size = STooBig | SSize {-# UNPACK #-} !Int
+type Size = Int
+{-
instance Outputable Size where
ppr STooBig = text "STooBig"
ppr (SSize n) = int n
@@ -1057,6 +1081,7 @@ adjustSize _ STooBig = STooBig
leqSize :: Size -> Int -> Bool
leqSize STooBig _ = False
leqSize (SSize n) m = n <= m
+-}
-------------------------
data InlineContext
@@ -1087,32 +1112,15 @@ exprTreeWillInline :: Int -> ExprTree -> Bool
-- (cheapExprTreeSize limit et) takes an upper bound `n` on the
-- size of et; i.e. without discounts etc.
-- Return True if (s <- limit), False otherwise
--- Bales out early in the False case
-exprTreeWillInline limit et
- = go et (\n -> n <= limit) 0
- where
- go :: ExprTree -> (Int -> Bool) -> Int -> Bool
- go _ _ n | n > limit = False
- go TooBig _ _ = False
- go (SizeIs { et_size = size, et_cases = cases }) k n
- = foldr go_ct k cases (n+size)
-
- go_ct :: CaseTree -> (Int -> Bool) -> Int -> Bool
- go_ct (ScrutOf {}) k n = k n
- go_ct (CaseOf _ _ alts) k n = foldr go_alt k alts n
-
- go_alt :: AltTree -> (Int -> Bool) -> Int -> Bool
- go_alt (AltTree _ _ et) k n = go et k (n+10)
-
+exprTreeWillInline limit (ExprTree { et_tot = tot }) = tot < limit
-------------------------
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
+exprTreeSize !ic (ExprTree { et_size = size
+ , et_cases = cases
+ , et_ret = ret_discount })
+ = foldr ((+) . caseTreeSize (ic { ic_want_res = False }))
+ discounted_size cases
where
discounted_size | ic_want_res ic = size - ret_discount
| otherwise = size
@@ -1120,17 +1128,17 @@ exprTreeSize !ic (SizeIs { et_size = size
caseTreeSize :: InlineContext -> CaseTree -> Size
caseTreeSize ic (ScrutOf bndr disc)
= case lookupBndr ic bndr of
- ArgNoInfo -> sizeN 0
- ArgIsNot {} -> sizeN (-disc) -- E.g. bndr is a DFun application
- -- T8732 need to inline mapM_
- ArgIsLam -> sizeN (-disc) -- Apply discount
- ArgIsCon {} -> sizeN (-disc) -- Apply discount
+ ArgNoInfo -> 0
+ ArgIsNot {} -> -disc -- E.g. bndr is a DFun application
+ -- T8732 need to inline mapM_
+ ArgIsLam -> -disc -- Apply discount
+ ArgIsCon {} -> -disc -- Apply discount
caseTreeSize ic (CaseOf scrut_var case_bndr alts)
= case lookupBndr ic scrut_var of
- ArgNoInfo -> keptCaseSize ic case_bndr alts
- ArgIsLam -> keptCaseSize ic case_bndr alts
- ArgIsNot cons -> keptCaseSize ic case_bndr (trim_alts cons alts)
+ ArgNoInfo -> keptCaseSize alts
+ ArgIsLam -> keptCaseSize alts
+ ArgIsNot cons -> keptCaseSize (trim_alts cons alts)
arg_summ@(ArgIsCon con args)
| Just at@(AltTree alt_con bndrs rhs) <- find_alt con alts
@@ -1143,7 +1151,7 @@ caseTreeSize ic (CaseOf scrut_var case_bndr alts)
exprTreeSize ic' rhs
| otherwise -- Happens for empty alternatives
- -> keptCaseSize ic case_bndr alts
+ -> keptCaseSize alts
find_alt :: AltCon -> [AltTree] -> Maybe AltTree
find_alt _ [] = Nothing
@@ -1162,28 +1170,20 @@ trim_alts acs (alt:alts)
| AltTree con _ _ <- alt, con `elem` acs = trim_alts acs alts
| otherwise = alt : trim_alts acs alts
-keptCaseSize :: InlineContext -> Id -> [AltTree] -> Size
+keptCaseSize :: [AltTree] -> Size
-- Size of a (retained) case expression
-keptCaseSize ic case_bndr 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
+keptCaseSize alts = foldr add_alt 0 alts
+ -- Just add up the sizes of the alternatives
+ -- We make the case itself free, but charge for each alternatives (that
+ -- is already included in the AltTrees
+ -- If there are no alternatives (case e of {}), we get zero
where
- size_alt :: AltTree -> Size
- size_alt (AltTree _ bndrs rhs)
- = exprTreeSize ic' rhs
- -- Cost for the alternative is already in `rhs`
- where
- -- Must extend ic_bound, lest a captured variable is
- -- looked up in ic_free by lookupBndr
- new_summaries :: [(Id,ArgSummary)]
- new_summaries = [(b,ArgNoInfo) | b <- case_bndr:bndrs]
- ic' = ic { ic_bound = ic_bound ic `extendVarEnvList` new_summaries }
+ add_alt :: AltTree -> Size -> Size
+ add_alt (AltTree _ _ (ExprTree { et_tot = tot })) n = n+tot
+ -- Cost for the alternative is already in `tot`
lookupBndr :: HasDebugCallStack => InlineContext -> Id -> ArgSummary
lookupBndr (IC { ic_bound = bound_env, ic_free = lookup_free }) var
| Just info <- assertPpr (isId var) (ppr var) $
lookupVarEnv bound_env var = info
| otherwise = lookup_free var
-
-
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1f12a52edf520f7f6776daad02dd72daf562fa6b...417d47c6eb3565af96ea2fbe6c45410527a102f7
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1f12a52edf520f7f6776daad02dd72daf562fa6b...417d47c6eb3565af96ea2fbe6c45410527a102f7
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/20231025/71c45d33/attachment-0001.html>
More information about the ghc-commits
mailing list