Make GHC.Types.Id.Make.shouldUnpackTy a bit more clever

As #23307, GHC.Types.Id.Make.shouldUnpackTy was leaving money on the
table, failing to unpack arguments that are perfectly unpackable.

The fix is pretty easy; see Note [Recursive unboxing]

8 files changed, 176 insertions, 0 deletions

diff --git a/testsuite/tests/simplCore/should_compile/T23307.hs b/testsuite/tests/simplCore/should_compile/T23307.hs
new file mode 100644
index 0000000000..3cc6f676ad
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T23307.hs
@@ -0,0 +1,5 @@
+module T23307 where
+
+data Stream a = Nil | Cons a !(Stream a)
+data Unconsed a = Unconsed a !(Stream a)
+data MUnconsed a = No | Yes {-# UNPACK #-} !(Unconsed a)
diff --git a/testsuite/tests/simplCore/should_compile/T23307.stderr b/testsuite/tests/simplCore/should_compile/T23307.stderr
new file mode 100644
index 0000000000..f42016e9a8
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T23307.stderr
@@ -0,0 +1,72 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+  = {terms: 29, types: 40, coercions: 0, joins: 0/0}
+
+-- RHS size: {terms: 8, types: 9, coercions: 0, joins: 0/0}
+T23307.$WYes [InlPrag=INLINE[final] CONLIKE]
+  :: forall a. Unconsed a %1 -> MUnconsed a
+[GblId[DataConWrapper],
+ Arity=1,
+ Str=<SL>,
+ 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= \ (@a) (conrep [Occ=Once1!] :: Unconsed a) ->
+                 case conrep of { Unconsed unbx [Occ=Once1] unbx1 [Occ=Once1] ->
+                 T23307.Yes @a unbx unbx1
+                 }}]
+T23307.$WYes
+  = \ (@a) (conrep [Occ=Once1!] :: Unconsed a) ->
+      case conrep of { Unconsed unbx [Occ=Once1] unbx1 [Occ=Once1] ->
+      T23307.Yes @a unbx unbx1
+      }
+
+-- RHS size: {terms: 9, types: 7, coercions: 0, joins: 0/0}
+T23307.$WUnconsed [InlPrag=INLINE[final] CONLIKE]
+  :: forall a. a %1 -> Stream a %1 -> Unconsed a
+[GblId[DataConWrapper],
+ Arity=2,
+ Str=<L><SL>,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)
+         Tmpl= \ (@a)
+                 (conrep [Occ=Once1] :: a)
+                 (conrep1 [Occ=Once1] :: Stream a) ->
+                 case conrep1 of conrep2 [Occ=Once1] { __DEFAULT ->
+                 T23307.Unconsed @a conrep conrep2
+                 }}]
+T23307.$WUnconsed
+  = \ (@a)
+      (conrep [Occ=Once1] :: a)
+      (conrep1 [Occ=Once1] :: Stream a) ->
+      case conrep1 of conrep2 [Occ=Once1] { __DEFAULT ->
+      T23307.Unconsed @a conrep conrep2
+      }
+
+-- RHS size: {terms: 9, types: 7, coercions: 0, joins: 0/0}
+T23307.$WCons [InlPrag=INLINE[final] CONLIKE]
+  :: forall a. a %1 -> Stream a %1 -> Stream a
+[GblId[DataConWrapper],
+ Arity=2,
+ Str=<L><SL>,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)
+         Tmpl= \ (@a)
+                 (conrep [Occ=Once1] :: a)
+                 (conrep1 [Occ=Once1] :: Stream a) ->
+                 case conrep1 of conrep2 [Occ=Once1] { __DEFAULT ->
+                 T23307.Cons @a conrep conrep2
+                 }}]
+T23307.$WCons
+  = \ (@a)
+      (conrep [Occ=Once1] :: a)
+      (conrep1 [Occ=Once1] :: Stream a) ->
+      case conrep1 of conrep2 [Occ=Once1] { __DEFAULT ->
+      T23307.Cons @a conrep conrep2
+      }
+
+
+
diff --git a/testsuite/tests/simplCore/should_compile/T23307a.hs b/testsuite/tests/simplCore/should_compile/T23307a.hs
new file mode 100644
index 0000000000..f02fee86b4
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T23307a.hs
@@ -0,0 +1,7 @@
+module T23307a where
+
+data List a = Nil | Cons {-# UNPACK #-} !(Unconsed a)
+                    -- This UNPACK should work
+
+data Unconsed a = Unconsed a !(List a)
+data MUnconsed a = No | Yes {-# UNPACK #-} !(Unconsed a)
\ No newline at end of file
diff --git a/testsuite/tests/simplCore/should_compile/T23307a.stderr b/testsuite/tests/simplCore/should_compile/T23307a.stderr
new file mode 100644
index 0000000000..415edf23f9
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T23307a.stderr
@@ -0,0 +1,68 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+  = {terms: 28, types: 41, coercions: 0, joins: 0/0}
+
+-- RHS size: {terms: 8, types: 9, coercions: 0, joins: 0/0}
+T23307a.$WYes [InlPrag=INLINE[final] CONLIKE]
+  :: forall a. Unconsed a %1 -> MUnconsed a
+[GblId[DataConWrapper],
+ Arity=1,
+ Str=<SL>,
+ 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= \ (@a) (conrep [Occ=Once1!] :: Unconsed a) ->
+                 case conrep of { Unconsed unbx [Occ=Once1] unbx1 [Occ=Once1] ->
+                 T23307a.Yes @a unbx unbx1
+                 }}]
+T23307a.$WYes
+  = \ (@a) (conrep [Occ=Once1!] :: Unconsed a) ->
+      case conrep of { Unconsed unbx [Occ=Once1] unbx1 [Occ=Once1] ->
+      T23307a.Yes @a unbx unbx1
+      }
+
+-- RHS size: {terms: 9, types: 7, coercions: 0, joins: 0/0}
+T23307a.$WUnconsed [InlPrag=INLINE[final] CONLIKE]
+  :: forall a. a %1 -> List a %1 -> Unconsed a
+[GblId[DataConWrapper],
+ Arity=2,
+ Str=<L><SL>,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)
+         Tmpl= \ (@a)
+                 (conrep [Occ=Once1] :: a)
+                 (conrep1 [Occ=Once1] :: List a) ->
+                 case conrep1 of conrep2 [Occ=Once1] { __DEFAULT ->
+                 T23307a.Unconsed @a conrep conrep2
+                 }}]
+T23307a.$WUnconsed
+  = \ (@a)
+      (conrep [Occ=Once1] :: a)
+      (conrep1 [Occ=Once1] :: List a) ->
+      case conrep1 of conrep2 [Occ=Once1] { __DEFAULT ->
+      T23307a.Unconsed @a conrep conrep2
+      }
+
+-- RHS size: {terms: 8, types: 9, coercions: 0, joins: 0/0}
+T23307a.$WCons [InlPrag=INLINE[final] CONLIKE]
+  :: forall a. Unconsed a %1 -> List a
+[GblId[DataConWrapper],
+ Arity=1,
+ Str=<SL>,
+ 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= \ (@a) (conrep [Occ=Once1!] :: Unconsed a) ->
+                 case conrep of { Unconsed unbx [Occ=Once1] unbx1 [Occ=Once1] ->
+                 T23307a.Cons @a unbx unbx1
+                 }}]
+T23307a.$WCons
+  = \ (@a) (conrep [Occ=Once1!] :: Unconsed a) ->
+      case conrep of { Unconsed unbx [Occ=Once1] unbx1 [Occ=Once1] ->
+      T23307a.Cons @a unbx unbx1
+      }
+
+
+
diff --git a/testsuite/tests/simplCore/should_compile/T23307b.hs b/testsuite/tests/simplCore/should_compile/T23307b.hs
new file mode 100644
index 0000000000..bde4f4da7e
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T23307b.hs
@@ -0,0 +1,7 @@
+module Foo where
+
+-- It's easy to get an infinite loop
+-- when deciding what to unbox here.
+
+data T = MkT !S Int
+data S = MkS !T
\ No newline at end of file
diff --git a/testsuite/tests/simplCore/should_compile/T23307c.hs b/testsuite/tests/simplCore/should_compile/T23307c.hs
new file mode 100644
index 0000000000..a0d4de1cfa
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T23307c.hs
@@ -0,0 +1,7 @@
+module Foo where
+
+newtype Identity x = MkId x
+newtype Fix f = MkFix (f (Fix f))
+
+-- This test just checks that the compiler itself doesn't loop
+data Loop = LCon {-# UNPACK #-} !(Fix Identity)
diff --git a/testsuite/tests/simplCore/should_compile/T23307c.stderr b/testsuite/tests/simplCore/should_compile/T23307c.stderr
new file mode 100644
index 0000000000..b55b886583
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T23307c.stderr
@@ -0,0 +1,5 @@
+
+T23307c.hs:7:13: warning: [GHC-40091]
+    • Ignoring unusable UNPACK pragma on the first argument of ‘LCon’
+    • In the definition of data constructor ‘LCon’
+      In the data type declaration for ‘Loop’
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index a472aa05d9..b1ec7473ff 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -479,3 +479,8 @@ test('T23024', normal, multimod_compile, ['T23024', '-O -v0'])
 test('T23026', normal, compile, ['-O'])
 test('T23267', [expect_broken(23267), only_ways(['ghci']), extra_hc_opts('-fno-unoptimized-core-for-interpreter -fspec-constr')], ghci_script, ['T23267.script'])
 test('T23362', normal, compile, ['-O'])
+test('T23307', normal, compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-uniques'])
+test('T23307a', normal, compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-uniques'])
+test('T23307b', normal, compile, ['-O'])
+test('T23307c', normal, compile, ['-O'])
+