WorkWrap: Unboxing unboxed tuples is not always useful (#22388)

See Note [Unboxing through unboxed tuples].

Fixes #22388.

4 files changed, 136 insertions, 12 deletions

diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
index 28dab48941..c4b20f3b86 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
-   , isGoodWorker, badWorker , goodWorker
+   , badWorker , goodWorker
    )
 where
 
@@ -585,10 +585,6 @@ badWorker = False
 goodWorker :: Bool
 goodWorker = True
 
-isGoodWorker :: Bool -> Bool
-isGoodWorker = id
-
-
 -- | Unwraps the 'Boxity' decision encoded in the given 'SubDemand' and returns
 -- a 'DataConPatContext' as well the nested demands on fields of the 'DataCon'
 -- to unbox.
@@ -913,7 +909,7 @@ mkWWstr_one opts arg str_mark =
     do_nothing = return (badWorker, [(arg,arg_str)], nop_fn, varToCoreExpr arg)
 
 unbox_one_arg :: WwOpts
-              -> Var-> DataConPatContext Demand
+              -> Var -> DataConPatContext Demand
               -> UniqSM (Bool, [(Var,StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
 unbox_one_arg opts arg_var
               DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args
@@ -939,13 +935,14 @@ unbox_one_arg opts arg_var
              -- See Note [Call-by-value for worker args]
              all_str_marks = (map (const NotMarkedStrict) ex_tvs') ++ con_str_marks
 
-       ; (_sub_args_quality, worker_args, wrap_fn, wrap_args)
+       ; (nested_useful, worker_args, wrap_fn, wrap_args)
              <- mkWWstr opts (ex_tvs' ++ arg_ids') all_str_marks
 
        ; let wrap_arg = mkConApp dc (map Type tc_args ++ wrap_args) `mkCast` mkSymCo co
-
-       ; return (goodWorker, worker_args, unbox_fn . wrap_fn, wrap_arg) }
-                          -- Don't pass the arg, rebox instead
+       -- 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) }
 
 -- | Tries to find a suitable absent filler to bind the given absent identifier
 -- to. See Note [Absent fillers].
@@ -1195,6 +1192,26 @@ fragile
    because `MkT` is strict in its Int# argument, so we get an absentError
    exception when we shouldn't.  Very annoying!
 
+Note [Unboxing through unboxed tuples]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We should not to a worker/wrapper split just for unboxing the components of
+an unboxed tuple (in the result *or* argument, #22388). Consider
+  boring_res x y = (# y, x #)
+It's entirely pointless to split for the constructed unboxed pair to
+  $wboring_res x y = (# y, x #)
+  boring_res = case $wboring_res x y of (# a, b #) -> (# a, b #)
+`boring_res` will immediately simplify to an alias for `$wboring_res`!
+
+Similarly, the unboxed tuple might occur in argument position
+  boring_arg (# x, y, z #) = (# z, x, y #)
+It's entirely pointless to "unbox" the triple
+  $wboring_arg x y z = (# z, x, y #)
+  boring_arg (# x, y, z #) = $wboring_arg x y z
+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.
+
 ************************************************************************
 *                                                                      *
          Type scrutiny that is specific to demand analysis
@@ -1467,8 +1484,7 @@ unbox_one_result opts res_bndr
       -- this_work_unbox_res alt = (case res_bndr |> co of C a b -> <alt>[a,b])
       this_work_unbox_res = mkUnpackCase (Var res_bndr) co cprCaseBndrMult dc arg_ids
 
-  -- Don't try to WW an unboxed tuple return type when there's nothing inside
-  -- to unbox further.
+  -- 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
diff --git a/testsuite/tests/stranal/should_compile/T22388.hs b/testsuite/tests/stranal/should_compile/T22388.hs
new file mode 100644
index 0000000000..87ae9e6fa0
--- /dev/null
+++ b/testsuite/tests/stranal/should_compile/T22388.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+
+-- See Note [Unboxing through unboxed tuples]
+module T22388 where
+
+-- Don't split, because neither the result not arg cancels away a box.
+boring :: (# Int, Int, Int #) -> (# Int, Int, Int #)
+boring (# x, y, z #) = (# y, z, x #)
+{-# NOINLINE boring #-}
+
+-- Do split, because we get to drop z and pass x and y unboxed
+interesting :: (# Int, Int, Int #) -> (# Int #)
+interesting (# x, y, z #) = let !t = x + y in (# t #)
+{-# NOINLINE interesting #-}
diff --git a/testsuite/tests/stranal/should_compile/T22388.stderr b/testsuite/tests/stranal/should_compile/T22388.stderr
new file mode 100644
index 0000000000..25342cb4f6
--- /dev/null
+++ b/testsuite/tests/stranal/should_compile/T22388.stderr
@@ -0,0 +1,92 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+  = {terms: 48, types: 81, coercions: 0, joins: 0/0}
+
+-- RHS size: {terms: 8, types: 23, coercions: 0, joins: 0/0}
+boring [InlPrag=NOINLINE]
+  :: (# Int, Int, Int #) -> (# Int, Int, Int #)
+[GblId, Arity=1, Str=<1!P(L,L,L)>, Cpr=1, Unf=OtherCon []]
+boring
+  = \ (ds :: (# Int, Int, Int #)) ->
+      case ds of { (# x, y, z #) -> (# y, z, x #) }
+
+-- RHS size: {terms: 5, types: 2, coercions: 0, joins: 0/0}
+T22388.$winteresting [InlPrag=NOINLINE]
+  :: GHC.Prim.Int# -> GHC.Prim.Int# -> GHC.Prim.Int#
+[GblId, Arity=2, Str=<L><L>, Unf=OtherCon []]
+T22388.$winteresting
+  = \ (ww :: GHC.Prim.Int#) (ww1 :: GHC.Prim.Int#) ->
+      GHC.Prim.+# ww ww1
+
+-- RHS size: {terms: 18, types: 24, coercions: 0, joins: 0/0}
+interesting [InlPrag=NOINLINE[final]]
+  :: (# Int, Int, Int #) -> (# Int #)
+[GblId,
+ Arity=1,
+ Str=<1!P(1!P(L),1!P(L),A)>,
+ Cpr=1(1),
+ Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True,
+         Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
+         Tmpl= \ (ds [Occ=Once1!] :: (# Int, Int, Int #)) ->
+                 case ds of
+                 { (# ww [Occ=Once1!], ww1 [Occ=Once1!], _ [Occ=Dead] #) ->
+                 case ww of { GHC.Types.I# ww3 [Occ=Once1] ->
+                 case ww1 of { GHC.Types.I# ww4 [Occ=Once1] ->
+                 case T22388.$winteresting ww3 ww4 of ww5 [Occ=Once1] { __DEFAULT ->
+                 (# GHC.Types.I# ww5 #)
+                 }
+                 }
+                 }
+                 }}]
+interesting
+  = \ (ds :: (# Int, Int, Int #)) ->
+      case ds of { (# ww, ww1, ww2 #) ->
+      case ww of { GHC.Types.I# ww3 ->
+      case ww1 of { GHC.Types.I# ww4 ->
+      case T22388.$winteresting ww3 ww4 of ww5 { __DEFAULT ->
+      (# GHC.Types.I# ww5 #)
+      }
+      }
+      }
+      }
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T22388.$trModule4 :: GHC.Prim.Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+T22388.$trModule4 = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T22388.$trModule3 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T22388.$trModule3 = GHC.Types.TrNameS T22388.$trModule4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T22388.$trModule2 :: GHC.Prim.Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+T22388.$trModule2 = "T22388"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T22388.$trModule1 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T22388.$trModule1 = GHC.Types.TrNameS T22388.$trModule2
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T22388.$trModule :: GHC.Types.Module
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T22388.$trModule
+  = GHC.Types.Module T22388.$trModule3 T22388.$trModule1
+
+
+
diff --git a/testsuite/tests/stranal/should_compile/all.T b/testsuite/tests/stranal/should_compile/all.T
index 6dd65a9fcb..c5f142567f 100644
--- a/testsuite/tests/stranal/should_compile/all.T
+++ b/testsuite/tests/stranal/should_compile/all.T
@@ -86,3 +86,5 @@ test('T21128', [ grep_errmsg(r'let { y = I\#') ], multimod_compile, ['T21128', '
 test('T21265', normal, compile, [''])
 test('EtaExpansion', normal, compile, [''])
 test('T22039', normal, compile, [''])
+# T22388: Should see $winteresting but not $wboring
+test('T22388', [ grep_errmsg(r'^\S+\$w\S+') ], compile, ['-dsuppress-uniques -ddump-simpl'])