[Git][ghc/ghc][wip/T22388] Boxity: Handle argument budget of unboxed tuples correctly (#21737)
Sebastian Graf (@sgraf812)
gitlab at gitlab.haskell.org
Mon Nov 7 13:38:16 UTC 2022
Sebastian Graf pushed to branch wip/T22388 at Glasgow Haskell Compiler / GHC
Commits:
317fc94a by Sebastian Graf at 2022-11-07T14:37:59+01:00
Boxity: Handle argument budget of unboxed tuples correctly (#21737)
Now Budget roughly tracks the combined width of all arguments after unarisation.
See the changes to `Note [Worker argument budgets]`.
Fixes #21737.
- - - - -
5 changed files:
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs
- + testsuite/tests/stranal/sigs/T21737.hs
- + testsuite/tests/stranal/sigs/T21737.stderr
- testsuite/tests/stranal/sigs/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -45,6 +45,7 @@ import GHC.Builtin.PrimOps
import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )
import GHC.Types.Unique.Set
import GHC.Types.Unique.MemoFun
+import GHC.Types.RepType
{-
@@ -1771,10 +1772,36 @@ limit the maximum number of worker args to the maximum of
We pursue a "layered" strategy for unboxing: we unbox the top level of the
argument(s), subject to budget; if there are any arguments left we unbox the
next layer, using that depleted budget.
+Unboxing an argument *increases* the budget for the inner layer roughly
+according to how many registers that argument takes (unboxed tuples take
+multiple registers!), as determined by 'unariseArity'.
+Budget is spent when we have to pass a non-absent field as a parameter.
To achieve this, we use the classic almost-circular programming technique in
which we we write one pass that takes a lazy list of the Budgets for every
-layer.
+layer. The effect is that of a breadth-first search (over argument type and
+demand structure) to compute Budgets followed by a depth-first search to
+construct the product demands, but laziness allows us to do it all in one
+pass and without intermediate data structures.
+
+There's a bit of complication as a result of handling unboxed tuples correctly;
+Specifically, handling nested unboxed tuples. Consider (#21737)
+
+ yes_nested :: (Int, Int) -> (# Int, (# Int, Int, Int #) #) -> Int
+ yes_nested (a,b) (# c, (# d, e, f #) #) = a + b + c + d + e + f
+
+Suppose we have -fmax-worker-args=4. Then `yes_nested` will have 5 arguments
+at runtime anyway because of the nested unboxed tuple which will be unarised to
+4 args. So it's best to leave `(a,b)` boxed (because we already are above our
+arg threshold), but unbox `c` through `f` because that doesn't increase the
+number of args post unarisation.
+
+For that to work, our budget calculations must initialise with a budget of 5,
+based on the `unariseArity` of each arg (which looks at the number of primreps).
+When we encounter an unboxed tuple, we spent budget according to `unariseArity`,
+which is 4 for the unboxed pair. In doing so, we have *also* spent the budget
+for the nested unboxed triple as well as for the other field! Hence our algo
+tracks in a flag whether we are looking at an unboxed field.
Note [The OPAQUE pragma and avoiding the reboxing of arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1795,10 +1822,17 @@ W/W-transformation code that boxed arguments of 'f' must definitely be passed
along in boxed form and as such dissuade the creation of reboxing workers.
-}
+-- | How many registers does this type take after unarisation?
+unariseArity :: Type -> Arity
+unariseArity ty = length (typePrimRep ty)
+
data Budgets = MkB Arity Budgets -- An infinite list of arity budgets
-incTopBudget :: Budgets -> Budgets
-incTopBudget (MkB n bg) = MkB (n+1) bg
+earnTopBudget :: Arity -> Budgets -> Budgets
+earnTopBudget m (MkB n bg) = MkB (n+m) bg
+
+spendTopBudget :: Arity -> Budgets -> Budgets
+spendTopBudget m (MkB n bg) = MkB (n-m) bg
positiveTopBudget :: Budgets -> Bool
positiveTopBudget (MkB n _) = n >= 0
@@ -1811,7 +1845,8 @@ finaliseArgBoxities env fn arity rhs div
-- Then there are no binders; we don't worker/wrapper; and we
-- simply want to give f the same demand signature as g
- | otherwise
+ | otherwise -- NB: arity is the threshold_arity, which might be less than
+ -- manifest arity for join points
= -- pprTrace "finaliseArgBoxities" (
-- vcat [text "function:" <+> ppr fn
-- , text "dmds before:" <+> ppr (map idDemandInfo (filter isId bndrs))
@@ -1823,13 +1858,15 @@ finaliseArgBoxities env fn arity rhs div
where
opts = ae_opts env
(bndrs, _body) = collectBinders rhs
- max_wkr_args = dmd_max_worker_args opts `max` arity
+ unarise_arity = sum [ length (typePrimRep (idType b)) | b <- bndrs, isId b ]
+ max_wkr_args = dmd_max_worker_args opts `max` unarise_arity
-- See Note [Worker argument budget]
-- This is the key line, which uses almost-circular programming
-- The remaining budget from one layer becomes the initial
-- budget for the next layer down. See Note [Worker argument budget]
- (remaining_budget, arg_dmds') = go_args (MkB max_wkr_args remaining_budget) arg_triples
+ -- False <=> Not trying to unbox a field of an unboxed tuple here
+ (remaining_budget, arg_dmds') = go_args False (MkB max_wkr_args remaining_budget) arg_triples
arg_triples :: [(Type, StrictnessMark, Demand)]
arg_triples = take arity $
@@ -1860,30 +1897,43 @@ finaliseArgBoxities env fn arity rhs div
-- is_bot_fn: see Note [Boxity for bottoming functions]
is_bot_fn = div == botDiv
- go_args :: Budgets -> [(Type,StrictnessMark,Demand)] -> (Budgets, [Demand])
- go_args bg triples = mapAccumL go_arg bg triples
+ -- in_ubx_fld: see Note [Worker argument budget]
+ go_args :: Bool -> Budgets -> [(Type,StrictnessMark,Demand)] -> (Budgets, [Demand])
+ go_args in_ubx_fld bg triples = mapAccumL (go_arg in_ubx_fld) bg triples
- go_arg :: Budgets -> (Type,StrictnessMark,Demand) -> (Budgets, Demand)
- go_arg bg@(MkB bg_top bg_inner) (ty, str_mark, dmd@(n :* _))
+ -- in_ubx_fld: see Note [Worker argument budget]
+ go_arg :: Bool -> Budgets -> (Type,StrictnessMark,Demand) -> (Budgets, Demand)
+ go_arg in_ubx_fld bg@(MkB bg_top bg_inner) (ty, str_mark, dmd@(n :* _))
= case wantToUnboxArg env ty str_mark dmd of
DropAbsent -> (bg, dmd)
- DontUnbox | is_bot_fn, isTyVarTy ty -> (decremented_bg, dmd)
- | otherwise -> (decremented_bg, trimBoxity dmd)
+ DontUnbox | is_bot_fn, isTyVarTy ty -> (retain_budget, dmd)
+ | otherwise -> (retain_budget, trimBoxity dmd)
-- If bot: Keep deep boxity even though WW won't unbox
-- See Note [Boxity for bottoming functions] case (A)
-- trimBoxity: see Note [No lazy, Unboxed demands in demand signature]
- DoUnbox triples -> (MkB (bg_top-1) final_bg_inner, final_dmd)
+ DoUnbox triples
+ -> (spendTopBudget cost (MkB bg_top final_bg_inner), final_dmd)
where
- (bg_inner', dmds') = go_args (incTopBudget bg_inner) triples
- -- incTopBudget: give one back for the arg we are unboxing
+ (bg_inner', dmds') = go_args (isUnboxedTupleType ty) (earnTopBudget cost bg_inner) triples
+ -- earnTopBudget: give back the cost of the arg we are
+ -- unboxing, because that is about how many registers are
+ -- freed by unboxing.
dmd' = n :* (mkProd Unboxed $! dmds')
(final_bg_inner, final_dmd)
| positiveTopBudget bg_inner' = (bg_inner', dmd')
| otherwise = (bg_inner, trimBoxity dmd)
where
- decremented_bg = MkB (bg_top-1) bg_inner
+ -- in_ubx_fld: see Note [Worker argument budget]
+ -- True <=> we are looking at the field of an unboxed tuple
+ -- The cost of retaining these fields is 0, because they have already
+ -- been spent for when deciding to unbox the tuple in the first place.
+ cost | in_ubx_fld = 0
+ | otherwise = unariseArity ty
+ retain_budget = spendTopBudget cost bg
+ -- spendTopBudget: spend from our budget the cost of the
+ -- arg we are retaining.
add_demands :: [Demand] -> CoreExpr -> CoreExpr
-- Attach the demands to the outer lambdas of this expression
=====================================
compiler/GHC/Core/Opt/WorkWrap/Utils.hs
=====================================
@@ -15,7 +15,7 @@ module GHC.Core.Opt.WorkWrap.Utils
, findTypeShape, IsRecDataConResult(..), isRecDataCon
, mkAbsentFiller
, isWorkerSmallEnough, dubiousDataConInstArgTys
- , badWorker , goodWorker
+ , boringSplit , usefulSplit
)
where
@@ -571,19 +571,24 @@ data UnboxingDecision unboxing_info
-- returned product was constructed, so unbox it.
| DropAbsent -- ^ The argument/field was absent. Drop it.
--- Do we want to create workers just for unlifting?
-wwForUnlifting :: WwOpts -> Bool
-wwForUnlifting !opts
+-- | Do we want to create workers just for unlifting?
+wwUseForUnlifting :: WwOpts -> WwUse
+wwUseForUnlifting !opts
-- Always unlift if possible
- | wo_unlift_strict opts = goodWorker
+ | wo_unlift_strict opts = usefulSplit
-- Don't unlift it would cause additional W/W splits.
- | otherwise = badWorker
+ | otherwise = boringSplit
-badWorker :: Bool
-badWorker = False
+-- | Is the worker/wrapper split profitable?
+type WwUse = Bool
-goodWorker :: Bool
-goodWorker = True
+-- | WW split not profitable
+boringSplit :: Bool
+boringSplit = False
+
+-- | WW split profitable
+usefulSplit :: Bool
+usefulSplit = True
-- | Unwraps the 'Boxity' decision encoded in the given 'SubDemand' and returns
-- a 'DataConPatContext' as well the nested demands on fields of the 'DataCon'
@@ -822,7 +827,7 @@ Is this a win? Not always:
So there is a flag, `-fworker-wrapper-cbv`, to control whether we do
w/w on strict arguments (internally `Opt_WorkerWrapperUnlift`). The
flag is off by default. The choice is made in
-GHC.Core.Opt.WorkWrape.Utils.wwForUnlifting
+GHC.Core.Opt.WorkWrape.Utils.wwUseForUnlifting
See also `Note [WW for calling convention]` in GHC.Core.Opt.WorkWrap.Utils
-}
@@ -839,7 +844,7 @@ mkWWstr :: WwOpts
-> [Var] -- Wrapper args; have their demand info on them
-- *Includes type variables*
-> [StrictnessMark] -- Strictness-mark info for arguments
- -> UniqSM (Bool, -- Will this result in a useful worker
+ -> UniqSM (WwUse, -- Will this result in a useful worker
[(Var,StrictnessMark)], -- Worker args/their call-by-value semantics.
CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call
-- and without its lambdas
@@ -851,7 +856,7 @@ mkWWstr opts args str_marks
= -- pprTrace "mkWWstr" (ppr args) $
go args str_marks
where
- go [] _ = return (badWorker, [], nop_fn, [])
+ go [] _ = return (boringSplit, [], nop_fn, [])
go (arg : args) (str:strs)
= do { (useful1, args1, wrap_fn1, wrap_arg) <- mkWWstr_one opts arg str
; (useful2, args2, wrap_fn2, wrap_args) <- go args strs
@@ -871,7 +876,7 @@ mkWWstr opts args str_marks
mkWWstr_one :: WwOpts
-> Var
-> StrictnessMark
- -> UniqSM (Bool, [(Var,StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
+ -> UniqSM (WwUse, [(Var,StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
mkWWstr_one opts arg str_mark =
-- pprTrace "mkWWstr_one" (ppr arg <+> (if isId arg then ppr arg_ty $$ ppr arg_dmd else text "type arg")) $
case canUnboxArg fam_envs arg_ty arg_dmd of
@@ -883,7 +888,7 @@ mkWWstr_one opts arg str_mark =
-- We can't always handle absence for arbitrary
-- unlifted types, so we need to choose just the cases we can
-- (that's what mkAbsentFiller does)
- -> return (goodWorker, [], nop_fn, absent_filler)
+ -> return (usefulSplit, [], nop_fn, absent_filler)
| otherwise -> do_nothing
DoUnbox dcpc -> -- pprTrace "mkWWstr_one:1" (ppr (dcpc_dc dcpc) <+> ppr (dcpc_tc_args dcpc) $$ ppr (dcpc_args dcpc)) $
@@ -891,12 +896,12 @@ mkWWstr_one opts arg str_mark =
DontUnbox
| isStrictDmd arg_dmd || isMarkedStrict str_mark
- , wwForUnlifting opts -- See Note [CBV Function Ids]
+ , wwUseForUnlifting opts -- See Note [CBV Function Ids]
, not (isFunTy arg_ty)
, not (isUnliftedType arg_ty) -- Already unlifted!
-- NB: function arguments have a fixed RuntimeRep,
-- so it's OK to call isUnliftedType here
- -> return (goodWorker, [(arg, MarkedStrict)], nop_fn, varToCoreExpr arg )
+ -> return (usefulSplit, [(arg, MarkedStrict)], nop_fn, varToCoreExpr arg )
| otherwise -> do_nothing
@@ -906,11 +911,11 @@ mkWWstr_one opts arg str_mark =
arg_dmd = idDemandInfo arg
arg_str | isTyVar arg = NotMarkedStrict -- Type args don't get strictness marks
| otherwise = str_mark
- do_nothing = return (badWorker, [(arg,arg_str)], nop_fn, varToCoreExpr arg)
+ do_nothing = return (boringSplit, [(arg,arg_str)], nop_fn, varToCoreExpr arg)
unbox_one_arg :: WwOpts
-> Var -> DataConPatContext Demand
- -> UniqSM (Bool, [(Var,StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
+ -> UniqSM (WwUse, [(Var,StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
unbox_one_arg opts arg_var
DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args
, dcpc_co = co, dcpc_args = ds }
@@ -941,8 +946,8 @@ unbox_one_arg opts arg_var
; let wrap_arg = mkConApp dc (map Type tc_args ++ wrap_args) `mkCast` mkSymCo co
-- See Note [Unboxing through unboxed tuples]
; return $ if isUnboxedTupleDataCon dc && not nested_useful
- then (badWorker, [(arg_var,NotMarkedStrict)], nop_fn, varToCoreExpr arg_var)
- else (goodWorker, worker_args, unbox_fn . wrap_fn, wrap_arg) }
+ then (boringSplit, [(arg_var,NotMarkedStrict)], nop_fn, varToCoreExpr arg_var)
+ else (usefulSplit, worker_args, unbox_fn . wrap_fn, wrap_arg) }
-- | Tries to find a suitable absent filler to bind the given absent identifier
-- to. See Note [Absent fillers].
@@ -1210,7 +1215,7 @@ It's entirely pointless to "unbox" the triple
because after unarisation, `boring_arg` is just an alias for `$wboring_arg`.
Conclusion: Only consider unboxing an unboxed tuple useful when we will
-also unbox its components. That is governed by the `goodWorker` mechanism.
+also unbox its components. That is governed by the `usefulSplit` mechanism.
************************************************************************
* *
@@ -1393,12 +1398,12 @@ mkWWcpr_entry
:: WwOpts
-> Type -- function body
-> Cpr -- CPR analysis results
- -> UniqSM (Bool, -- Is w/w'ing useful?
+ -> UniqSM (WwUse, -- Is w/w'ing useful?
CoreExpr -> CoreExpr, -- New wrapper. 'nop_fn' if not useful
CoreExpr -> CoreExpr) -- New worker. 'nop_fn' if not useful
-- ^ Entrypoint to CPR W/W. See Note [Worker/wrapper for CPR] for an overview.
mkWWcpr_entry opts body_ty body_cpr
- | not (wo_cpr_anal opts) = return (badWorker, nop_fn, nop_fn)
+ | not (wo_cpr_anal opts) = return (boringSplit, nop_fn, nop_fn)
| otherwise = do
-- Part (1)
res_bndr <- mk_res_bndr body_ty
@@ -1415,8 +1420,8 @@ mkWWcpr_entry opts body_ty body_cpr
let wrap_fn = unbox_transit_tup rebuilt_result -- 3 2
work_fn body = bind_res_bndr body (work_unpack_res transit_tup) -- 1 2 3
return $ if not useful
- then (badWorker, nop_fn, nop_fn)
- else (goodWorker, wrap_fn, work_fn)
+ then (boringSplit, nop_fn, nop_fn)
+ else (usefulSplit, wrap_fn, work_fn)
-- | Part (1) of Note [Worker/wrapper for CPR].
mk_res_bndr :: Type -> UniqSM Id
@@ -1428,18 +1433,18 @@ mk_res_bndr body_ty = do
-- | What part (2) of Note [Worker/wrapper for CPR] collects.
--
--- 1. A Bool capturing whether the transformation did anything useful.
+-- 1. A 'WwUse' capturing whether the split does anything useful.
-- 2. The list of transit variables (see the Note).
-- 3. The result builder expression for the wrapper. The original case binder if not useful.
-- 4. The result unpacking expression for the worker. 'nop_fn' if not useful.
-type CprWwResultOne = (Bool, OrdList Var, CoreExpr , CoreExpr -> CoreExpr)
-type CprWwResultMany = (Bool, OrdList Var, [CoreExpr], CoreExpr -> CoreExpr)
+type CprWwResultOne = (WwUse, OrdList Var, CoreExpr , CoreExpr -> CoreExpr)
+type CprWwResultMany = (WwUse, OrdList Var, [CoreExpr], CoreExpr -> CoreExpr)
mkWWcpr :: WwOpts -> [Id] -> [Cpr] -> UniqSM CprWwResultMany
mkWWcpr _opts vars [] =
-- special case: No CPRs means all top (for example from FlatConCpr),
-- hence stop WW.
- return (badWorker, toOL vars, map varToCoreExpr vars, nop_fn)
+ return (boringSplit, toOL vars, map varToCoreExpr vars, nop_fn)
mkWWcpr opts vars cprs = do
-- No existentials in 'vars'. 'canUnboxResult' should have checked that.
massertPpr (not (any isTyVar vars)) (ppr vars $$ ppr cprs)
@@ -1458,7 +1463,7 @@ mkWWcpr_one opts res_bndr cpr
, DoUnbox dcpc <- canUnboxResult (wo_fam_envs opts) (idType res_bndr) cpr
= unbox_one_result opts res_bndr dcpc
| otherwise
- = return (badWorker, unitOL res_bndr, varToCoreExpr res_bndr, nop_fn)
+ = return (boringSplit, unitOL res_bndr, varToCoreExpr res_bndr, nop_fn)
unbox_one_result
:: WwOpts -> Id -> DataConPatContext Cpr -> UniqSM CprWwResultOne
@@ -1486,8 +1491,8 @@ unbox_one_result opts res_bndr
-- See Note [Unboxing through unboxed tuples]
return $ if isUnboxedTupleDataCon dc && not nested_useful
- then ( badWorker, unitOL res_bndr, Var res_bndr, nop_fn )
- else ( goodWorker
+ then ( boringSplit, unitOL res_bndr, Var res_bndr, nop_fn )
+ else ( usefulSplit
, transit_vars
, rebuilt_result
, this_work_unbox_res . work_unbox_res
=====================================
testsuite/tests/stranal/sigs/T21737.hs
=====================================
@@ -0,0 +1,37 @@
+{-# OPTIONS_GHC -fmax-worker-args=4 #-}
+
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+
+-- See Note [Worker argument budget]
+module T21737 where
+
+data T = MkT (# Int, Int, Int, Int #)
+
+-- NB: -fmax-worker-args=4 at the top of this file!
+-- We should unbox through the unboxed pair but not T
+{-# NOINLINE f #-}
+f :: Int -> (# Int, Int #) -> T -> Int
+f x (# y, z #) (MkT (# x1, x2, x3, x4 #)) = x + y + z + x1 + x2 + x3 + x4
+
+-- NB: -fmax-worker-args=4 at the top of this file!
+-- Do split the triple *even if* that gets us to 6 args,
+-- because the triple will take 3 registers anyway (not 1)
+-- and we get to unbox a b c.
+yes :: (# Int, Int, Int #) -> Int -> Int -> Int -> Int
+yes (# a, b, c #) d e f = a + b + c + d + e + f
+{-# NOINLINE yes #-}
+
+data U = MkU (# Int, Int, Int, Int, Int, Int #)
+
+-- NB: -fmax-worker-args=4 at the top of this file!
+-- Don't unbox U, because then we'll pass an unboxed 6-tuple, all in registers.
+no :: U -> Int
+no (MkU (# a, b, c, d, e, f #)) = a + b + c + d + e + f
+{-# NOINLINE no #-}
+
+-- NB: -fmax-worker-args=4 at the top of this file!
+-- Do split the inner unboxed triple *even if* that gets us to 5 args, because
+-- the function will take 5 args anyway. But don't split the pair!
+yes_nested :: (Int, Int) -> (# Int, (# Int, Int, Int #) #) -> Int
+yes_nested (a,b) (# c, (# d, e, f #) #) = a + b + c + d + e + f
+{-# NOINLINE yes_nested #-}
=====================================
testsuite/tests/stranal/sigs/T21737.stderr
=====================================
@@ -0,0 +1,24 @@
+
+==================== Strictness signatures ====================
+T21737.f: <1!P(L)><1!P(1!P(L),1!P(L))><1P(1P(1L,1L,1L,1L))>
+T21737.no: <1P(1P(1L,1L,1L,1L,1L,1L))>
+T21737.yes: <1!P(1!P(L),1!P(L),1!P(L))><1!P(L)><1!P(L)><1!P(L)>
+T21737.yes_nested: <1P(1L,1L)><1!P(1!P(L),1!P(1!P(L),1!P(L),1!P(L)))>
+
+
+
+==================== Cpr signatures ====================
+T21737.f: 1
+T21737.no: 1
+T21737.yes: 1
+T21737.yes_nested: 1
+
+
+
+==================== Strictness signatures ====================
+T21737.f: <1!P(L)><1!P(1!P(L),1!P(L))><1P(1P(1L,1L,1L,1L))>
+T21737.no: <1P(1P(1L,1L,1L,1L,1L,1L))>
+T21737.yes: <1!P(1!P(L),1!P(L),1!P(L))><1!P(L)><1!P(L)><1!P(L)>
+T21737.yes_nested: <1P(1L,1L)><1!P(1!P(L),1!P(1!P(L),1!P(L),1!P(L)))>
+
+
=====================================
testsuite/tests/stranal/sigs/all.T
=====================================
@@ -38,3 +38,4 @@ test('T21754', normal, compile, [''])
test('T21888', normal, compile, [''])
test('T21888a', normal, compile, [''])
test('T22241', normal, compile, [''])
+test('T21737', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/317fc94a26ef189161a22343291830c130374225
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/317fc94a26ef189161a22343291830c130374225
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/20221107/3e9a6bf6/attachment-0001.html>
More information about the ghc-commits
mailing list