[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 09:45:36 UTC 2022
Sebastian Graf pushed to branch wip/T22388 at Glasgow Haskell Compiler / GHC
Commits:
6024df44 by Sebastian Graf at 2022-11-07T10:44:41+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/Type.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
=====================================
@@ -1771,10 +1771,17 @@ 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.
Note [The OPAQUE pragma and avoiding the reboxing of arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1795,10 +1802,18 @@ 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.
-}
+unariseArity :: Type -> Arity
+unariseArity ty
+ | Just reps <- isFixedArityUnboxedTupleType_maybe ty = length reps
+ | otherwise = 1
+
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
@@ -1816,6 +1831,7 @@ finaliseArgBoxities env fn arity rhs div
-- vcat [text "function:" <+> ppr fn
-- , text "dmds before:" <+> ppr (map idDemandInfo (filter isId bndrs))
-- , text "dmds after: " <+> ppr arg_dmds' ]) $
+ assert (arity == count isId bndrs) $
Just (arg_dmds', add_demands arg_dmds' rhs)
-- add_demands: we must attach the final boxities to the lambda-binders
-- of the function, both because that's kosher, and because CPR analysis
@@ -1823,7 +1839,8 @@ 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 [ unariseArity (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
@@ -1868,22 +1885,28 @@ finaliseArgBoxities env fn arity rhs div
= 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 width (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 (earnTopBudget width bg_inner) triples
+ -- earnTopBudget: give back the width 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
+ width = unariseArity ty
+ retain_budget = spendTopBudget width bg
+ -- spendTopBudget: spend from our budget the width of the
+ -- arg we are retaining.
add_demands :: [Demand] -> CoreExpr -> CoreExpr
-- Attach the demands to the outer lambdas of this expression
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -127,7 +127,8 @@ module GHC.Core.Type (
isLiftedRuntimeRep, isUnliftedRuntimeRep, runtimeRepLevity_maybe,
isBoxedRuntimeRep,
isLiftedLevity, isUnliftedLevity,
- isUnliftedType, isBoxedType, isUnboxedTupleType, isUnboxedSumType,
+ isUnliftedType, isBoxedType,
+ isUnboxedTupleType, isFixedArityUnboxedTupleType_maybe, isUnboxedSumType,
kindBoxedRepLevity_maybe,
mightBeLiftedType, mightBeUnliftedType,
isAlgType, isDataFamilyAppType,
@@ -2564,6 +2565,21 @@ isUnboxedTupleType ty
-- NB: Do not use typePrimRep, as that can't tell the difference between
-- unboxed tuples and unboxed sums
+isFixedArityUnboxedTupleType_maybe :: Type -> Maybe [RuntimeRepType]
+isFixedArityUnboxedTupleType_maybe ty
+ | Just rep <- getRuntimeRep_maybe ty
+ , Just (tc, [arg]) <- splitTyConApp_maybe rep
+ , tc `hasKey` tupleRepDataConKey
+ = extract_arg_reps (splitTyConApp_maybe arg)
+ | otherwise
+ = Nothing
+ where
+ extract_arg_reps (Just (tc, tc_args))
+ | [_] <- tc_args, tc `hasKey` nilDataConKey
+ = Just []
+ | [_,hd,tl] <- tc_args, tc `hasKey` consDataConKey
+ = (hd :) <$> extract_arg_reps (splitTyConApp_maybe tl)
+ extract_arg_reps _ = Nothing
isUnboxedSumType :: Type -> Bool
isUnboxedSumType ty
=====================================
testsuite/tests/stranal/sigs/T21737.hs
=====================================
@@ -0,0 +1,30 @@
+{-# 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 #-}
=====================================
testsuite/tests/stranal/sigs/T21737.stderr
=====================================
@@ -0,0 +1,21 @@
+
+==================== 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)>
+
+
+
+==================== Cpr signatures ====================
+T21737.f: 1
+T21737.no: 1
+T21737.yes: 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)>
+
+
=====================================
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/6024df448c560dbcdda5ecfdeef362b609a1e398
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6024df448c560dbcdda5ecfdeef362b609a1e398
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/f40dc16f/attachment-0001.html>
More information about the ghc-commits
mailing list