Make reallyUnsafePtrEquality# levity-polymorphic

fixes #17126, updates containers submodule

5 files changed, 59 insertions, 0 deletions

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, [''])