Make reallyUnsafePtrEquality# levity-polymorphic

fixes #17126, updates containers submodule

9 files changed, 76 insertions, 1 deletions

diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp
index 672b831ac7..145aed43a8 100644
--- a/compiler/GHC/Builtin/primops.txt.pp
+++ b/compiler/GHC/Builtin/primops.txt.pp
@@ -3058,7 +3058,7 @@ section "Unsafe pointer equality"
 ------------------------------------------------------------------------
 
 primop  ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp
-   a -> a -> Int#
+   v -> v -> Int#
    { Returns {\texttt 1\#} if the given pointers are equal and {\texttt 0\#} otherwise. }
    with
    can_fail   = True -- See Note [reallyUnsafePtrEquality#]
diff --git a/docs/users_guide/9.4.1-notes.rst b/docs/users_guide/9.4.1-notes.rst
index 68417b0a6b..04b44dd0e6 100644
--- a/docs/users_guide/9.4.1-notes.rst
+++ b/docs/users_guide/9.4.1-notes.rst
@@ -41,6 +41,13 @@ Version 9.4.1
 
         raise# :: forall (a :: Type) {r :: RuntimeRep} (b :: TYPE r). a -> b
 
+- ``GHC.Exts.reallyUnsafePtrEquality#`` is now levity-polymorphic: ::
+
+        reallyUnsafePtrEquality# :: forall {l :: Levity} (a :: TYPE (BoxedRep l)). a -> a -> Int#
+
+   This means that ``GHC.Exts.reallyUnsafePtrEquality#`` now works on primitive arrays,
+   such as ``GHC.Exts.Array#`` and ``GHC.Exts.ByteArray#``.
+
 ``ghc`` library
 ~~~~~~~~~~~~~~~
 
diff --git a/libraries/containers b/libraries/containers
-Subproject 7fb91ca53b1aca7c077b36a0c1f8f785d177da3
+Subproject f90e38cb170dcd68de8660dfd9d0e879921acc2
diff --git a/libraries/ghc-prim/changelog.md b/libraries/ghc-prim/changelog.md
index 122856346f..ec8df7904b 100644
--- a/libraries/ghc-prim/changelog.md
+++ b/libraries/ghc-prim/changelog.md
@@ -39,6 +39,15 @@
   raise# :: forall (a :: Type) {r :: RuntimeRep} (b :: TYPE r). a -> b
   ```
 
+- `reallyUnsafePtrEquality#` is now levity-polymorphic:
+
+   ```
+   reallyUnsafePtrEquality# :: forall {l :: Levity} (a :: TYPE (BoxedRep l)). a -> a -> Int#
+   ```
+
+   This means that `reallyUnsafePtrEquality#` now works on primitive arrays,
+   such as `Array#` and `ByteArray#`.
+
 
 ## 0.8.0 (edit as necessary)
 
diff --git a/testsuite/tests/primops/should_run/LevPolyPtrEquality1.hs b/testsuite/tests/primops/should_run/LevPolyPtrEquality1.hs
new file mode 100644
index 0000000000..bbd4819c7d
--- /dev/null
+++ b/testsuite/tests/primops/should_run/LevPolyPtrEquality1.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+module Main where
+
+import GHC.Exts
+import GHC.IO
+
+data ByteArray = ByteArray ByteArray#
+
+mkTwoByteArrays :: IO ( ByteArray, ByteArray )
+mkTwoByteArrays = IO \ s1 -> case newPinnedByteArray# 32# s1 of
+  (# s2, mba1 #) -> case unsafeFreezeByteArray# mba1 s2 of
+    (# s3, ba1 #) -> case newPinnedByteArray# 32# s3 of
+      (# s4, mba2 #) -> case unsafeFreezeByteArray# mba2 s4 of
+        (# s5, ba2 #) -> (# s5, ( ByteArray ba1, ByteArray ba2 ) #)
+
+main :: IO ()
+main = do
+  ( ByteArray ba1, ByteArray ba2 ) <- mkTwoByteArrays
+  putStr "eq 1 2: "
+  print $ isTrue# ( reallyUnsafePtrEquality# ba1 ba2 )
+  putStr "eq 1 1: "
+  print $ isTrue# ( reallyUnsafePtrEquality# ba1 ba1 )
diff --git a/testsuite/tests/primops/should_run/LevPolyPtrEquality1.stdout b/testsuite/tests/primops/should_run/LevPolyPtrEquality1.stdout
new file mode 100644
index 0000000000..aaf2e46dcf
--- /dev/null
+++ b/testsuite/tests/primops/should_run/LevPolyPtrEquality1.stdout
@@ -0,0 +1,2 @@
+eq 1 2: False
+eq 1 1: True
diff --git a/testsuite/tests/primops/should_run/LevPolyPtrEquality2.hs b/testsuite/tests/primops/should_run/LevPolyPtrEquality2.hs
new file mode 100644
index 0000000000..39be43ed29
--- /dev/null
+++ b/testsuite/tests/primops/should_run/LevPolyPtrEquality2.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnliftedDatatypes #-}
+
+module Main where
+
+import GHC.Exts
+import GHC.Types
+
+data PEither a b :: UnliftedType where
+  PLeft  :: a -> PEither a b
+  PRight :: b -> PEither a b
+
+main :: IO ()
+main = do
+  let
+    a, b, c :: PEither Bool Int
+    a = PRight 1
+    b = case a of { PLeft a -> PLeft (not a) ; r -> r }
+    c = PLeft False
+  putStr "eq a b: "
+  print $ isTrue# ( reallyUnsafePtrEquality# a b )
+  putStr "eq a c: "
+  print $ isTrue# ( reallyUnsafePtrEquality# a c )
+  putStr "eq b c: "
+  print $ isTrue# ( reallyUnsafePtrEquality# b c )
diff --git a/testsuite/tests/primops/should_run/LevPolyPtrEquality2.stdout b/testsuite/tests/primops/should_run/LevPolyPtrEquality2.stdout
new file mode 100644
index 0000000000..dfc7ac9454
--- /dev/null
+++ b/testsuite/tests/primops/should_run/LevPolyPtrEquality2.stdout
@@ -0,0 +1,3 @@
+eq a b: True
+eq a c: False
+eq b c: False
diff --git a/testsuite/tests/primops/should_run/all.T b/testsuite/tests/primops/should_run/all.T
index cad58c1909..ef046f34ae 100644
--- a/testsuite/tests/primops/should_run/all.T
+++ b/testsuite/tests/primops/should_run/all.T
@@ -38,3 +38,6 @@ test('T14664', normal, compile_and_run, [''])
 test('CStringLength', normal, compile_and_run, ['-O2'])
 test('NonNativeSwitch', normal, compile_and_run, ['-O2'])
 test('Sized', normal, compile_and_run, [''])
+
+test('LevPolyPtrEquality1', normal, compile_and_run, [''])
+test('LevPolyPtrEquality2', normal, compile_and_run, [''])