Worker/wrapper: Refactor CPR WW to work for nested CPR (#18174)wip/nested-cpr-ww

In another small step towards bringing a manageable variant of Nested
CPR into GHC, this patch refactors worker/wrapper to be able to exploit
Nested CPR signatures. See the new Note [Worker/wrapper for CPR].

The nested code path is currently not triggered, though, because all
signatures that we annotate are still flat. So purely a refactoring.
I am very confident that it works, because I ripped it off !1866 95%
unchanged.

A few test case outputs changed, but only it's auxiliary names only.
I also added test cases for #18109 and #18401.

There's a 2.6% metric increase in T13056 after a rebase, caused by an
additional Simplifier run. It appears b1d0b9c saw a similar additional
iteration. I think it's just a fluke.

Metric Increase:
    T13056

5 files changed, 137 insertions, 0 deletions

diff --git a/testsuite/tests/cpranal/should_compile/T18109.hs b/testsuite/tests/cpranal/should_compile/T18109.hs
new file mode 100644
index 0000000000..5c52a187c9
--- /dev/null
+++ b/testsuite/tests/cpranal/should_compile/T18109.hs
@@ -0,0 +1,25 @@
+{-# OPTIONS_GHC -O2 -fforce-recomp -dno-typeable-binds #-}
+
+-- | These are all examples where the CPR worker should not return an unboxed
+-- singleton tuple of the field, but rather the single field directly.
+-- This is OK if the field indeed terminates quickly;
+-- see Note [No unboxed tuple for single, unlifted transit var]
+module T18109 where
+
+data F = F (Int -> Int)
+
+f :: Int -> F
+f n = F (+n)
+{-# NOINLINE f #-}
+
+data T = T (Int, Int)
+
+g :: T -> T
+g t@(T p) = p `seq` t
+{-# NOINLINE g #-}
+
+data U = U ![Int]
+
+h :: Int -> U
+h n = U [0..n]
+{-# NOINLINE h #-}
diff --git a/testsuite/tests/cpranal/should_compile/T18109.stderr b/testsuite/tests/cpranal/should_compile/T18109.stderr
new file mode 100644
index 0000000000..ad92bdda17
--- /dev/null
+++ b/testsuite/tests/cpranal/should_compile/T18109.stderr
@@ -0,0 +1,51 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core = {terms: 78, types: 81, coercions: 0, joins: 0/1}
+
+-- RHS size: {terms: 6, types: 4, coercions: 0, joins: 0/0}
+T18109.$WU :: [Int] %1 -> U
+T18109.$WU = \ (dt_aDr :: [Int]) -> case dt_aDr of dt_X0 { __DEFAULT -> T18109.U dt_X0 }
+
+-- RHS size: {terms: 6, types: 12, coercions: 0, joins: 0/0}
+T18109.$wg :: (Int, Int) -> (# (Int, Int) #)
+T18109.$wg = \ (ww_sKr :: (Int, Int)) -> case ww_sKr of p_X2 { (ipv_sIU, ipv1_sIV) -> (# p_X2 #) }
+
+-- RHS size: {terms: 10, types: 13, coercions: 0, joins: 0/0}
+g :: T -> T
+g = \ (w_sKp :: T) -> case w_sKp of { T ww_sKr -> case T18109.$wg ww_sKr of { (# ww1_sKJ #) -> T18109.T ww1_sKJ } }
+
+-- RHS size: {terms: 6, types: 5, coercions: 0, joins: 0/0}
+T18109.$wf :: Int -> (# Int -> Int #)
+T18109.$wf = \ (w_sKw :: Int) -> (# \ (v_B2 :: Int) -> GHC.Num.$fNumInt_$c+ v_B2 w_sKw #)
+
+-- RHS size: {terms: 7, types: 7, coercions: 0, joins: 0/0}
+f :: Int -> F
+f = \ (w_sKw :: Int) -> case T18109.$wf w_sKw of { (# ww_sKL #) -> T18109.F ww_sKL }
+
+-- RHS size: {terms: 26, types: 10, coercions: 0, joins: 0/1}
+T18109.$wh :: GHC.Prim.Int# -> [Int]
+T18109.$wh
+  = \ (ww_sKE :: GHC.Prim.Int#) ->
+      case GHC.Prim.># 0# ww_sKE of {
+        __DEFAULT ->
+          letrec {
+            go3_aKm :: GHC.Prim.Int# -> [Int]
+            go3_aKm
+              = \ (x_aKn :: GHC.Prim.Int#) ->
+                  GHC.Types.:
+                    @Int
+                    (GHC.Types.I# x_aKn)
+                    (case GHC.Prim.==# x_aKn ww_sKE of {
+                       __DEFAULT -> go3_aKm (GHC.Prim.+# x_aKn 1#);
+                       1# -> GHC.Types.[] @Int
+                     }); } in
+          go3_aKm 0#;
+        1# -> GHC.Types.[] @Int
+      }
+
+-- RHS size: {terms: 10, types: 5, coercions: 0, joins: 0/0}
+h :: Int -> U
+h = \ (w_sKC :: Int) -> case w_sKC of { GHC.Types.I# ww_sKE -> case T18109.$wh ww_sKE of ww1_sKN { __DEFAULT -> T18109.U ww1_sKN } }
+
+
+
diff --git a/testsuite/tests/cpranal/should_compile/T18401.hs b/testsuite/tests/cpranal/should_compile/T18401.hs
new file mode 100644
index 0000000000..c850d9a7e0
--- /dev/null
+++ b/testsuite/tests/cpranal/should_compile/T18401.hs
@@ -0,0 +1,20 @@
+{-# OPTIONS_GHC -O2 -fforce-recomp -dno-typeable-binds #-}
+
+module T18401 where
+
+-- | A safe version of `init`.
+-- @safeInit [] = Nothing@
+-- @safeInit xs = Just $ init xs@
+safeInit :: [a] -> Maybe [a]
+safeInit xs = case si xs of
+  (False, _) -> Nothing
+  (_, ys) -> Just ys
+
+si :: [a] -> (Bool, [a])
+si xs0 = foldr go stop xs0 Nothing
+  where
+    stop Nothing = (False, [])
+    stop _ = (True, [])
+    go x r Nothing = (True, snd (r (Just x)))
+    go x r (Just p) = (True, p : snd (r (Just x)))
+
diff --git a/testsuite/tests/cpranal/should_compile/T18401.stderr b/testsuite/tests/cpranal/should_compile/T18401.stderr
new file mode 100644
index 0000000000..e299ba4dc7
--- /dev/null
+++ b/testsuite/tests/cpranal/should_compile/T18401.stderr
@@ -0,0 +1,35 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core = {terms: 54, types: 101, coercions: 0, joins: 0/0}
+
+Rec {
+-- RHS size: {terms: 20, types: 31, coercions: 0, joins: 0/0}
+T18401.safeInit_$spoly_$wgo1 :: forall {a}. a -> [a] -> (# Bool, [a] #)
+T18401.safeInit_$spoly_$wgo1
+  = \ (@a_aO1) (sc_s17W :: a_aO1) (sc1_s17V :: [a_aO1]) ->
+      case sc1_s17V of {
+        [] -> (# GHC.Types.True, GHC.Types.[] @a_aO1 #);
+        : y_a158 ys_a159 -> (# GHC.Types.True, GHC.Types.: @a_aO1 sc_s17W (case T18401.safeInit_$spoly_$wgo1 @a_aO1 y_a158 ys_a159 of { (# ww_s17y, ww1_s17z #) -> ww1_s17z }) #)
+      }
+end Rec }
+
+-- RHS size: {terms: 17, types: 25, coercions: 0, joins: 0/0}
+si :: forall a. [a] -> (Bool, [a])
+si
+  = \ (@a_s17i) (w_s17j :: [a_s17i]) ->
+      case w_s17j of {
+        [] -> (GHC.Types.False, GHC.Types.[] @a_s17i);
+        : y_a158 ys_a159 -> (GHC.Types.True, case T18401.safeInit_$spoly_$wgo1 @a_s17i y_a158 ys_a159 of { (# ww_X3, ww1_X4 #) -> ww1_X4 })
+      }
+
+-- RHS size: {terms: 14, types: 22, coercions: 0, joins: 0/0}
+safeInit :: forall a. [a] -> Maybe [a]
+safeInit
+  = \ (@a_aO1) (xs_aus :: [a_aO1]) ->
+      case xs_aus of {
+        [] -> GHC.Maybe.Nothing @[a_aO1];
+        : y_a158 ys_a159 -> GHC.Maybe.Just @[a_aO1] (case T18401.safeInit_$spoly_$wgo1 @a_aO1 y_a158 ys_a159 of { (# ww_X3, ww1_X4 #) -> ww1_X4 })
+      }
+
+
+
diff --git a/testsuite/tests/cpranal/should_compile/all.T b/testsuite/tests/cpranal/should_compile/all.T
index 5a37f42376..d70d978be6 100644
--- a/testsuite/tests/cpranal/should_compile/all.T
+++ b/testsuite/tests/cpranal/should_compile/all.T
@@ -5,3 +5,9 @@ def f( name, opts ):
 setTestOpts(f)
 
 test('Cpr001', [], multimod_compile, ['Cpr001', '-v0'])
+# The following tests grep for type signatures of worker functions.
+test('T18109', [ grep_errmsg(r'^T18109\.\$w\S+ ::') ], compile, ['-ddump-simpl -dsuppress-idinfo -dppr-cols=9999'])
+# T18401 probably needs -flate-dmd-anal so that it runs after SpecConstr.
+# It is currently broken, but not marked expect_broken. We can't know the exact
+# name of the function before it is fixed, so expect_broken doesn't make sense.
+test('T18401', [ grep_errmsg(r'^T18401\.\S+ ::') ], compile, ['-ddump-simpl -dsuppress-idinfo -dppr-cols=9999 -flate-dmd-anal'])