[Git][ghc/ghc][wip/spj-unf-size] More improvements
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Thu Nov 2 17:43:22 UTC 2023
Simon Peyton Jones pushed to branch wip/spj-unf-size at Glasgow Haskell Compiler / GHC
Commits:
35e4e67f by Simon Peyton Jones at 2023-11-02T17:42:00+00:00
More improvements
Mainly doing the result-discounts as before.
Some skirmishing about dealing with knownCon.. more to come
- - - - -
5 changed files:
- compiler/GHC/Core.hs
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/Simplify/Inline.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Core/Unfold.hs
Changes:
=====================================
compiler/GHC/Core.hs
=====================================
@@ -1401,10 +1401,12 @@ type Size = Int
type Discount = Int
data ExprTree
- = ExprTree { et_wc_tot :: {-# UNPACK #-} !Size -- ^ Worst-case size of whole tree
- , et_size :: {-# UNPACK #-} !Size -- ^ Size of the bit apart from et_cases
- , et_ret :: {-# UNPACK #-} !Discount -- ^ Discount when result is scrutinised
- , et_cases :: Bag CaseTree
+ = ExprTree { et_wc_tot :: {-# UNPACK #-} !Size -- ^ Total worst-case size of whole tree
+ , et_ret :: {-# UNPACK #-} !Discount -- ^ Total discount when result is scrutinised
+ -- Both et_wc_tot and et_rec /include/ et_cases
+
+ , et_size :: {-# UNPACK #-} !Size -- ^ Size of the tree /apart from/ et_cases
+ , et_cases :: Bag CaseTree -- ^ Case exprsions and discounts
}
data CaseTree
=====================================
compiler/GHC/Core/Opt/Simplify/Env.hs
=====================================
@@ -931,9 +931,9 @@ refineFromInScope :: HasDebugCallStack => SimplMode -> InScopeSet -> Var -> Var
refineFromInScope mode in_scope v
| isLocalId v = case lookupInScope in_scope v of
Just v' -> v'
- Nothing -> -- pprPanic "refineFromInScope" (ppr in_scope $$ ppr v)
- pprTrace "refineFromInScope"
- (ppr (sm_module mode) <+> ppr v) v
+ Nothing -> pprPanic "refineFromInScope" (ppr (sm_module mode) $$ ppr v $$ ppr in_scope)
+ -- pprTrace "refineFromInScope"
+ -- (ppr (sm_module mode) <+> ppr v) v
-- c.f #19074 for a subtle place where this went wrong
| otherwise = v
=====================================
compiler/GHC/Core/Opt/Simplify/Inline.hs
=====================================
@@ -597,11 +597,21 @@ exprSummary env e = go env e []
go env (Tick _ e) as = go env e as
go env (App f a) as | isValArg a = go env f (a:as)
| otherwise = go env f as
- go env (Let b e) as = go env' e as
- where
- env' = env `addNewInScopeIds` bindersOf b
- go env (Var v) as
+ -- Look through let-expressions
+ go env (Let b e) as
+ | let env' = env `addNewInScopeIds` bindersOf b
+ = go env' e as
+
+{-
+ -- Look through single-branch case-expressions; like lets
+ go env (Case _ b _ alts) as
+ | [Alt _ bs e] <- alts
+ , let env' = env `addNewInScopeIds` (b:bs)
+ = go env' e as
+-}
+
+ go env (Var v) as
= -- Simplify.Env.substId Looks up in substitution
-- /and/ refines from the InScopeset
case substId env v of
=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -1336,6 +1336,7 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr
-- CPR'd workers getting inlined back into their wrappers,
| idArity fun == 0
, Just rhs <- expandUnfolding_maybe unfolding
+-- If `fun` is in the in-scope set then the free var of its RHS should be too
, let in_scope' = extend_in_scope (exprFreeVars rhs)
= go (Left in_scope') floats rhs cont
=====================================
compiler/GHC/Core/Unfold.hs
=====================================
@@ -618,7 +618,13 @@ exprTree opts args expr
-- When this scrutinee has structure, we expect to eliminate the case
go_alts remaining_case_depth vs b alts)
where
- rcd1 = remaining_case_depth - 1
+ -- Decremement remaining case depth when going inside
+ -- a case with more than one alternative.
+ -- Don't do so for single-alt cases, becuase they don't give rise
+ -- to exponential blow-up, and it's very common to have deep nests
+ -- of case x of (a,b) -> case a of I# a' -> ...
+ rcd1 | isSingleton alts = remaining_case_depth
+ | otherwise = remaining_case_depth - 1
alt_alt_tree :: Id -> Alt Var -> Maybe AltTree
alt_alt_tree v (Alt con bs rhs)
@@ -1054,7 +1060,8 @@ metAddAlt bOMB_OUT_SIZE (Just et1) (Just et2)
else Just (ExprTree { et_wc_tot = t12
, et_size = n1 + n2
, et_cases = c1 `unionBags` c2
- , et_ret = ret1 + ret2 })
+ , et_ret = ret1 + ret2 -- See Note [Result discount for case alternatives]
+ })
-- | The "expression tree"; an abstraction of the RHS of the function
@@ -1069,11 +1076,13 @@ etCaseOf :: Size -> Id -> Id -> [AltTree] -> Maybe ExprTree
-- is a variable) but charge for each alternative (included in `altTreesSize`)
etCaseOf bOMB_OUT_SIZE scrut case_bndr alts
| tot >= bOMB_OUT_SIZE = Nothing
- | otherwise = Just (ExprTree { et_wc_tot = tot, et_size = 0, et_ret = 0
+ | otherwise = Just (ExprTree { et_wc_tot = tot, et_ret = ret
+ , et_size = 0
, et_cases = unitBag case_tree })
where
case_tree = CaseOf scrut case_bndr alts
tot = altTreesSize alts
+ ret = altTreesDiscount alts
altTreesSize :: [AltTree] -> Size
-- Total worst-case size of a [AltTree], including the per-alternative cost of altSize
@@ -1082,9 +1091,25 @@ altTreesSize alts = foldl' add_alt 0 alts
add_alt n (AltTree _ _ (ExprTree { et_wc_tot = alt_tot }))
= n + alt_tot + altSize
+altTreesDiscount :: [AltTree] -> Discount
+-- See Note [Result discount for case alternatives]
+altTreesDiscount alts = foldl' add_alt 0 alts
+ where
+ add_alt n (AltTree _ _ (ExprTree { et_ret = ret })) = n + ret
+
etScrutOf :: Id -> Discount -> ExprTree
etScrutOf v d = etZero { et_cases = unitBag (ScrutOf v d) }
+{- Note [Result discount for case alternatives]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When adding the size of alternatives, we *add* the result discounts
+too, rather than take the *maximum*. For a multi-branch case, this
+gives a discount for each branch that returns a constructor, making us
+keener to inline. I did try using 'max' instead, but it makes nofib
+'rewrite' and 'puzzle' allocate significantly more, and didn't make
+binary sizes shrink significantly either.
+-}
+
{- *********************************************************************
* *
From ExprTree to Size
@@ -1128,6 +1153,7 @@ exprTreeSize !ic (ExprTree { et_size = size
, et_cases = cases
, et_ret = ret_discount })
= foldr ((+) . caseTreeSize (ic { ic_want_res = False }))
+ -- False: all result discount is at the top; ignore inner ones
discounted_size cases
where
discounted_size | ic_want_res ic = size - ret_discount
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/35e4e67fd287d7a42e204b97b6390b0b7098e70f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/35e4e67fd287d7a42e204b97b6390b0b7098e70f
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/20231102/19404e7e/attachment-0001.html>
More information about the ghc-commits
mailing list