Fix coercion optimisation for SelCo (#23362)

setNominalRole_maybe is supposed to output a nominal coercion.
In the SelCo case, it was not updating the stored role to Nominal,
causing #23362.

3 files changed, 34 insertions, 3 deletions

diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs
index 6459136973..9ffcabd3a3 100644
--- a/compiler/GHC/Core/Coercion.hs
+++ b/compiler/GHC/Core/Coercion.hs
@@ -1355,7 +1355,7 @@ mkProofIrrelCo r kco        g1 g2 = mkUnivCo (ProofIrrelProv kco) r
 -- | Converts a coercion to be nominal, if possible.
 -- See Note [Role twiddling functions]
 setNominalRole_maybe :: Role -- of input coercion
-                     -> Coercion -> Maybe Coercion
+                     -> Coercion -> Maybe CoercionN
 setNominalRole_maybe r co
   | r == Nominal = Just co
   | otherwise = setNominalRole_maybe_helper co
@@ -1380,10 +1380,19 @@ setNominalRole_maybe r co
       = AppCo <$> setNominalRole_maybe_helper co1 <*> pure co2
     setNominalRole_maybe_helper (ForAllCo tv kind_co co)
       = ForAllCo tv kind_co <$> setNominalRole_maybe_helper co
-    setNominalRole_maybe_helper (SelCo n co)
+    setNominalRole_maybe_helper (SelCo cs co) =
       -- NB, this case recurses via setNominalRole_maybe, not
       -- setNominalRole_maybe_helper!
-      = SelCo n <$> setNominalRole_maybe (coercionRole co) co
+      case cs of
+        SelTyCon n _r ->
+          -- Remember to update the role in SelTyCon to nominal;
+          -- not doing this caused #23362.
+          -- See the typing rule in Note [SelCo] in GHC.Core.TyCo.Rep.
+          SelCo (SelTyCon n Nominal) <$> setNominalRole_maybe (coercionRole co) co
+        SelFun fs ->
+          SelCo (SelFun fs) <$> setNominalRole_maybe (coercionRole co) co
+        SelForAll ->
+          pprPanic "setNominalRole_maybe: the coercion should already be nominal" (ppr co)
     setNominalRole_maybe_helper (InstCo co arg)
       = InstCo <$> setNominalRole_maybe_helper co <*> pure arg
     setNominalRole_maybe_helper (UnivCo prov _ co1 co2)
diff --git a/testsuite/tests/simplCore/should_compile/T23362.hs b/testsuite/tests/simplCore/should_compile/T23362.hs
new file mode 100644
index 0000000000..5c096d9f89
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T23362.hs
@@ -0,0 +1,21 @@
+module T23362 where
+
+import Unsafe.Coerce
+import Data.Kind
+
+type Phantom :: Type -> Type
+data Phantom a = MkPhantom
+
+newtype Id a = MkId a
+newtype First a = MkFirst (Id a)
+data Second a = MkSecond (First a)
+data Third a = MkThird !(Second a)
+
+a :: Second (Phantom Int)
+a = MkSecond (MkFirst (MkId MkPhantom))
+
+uc :: Second (Phantom Int) -> Second (Phantom Bool)
+uc = unsafeCoerce
+
+b :: Third (Phantom Bool)
+b = MkThird (uc a)
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index ae48423fa0..a472aa05d9 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -478,3 +478,4 @@ test('RewriteHigherOrderPatterns', normal, compile, ['-O -ddump-rule-rewrites -d
 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'])