Generalise reallyUnsafePtrEquality# and use it

fixes #9192 and #17126
updates containers submodule

1. Changes the type of the primop `reallyUnsafePtrEquality#` to the most
general version possible (heterogeneous as well as levity-polymorphic):

> reallyUnsafePtrEquality#
>   :: forall {l :: Levity} {k :: Levity}
>        (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k))
>   . a -> b -> Int#

2. Adds a new internal module, `GHC.Ext.PtrEq`, which contains pointer
equality operations that are now subsumed by `reallyUnsafePtrEquality#`.
These functions are then re-exported by `GHC.Exts` (so that no function
goes missing from the export list of `GHC.Exts`, which is user-facing).
More specifically, `GHC.Ext.PtrEq` defines:

  - A new function:
    * reallyUnsafePtrEquality :: forall (a :: Type). a -> a -> Int#

  - Library definitions of ex-primops:
     * `sameMutableArray#`
     * `sameSmallMutableArray`
     * `sameMutableByteArray#`
     * `sameMutableArrayArray#`
     * `sameMutVar#`
     * `sameTVar#`
     * `sameMVar#`
     * `sameIOPort#`
     * `eqStableName#`

  - New functions for comparing non-mutable arrays:
     * `sameArray#`
     * `sameSmallArray#`
     * `sameByteArray#`
     * `sameArrayArray#`

  These were requested in #9192.

Generally speaking, existing libraries that
use `reallyUnsafePtrEquality#` will continue to work with the new,
levity-polymorphic version. But not all!
Some (`containers`, `unordered-containers`, `dependent-map`) contain
the following:

> unsafeCoerce# reallyUnsafePtrEquality# a b

If we make `reallyUnsafePtrEquality#` levity-polymorphic, this code
fails the current GHC representation-polymorphism checks.
We agreed that the right solution here is to modify the library;
in this case by deleting the call to `unsafeCoerce#`,
since `reallyUnsafePtrEquality#` is now type-heterogeneous too.

8 files changed, 84 insertions, 0 deletions

diff --git a/testsuite/tests/primops/should_fail/LevPolyPtrEquality3.hs b/testsuite/tests/primops/should_fail/LevPolyPtrEquality3.hs
new file mode 100644
index 0000000000..b5c3da4f91
--- /dev/null
+++ b/testsuite/tests/primops/should_fail/LevPolyPtrEquality3.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE MagicHash #-}
+
+module LevPolyPtrEquality3 where
+
+import GHC.Exts
+  ( Int#
+  , unsafeCoerce#, reallyUnsafePtrEquality#
+  )
+
+f :: a -> b -> Int#
+f a b = unsafeCoerce# reallyUnsafePtrEquality# a b
diff --git a/testsuite/tests/primops/should_fail/LevPolyPtrEquality3.stderr b/testsuite/tests/primops/should_fail/LevPolyPtrEquality3.stderr
new file mode 100644
index 0000000000..279f32428b
--- /dev/null
+++ b/testsuite/tests/primops/should_fail/LevPolyPtrEquality3.stderr
@@ -0,0 +1,11 @@
+
+LevPolyPtrEquality3.hs:11:23: error:
+    Cannot use function with representation-polymorphic arguments:
+      reallyUnsafePtrEquality# :: GHC.Types.Any -> GHC.Types.Any -> Int#
+    (Note that representation-polymorphic primops,
+    such as 'coerce' and unboxed tuples, are eta-expanded
+    internally because they must occur fully saturated.
+    Use -fprint-typechecker-elaboration to display the full expression.)
+    Representation-polymorphic arguments:
+      GHC.Types.Any :: TYPE ('GHC.Types.BoxedRep GHC.Types.Any)
+      GHC.Types.Any :: TYPE ('GHC.Types.BoxedRep GHC.Types.Any)
diff --git a/testsuite/tests/primops/should_fail/all.T b/testsuite/tests/primops/should_fail/all.T
new file mode 100644
index 0000000000..f599102c23
--- /dev/null
+++ b/testsuite/tests/primops/should_fail/all.T
@@ -0,0 +1 @@
+test('LevPolyPtrEquality3', normal, compile_fail, [''])
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..ef52bd3de1
--- /dev/null
+++ b/testsuite/tests/primops/should_run/LevPolyPtrEquality2.hs
@@ -0,0 +1,28 @@
+{-# 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
+    d :: Either Bool Int
+    d = Right 1
+  putStr "eq a b: "
+  print $ isTrue# ( reallyUnsafePtrEquality# a b )
+  putStr "eq a c: "
+  print $ isTrue# ( reallyUnsafePtrEquality# a c )
+  putStr "eq a d: "
+  print $ isTrue# ( reallyUnsafePtrEquality# a d )
diff --git a/testsuite/tests/primops/should_run/LevPolyPtrEquality2.stdout b/testsuite/tests/primops/should_run/LevPolyPtrEquality2.stdout
new file mode 100644
index 0000000000..b06eeb90d0
--- /dev/null
+++ b/testsuite/tests/primops/should_run/LevPolyPtrEquality2.stdout
@@ -0,0 +1,3 @@
+eq a b: True
+eq a c: False
+eq a d: 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, [''])