Boxity: Handle argument budget of unboxed tuples correctly (#21737)wip/T22388

Now Budget roughly tracks the combined width of all arguments after unarisation.
See the changes to `Note [Worker argument budgets]`.

Fixes #21737.

5 files changed, 252 insertions, 50 deletions

diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs
index c6c5d11926..c890d775bb 100644
--- a/compiler/GHC/Core/Opt/DmdAnal.hs
+++ b/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
 
 
 {-
@@ -1762,7 +1763,7 @@ Note [Worker argument budget]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 In 'finaliseArgBoxities' we don't want to generate workers with zillions of
 argument when, say given a strict record with zillions of fields.  So we
-limit the maximum number of worker args to the maximum of
+limit the maximum number of worker args ('max_wkr_args') to the maximum of
   - -fmax-worker-args=N
   - The number of args in the original function; if it already has has
     zillions of arguments we don't want to seek /fewer/ args in the worker.
@@ -1771,10 +1772,91 @@ 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, see below), 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.
+
+Suppose we have -fmax-worker-args=4 for the remainder of this Note.
+Then consider this example function:
+
+  boxed :: (Int, Int) -> (Int, (Int, Int, Int)) -> Int
+  boxed (a,b) (c, (d,e,f)) = a + b + c + d + e + f
+
+With a budget of 4 args to spend (number of args is only 2), we'd be served well
+to unbox both pairs, but not the triple. Indeed, that is what the algorithm
+computes, and the following pictogram shows how the budget layers are computed.
+Each layer is started with `n ~>`, where `n` is the budget at the start of the
+layer. We write -n~> when we spend budget (and n is the remaining budget) and
++n~> when we earn budget. We separate unboxed args with ][ and indicate
+inner budget threads becoming negative in braces {{}}, so that we see which
+unboxing decision we do *not* commit to. Without further ado:
+
+  4 ~> ][     (a,b) -3~>               ][     (c, ...) -2~>
+       ][      | |                     ][      |   |
+       ][      | +-------------+       ][      |   +-----------------+
+       ][      |               |       ][      |                     |
+       ][      v               v       ][      v                     v
+  2 ~> ][ +3~> a  -2~> ][      b  -1~> ][ +2~> c  -1~> ][        (d, e, f) -0~>
+       ][      |       ][      |       ][      |       ][ {{      |  |  |                          }}
+       ][      |       ][      |       ][      |       ][ {{      |  |  +----------------+         }}
+       ][      v       ][      v       ][      v       ][ {{      v  +------v            v         }}
+  0 ~> ][ +1~> I# -0~> ][ +1~> I# -0~> ][ +1~> I# -0~> ][ {{ +1~> d -0~> ][ e -(-1)~> ][ f -(-2)~> }}
+
+Unboxing increments the budget we have on the next layer (because we don't need
+to retain the boxed arg), but in turn the inner layer must afford to retain all
+non-absent fields, each decrementing the budget. Note how the budget becomes
+negative when trying to unbox the triple and the unboxing decision is "rolled
+back". This is done by the 'positiveTopBudget' guard.
+
+There's a bit of complication as a result of handling unboxed tuples correctly;
+specifically, handling nested unboxed tuples. Consider (#21737)
+
+  unboxed :: (Int, Int) -> (# Int, (# Int, Int, Int #) #) -> Int
+  unboxed (a,b) (# c, (# d, e, f #) #) = a + b + c + d + e + f
+
+Recall that unboxed tuples will be flattened to individual arguments during
+unarisation. Here, `unboxed` will have 5 arguments at runtime because of the
+nested unboxed tuple, which will be flattened 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.
+
+Note that the challenge is that syntactically, `(# d, e, f #)` occurs in a
+deeper layer than `(a, b)`. Treating unboxed tuples as a regular data type, we'd
+make the same unboxing decisions as for `boxed` above; although our starting
+budget is 5 (Here, the number of args is greater than -fmax-worker-args), it's
+not enough to unbox the triple (we'd finish with budget -1). So we'd unbox `a`
+through `c`, but not `d` through `f`, which is silly, because then we'd end up
+having 6 arguments at runtime, of which `d` through `f` weren't unboxed.
+
+Hence we pretend that the fields of unboxed tuples appear in the same budget
+layer as the tuple itself. For example at the top-level, `(# x,y #)` is to be
+treated just like two arguments `x` and `y`.
+Of course, for that to work, our budget calculations must initialise
+'max_wkr_args' to 5, based on the 'unariseArity' of each Core arg: That would be
+1 for the pair and 4 for the unboxed pair. Then when we decide whether to unbox
+the unboxed pair, we *directly* recurse into the fields, spending our budget
+on retaining `c` and (after recursing once more) `d` through `f` as arguments,
+depleting our budget completely in the first layer. Pictorially:
+
+  5 ~> ][         (a,b) -4~>             ][         (# c, ... #)
+       ][ {{      | |                 }} ][      c  -3~> ][ (# d, e, f #)
+       ][ {{      | +-------+         }} ][      |       ][      d  -2~> ][      e  -1~> ][      f  -0~>
+       ][ {{      |         |         }} ][      |       ][      |       ][      |       ][      |
+       ][ {{      v         v         }} ][      v       ][      v       ][      v       ][      v
+  0 ~> ][ {{ +1~> a -0~> ][ b -(-1)~> }} ][ +1~> I# -0~> ][ +1~> I# -0~> ][ +1~> I# -0~> ][ +1~> I# -0~>
+
+As you can see, we have no budget left to justify unboxing `(a,b)` on the second
+layer, which is good, because it would increase the number of args. Also note
+that we can still unbox `c` through `f` in this layer, because doing so has a
+net zero effect on budget.
 
 Note [The OPAQUE pragma and avoiding the reboxing of arguments]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1795,10 +1877,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.
 -}
 
-data Budgets = MkB Arity Budgets   -- An infinite list of arity budgets
+-- | How many registers does this type take after unarisation?
+unariseArity :: Type -> Arity
+unariseArity ty = length (typePrimRep ty)
 
-incTopBudget :: Budgets -> Budgets
-incTopBudget (MkB n bg) = MkB (n+1) bg
+data Budgets = MkB !Arity Budgets   -- An infinite list of arity budgets
+
+earnTopBudget :: Budgets -> Budgets
+earnTopBudget (MkB n bg) = MkB (n+1) bg
+
+spendTopBudget :: Arity -> Budgets -> Budgets
+spendTopBudget m (MkB n bg) = MkB (n-m) bg
 
 positiveTopBudget :: Budgets -> Bool
 positiveTopBudget (MkB n _) = n >= 0
@@ -1811,7 +1900,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,8 +1913,10 @@ 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
-                      -- See Note [Worker argument budget]
+    unarise_arity   = sum [ unariseArity (idType b) | b <- bndrs, isId b ]
+    max_wkr_args    = dmd_max_worker_args opts `max` unarise_arity
+                      -- This is the budget initialisation step of
+                      -- Note [Worker argument budget]
 
     -- This is the key line, which uses almost-circular programming
     -- The remaining budget from one layer becomes the initial
@@ -1868,22 +1960,49 @@ 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)
             where
-              (bg_inner', dmds') = go_args (incTopBudget bg_inner) triples
-                     -- incTopBudget: give one back for the arg we are unboxing
+              retain_budget = spendTopBudget (unariseArity ty) bg
+                -- spendTopBudget: spend from our budget the cost of the
+                -- retaining the arg
+                -- The unboxed case does happen here, for example
+                --   app g x = g x :: (# Int, Int #)
+                -- here, `x` is used `L`azy and thus Boxed
+
+          DoUnbox triples
+            | isUnboxedTupleType ty
+            , (bg', dmds') <- go_args bg triples
+            -> (bg', n :* (mkProd Unboxed $! dmds'))
+                     -- See Note [Worker argument budget]
+                     -- unboxed tuples are always unboxed, deeply
+                     -- NB: Recurse with bg, *not* bg_inner! The unboxed fields
+                     -- are at the same budget layer.
+
+            | isUnboxedSumType ty
+            -> pprPanic "Unboxing through unboxed sum" (ppr fn <+> ppr ty)
+                     -- We currently don't return DoUnbox for unboxed sums.
+                     -- But hopefully we will at some point. When that happens,
+                     -- it would still be impossible to predict the effect
+                     -- of dropping absent fields and unboxing others on the
+                     -- unariseArity of the sum without losing sanity.
+                     -- We could overwrite bg_top with the one from
+                     -- retain_budget while still unboxing inside the alts as in
+                     -- the tuple case for a conservative solution, though.
+
+            | otherwise
+            -> (spendTopBudget 1 (MkB bg_top final_bg_inner), final_dmd)
+            where
+              (bg_inner', dmds') = go_args (earnTopBudget bg_inner) triples
+                     -- earnTopBudget: give back the cost of retaining the
+                     -- arg we are insted unboxing.
               dmd' = n :* (mkProd Unboxed $! dmds')
-              (final_bg_inner, final_dmd)
+              ~(final_bg_inner, final_dmd) -- "~": This match *must* be lazy!
                  | positiveTopBudget bg_inner' = (bg_inner', dmd')
                  | otherwise                   = (bg_inner,  trimBoxity dmd)
-      where
-        decremented_bg = MkB (bg_top-1) bg_inner
 
     add_demands :: [Demand] -> CoreExpr -> CoreExpr
     -- Attach the demands to the outer lambdas of this expression
diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
index c4b20f3b86..faedaaeec0 100644
--- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
+++ b/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 :: WwUse
+boringSplit = False
+
+-- | WW split profitable
+usefulSplit :: WwUse
+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
diff --git a/testsuite/tests/stranal/sigs/T21737.hs b/testsuite/tests/stranal/sigs/T21737.hs
new file mode 100644
index 0000000000..e07365cab8
--- /dev/null
+++ b/testsuite/tests/stranal/sigs/T21737.hs
@@ -0,0 +1,47 @@
+{-# 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!
+-- Hence do not unbox the nested triple.
+boxed :: (Int, Int) -> (Int, (Int, Int, Int)) -> Int
+boxed (a,b) (c, (d,e,f)) = a + b + c + d + e + f
+{-# NOINLINE boxed #-}
+
+-- 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!
+unboxed :: (Int, Int) -> (# Int, (# Int, Int, Int #) #) -> Int
+unboxed (a,b) (# c, (# d, e, f #) #) = a + b + c + d + e + f
+{-# NOINLINE unboxed #-}
+
+-- Point: Demand on `x` is lazy and thus Unboxed
+app :: ((# Int, Int #) -> (# Int, Int #)) -> (# Int, Int #) -> (# Int, Int #)
+app g x = g x
diff --git a/testsuite/tests/stranal/sigs/T21737.stderr b/testsuite/tests/stranal/sigs/T21737.stderr
new file mode 100644
index 0000000000..fe4d92b628
--- /dev/null
+++ b/testsuite/tests/stranal/sigs/T21737.stderr
@@ -0,0 +1,30 @@
+
+==================== Strictness signatures ====================
+T21737.app: <1C(1,L)><L>
+T21737.boxed: <1!P(1!P(L),1!P(L))><1!P(1!P(L),1P(1L,1L,1L))>
+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.unboxed: <1P(1L,1L)><1!P(1!P(L),1!P(1!P(L),1!P(L),1!P(L)))>
+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.app:
+T21737.boxed: 1
+T21737.f: 1
+T21737.no: 1
+T21737.unboxed: 1
+T21737.yes: 1
+
+
+
+==================== Strictness signatures ====================
+T21737.app: <1C(1,L)><L>
+T21737.boxed: <1!P(1!P(L),1!P(L))><1!P(1!P(L),1P(1L,1L,1L))>
+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.unboxed: <1P(1L,1L)><1!P(1!P(L),1!P(1!P(L),1!P(L),1!P(L)))>
+T21737.yes: <1!P(1!P(L),1!P(L),1!P(L))><1!P(L)><1!P(L)><1!P(L)>
+
+
diff --git a/testsuite/tests/stranal/sigs/all.T b/testsuite/tests/stranal/sigs/all.T
index 01ea48cfe8..24969391b7 100644
--- a/testsuite/tests/stranal/sigs/all.T
+++ b/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, [''])