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.

19 files changed, 446 insertions, 90 deletions

diff --git a/compiler/GHC/Builtin/Types/Prim.hs b/compiler/GHC/Builtin/Types/Prim.hs
index c339125e9a..ce4f1e5dc0 100644
--- a/compiler/GHC/Builtin/Types/Prim.hs
+++ b/compiler/GHC/Builtin/Types/Prim.hs
@@ -28,13 +28,17 @@ module GHC.Builtin.Types.Prim(
         runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep3TyVar,
         runtimeRep1TyVarInf, runtimeRep2TyVarInf,
         runtimeRep1Ty, runtimeRep2Ty, runtimeRep3Ty,
-        levity1TyVar, levity1TyVarInf, levity1Ty,
+        levity1TyVar, levity2TyVar,
+        levity1TyVarInf, levity2TyVarInf,
+        levity1Ty, levity2Ty,
 
         openAlphaTyVar, openBetaTyVar, openGammaTyVar,
         openAlphaTyVarSpec, openBetaTyVarSpec, openGammaTyVarSpec,
         openAlphaTy, openBetaTy, openGammaTy,
 
-        levPolyTyVar1, levPolyTyVar1Spec, levPolyTy1,
+        levPolyAlphaTyVar, levPolyBetaTyVar,
+        levPolyAlphaTyVarSpec, levPolyBetaTyVarSpec,
+        levPolyAlphaTy, levPolyBetaTy,
 
         multiplicityTyVar1, multiplicityTyVar2,
 
@@ -416,25 +420,35 @@ openAlphaTy = mkTyVarTy openAlphaTyVar
 openBetaTy  = mkTyVarTy openBetaTyVar
 openGammaTy = mkTyVarTy openGammaTyVar
 
-levity1TyVar :: TyVar
-(levity1TyVar : _)
-  = drop 11 (mkTemplateTyVars (repeat levityTy)) -- selects 'l'
+levity1TyVar, levity2TyVar :: TyVar
+(levity2TyVar : levity1TyVar : _) -- NB: levity2TyVar before levity1TyVar
+  = drop 10 (mkTemplateTyVars (repeat levityTy)) -- selects 'k', 'l'
+-- The ordering of levity2TyVar before levity1TyVar is chosen so that
+-- the more common levity1TyVar uses the levity variable 'l'.
 
-levity1TyVarInf :: TyVarBinder
+levity1TyVarInf, levity2TyVarInf :: TyVarBinder
 levity1TyVarInf = mkTyVarBinder Inferred levity1TyVar
+levity2TyVarInf = mkTyVarBinder Inferred levity2TyVar
 
-levity1Ty :: Type
+levity1Ty, levity2Ty :: Type
 levity1Ty = mkTyVarTy levity1TyVar
-
-levPolyTyVar1 :: TyVar
-[levPolyTyVar1] = mkTemplateTyVars [tYPE (mkTyConApp boxedRepDataConTyCon [levity1Ty])]
--- tv :: TYPE ('BoxedRep l)
-
-levPolyTyVar1Spec :: TyVarBinder
-levPolyTyVar1Spec = mkTyVarBinder Specified levPolyTyVar1
-
-levPolyTy1 :: Type
-levPolyTy1 = mkTyVarTy levPolyTyVar1
+levity2Ty = mkTyVarTy levity2TyVar
+
+levPolyAlphaTyVar, levPolyBetaTyVar :: TyVar
+[levPolyAlphaTyVar, levPolyBetaTyVar] =
+  mkTemplateTyVars
+    [tYPE (mkTyConApp boxedRepDataConTyCon [levity1Ty])
+    ,tYPE (mkTyConApp boxedRepDataConTyCon [levity2Ty])]
+-- alpha :: TYPE ('BoxedRep l)
+-- beta  :: TYPE ('BoxedRep k)
+
+levPolyAlphaTyVarSpec, levPolyBetaTyVarSpec :: TyVarBinder
+levPolyAlphaTyVarSpec = mkTyVarBinder Specified levPolyAlphaTyVar
+levPolyBetaTyVarSpec  = mkTyVarBinder Specified levPolyBetaTyVar
+
+levPolyAlphaTy, levPolyBetaTy :: Type
+levPolyAlphaTy = mkTyVarTy levPolyAlphaTyVar
+levPolyBetaTy  = mkTyVarTy levPolyBetaTyVar
 
 multiplicityTyVar1, multiplicityTyVar2  :: TyVar
 (multiplicityTyVar1 : multiplicityTyVar2 : _)
diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp
index 25e673b192..5f5cd64cfa 100644
--- a/compiler/GHC/Builtin/primops.txt.pp
+++ b/compiler/GHC/Builtin/primops.txt.pp
@@ -187,6 +187,41 @@ defaults
 -- description fields should be legal latex. Descriptions can contain
 -- matched pairs of embedded curly brackets.
 
+-- Note [Levity and representation polymorphic primops]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- In the types of primops in this module,
+-- 
+-- * The names `a,b,c,s` stand for type variables of kind Type
+-- 
+-- * The names `v` and `w` stand for levity-polymorphic
+--   type variables.
+--   For example:
+--      op :: v -> w -> Int
+--   really means
+--      op :: forall {l :: Levity} (a :: TYPE (BoxedRep l))
+--                   {k :: Levity} (b :: TYPE (BoxedRep k)).
+--            a -> b -> Int
+--  Two important things to note:
+--     - `v` and `w` have independent levities `l` and `k` (respectively), and
+--       these are inferred (not specified), as seen from the curly brackets.
+--     - `v` and `w` end up written as `a` and `b` (respectively) in types,
+--       which means that one shouldn't write a primop type involving both
+--       `a` and `v`, nor `b` and `w`.
+-- 
+-- * The names `o` and `p` stand for representation-polymorphic
+--   type variables, similarly to `v` and `w` above. For example:
+--      op :: o -> p -> Int
+--   really means
+--      op :: forall {q :: RuntimeRep} (a :: TYPE q)
+--                   {r :: RuntimeRep} (b :: TYPE r)
+--            a -> b -> Int
+--   We note:
+--    - `o` and `p` have independent `RuntimeRep`s `q` and `r`, which are
+--       inferred type variables (like for `v` and `w` above).
+--    - `o` and `p` share textual names with `a` and `b` (respectively).
+--      This means one shouldn't write a type involving both `a` and `o`,
+--      nor `b` and `p`, nor `o` and `v`, etc.
+
 #include "MachDeps.h"
 
 section "The word size story."
@@ -1360,9 +1395,6 @@ primop  NewArrayOp "newArray#" GenPrimOp
    out_of_line = True
    has_side_effects = True
 
-primop  SameMutableArrayOp "sameMutableArray#" GenPrimOp
-   MutableArray# s a -> MutableArray# s a -> Int#
-
 primop  ReadArrayOp "readArray#" GenPrimOp
    MutableArray# s a -> Int# -> State# s -> (# State# s, a #)
    {Read from specified index of mutable array. Result is not yet evaluated.}
@@ -1538,9 +1570,6 @@ primop  NewSmallArrayOp "newSmallArray#" GenPrimOp
    out_of_line = True
    has_side_effects = True
 
-primop  SameSmallMutableArrayOp "sameSmallMutableArray#" GenPrimOp
-   SmallMutableArray# s a -> SmallMutableArray# s a -> Int#
-
 primop  ShrinkSmallMutableArrayOp_Char "shrinkSmallMutableArray#" GenPrimOp
    SmallMutableArray# s a -> Int# -> State# s -> State# s
    {Shrink mutable array to new specified size, in
@@ -1741,9 +1770,6 @@ primop  MutableByteArrayContents_Char "mutableByteArrayContents#" GenPrimOp
    MutableByteArray# s -> Addr#
    {Intended for use with pinned arrays; otherwise very unsafe!}
 
-primop  SameMutableByteArrayOp "sameMutableByteArray#" GenPrimOp
-   MutableByteArray# s -> MutableByteArray# s -> Int#
-
 primop  ShrinkMutableByteArrayOp_Char "shrinkMutableByteArray#" GenPrimOp
    MutableByteArray# s -> Int# -> State# s -> State# s
    {Shrink mutable byte array to new specified size (in bytes), in
@@ -1972,9 +1998,6 @@ primop  NewArrayArrayOp "newArrayArray#" GenPrimOp
    out_of_line = True
    has_side_effects = True
 
-primop  SameMutableArrayArrayOp "sameMutableArrayArray#" GenPrimOp
-   MutableArrayArray# s -> MutableArrayArray# s -> Int#
-
 primop  UnsafeFreezeArrayArrayOp "unsafeFreezeArrayArray#" GenPrimOp
    MutableArrayArray# s -> State# s -> (# State# s, ArrayArray# #)
    {Make a mutable array of arrays immutable, without copying.}
@@ -2469,9 +2492,6 @@ primop  WriteMutVarOp "writeMutVar#"  GenPrimOp
    has_side_effects = True
    code_size = { primOpCodeSizeForeignCall } -- for the write barrier
 
-primop  SameMutVarOp "sameMutVar#" GenPrimOp
-   MutVar# s a -> MutVar# s a -> Int#
-
 -- Note [Why not an unboxed tuple in atomicModifyMutVar2#?]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 --
@@ -2548,6 +2568,7 @@ primop  RaiseOp "raise#" GenPrimOp
    a -> p
       -- NB: "p" is the same as "b" except it is representation-polymorphic
       -- (we shouldn't use "o" here as that would conflict with "a")
+      -- See Note [Levity and representation polymorphic primops]
    with
    -- In contrast to 'raiseIO#', which throws a *precise* exception,
    -- exceptions thrown by 'raise#' are considered *imprecise*.
@@ -2690,9 +2711,6 @@ primop  WriteTVarOp "writeTVar#" GenPrimOp
    out_of_line      = True
    has_side_effects = True
 
-primop  SameTVarOp "sameTVar#" GenPrimOp
-   TVar# s a -> TVar# s a -> Int#
-
 
 ------------------------------------------------------------------------
 section "Synchronized Mutable Variables"
@@ -2760,9 +2778,6 @@ primop  TryReadMVarOp "tryReadMVar#" GenPrimOp
    out_of_line      = True
    has_side_effects = True
 
-primop  SameMVarOp "sameMVar#" GenPrimOp
-   MVar# s a -> MVar# s a -> Int#
-
 primop  IsEmptyMVarOp "isEmptyMVar#" GenPrimOp
    MVar# s a -> State# s -> (# State# s, Int# #)
    {Return 1 if {\tt MVar\#} is empty; 0 otherwise.}
@@ -2805,10 +2820,6 @@ primop  WriteIOPortOp "writeIOPort#" GenPrimOp
    out_of_line      = True
    has_side_effects = True
 
-primop  SameIOPortOp "sameIOPort#" GenPrimOp
-   IOPort# s a -> IOPort# s a -> Int#
-
-
 ------------------------------------------------------------------------
 section "Delay/wait operations"
 ------------------------------------------------------------------------
@@ -2922,6 +2933,7 @@ section "Weak pointers"
 primtype Weak# b
 
 -- Note: "v" denotes a levity-polymorphic type variable
+-- See Note [Levity and representation polymorphic primops]
 
 primop  MkWeakOp "mkWeak#" GenPrimOp
    v -> b -> (State# RealWorld -> (# State# RealWorld, c #))
@@ -3009,9 +3021,6 @@ primop  MakeStableNameOp "makeStableName#" GenPrimOp
    has_side_effects = True
    out_of_line      = True
 
-primop  EqStableNameOp "eqStableName#" GenPrimOp
-   StableName# a -> StableName# b -> Int#
-
 primop  StableNameToIntOp "stableNameToInt#" GenPrimOp
    StableName# a -> Int#
 
@@ -3143,25 +3152,74 @@ section "Unsafe pointer equality"
 --  (#1 Bad Guy: Alastair Reid :)
 ------------------------------------------------------------------------
 
+-- `v` and `w` are levity-polymorphic type variables with independent levities.
+-- See Note [Levity and representation polymorphic primops]
 primop  ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp
-   a -> a -> Int#
+   v -> w -> Int#
    { Returns {\texttt 1\#} if the given pointers are equal and {\texttt 0\#} otherwise. }
    with
-   can_fail   = True -- See Note [reallyUnsafePtrEquality#]
-
+   can_fail   = True -- See Note [reallyUnsafePtrEquality# can_fail]
 
--- Note [reallyUnsafePtrEquality#]
+-- Note [Pointer comparison operations]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- The primop `reallyUnsafePtrEquality#` does a direct pointer
+-- equality between two (boxed) values.  Several things to note:
+-- 
+-- * It is levity-polymorphic. It works for TYPE (BoxedRep Lifted) and
+--   TYPE (BoxedRep Unlifted). But not TYPE IntRep, for example.
+--   This levity-polymorphism comes from the use of the type variables
+--   "v" and "w". See Note [Levity and representation polymorphic primops]
+-- 
+-- * It does not evaluate its arguments. The user of the primop is responsible
+--   for doing so.
+-- 
+-- * It is hetero-typed; you can compare pointers of different types.
+--   This is used in various packages such as containers & unordered-containers.
+-- 
+-- * It is obviously very dangerous, because
+--      let x = f y in reallyUnsafePtrEquality# x x
+--   will probably return True, whereas
+--      reallyUnsafePtrEquality# (f y) (f y)
+--   will probably return False. ("probably", because it's affected
+--   by CSE and inlining).
+-- 
+-- * reallyUnsafePtrEquality# can't fail, but it is marked as such
+--   to prevent it from floating out.
+--   See Note [reallyUnsafePtrEquality# can_fail]
+-- 
+-- The library GHC.Exts provides several less Wild-West functions
+-- for use in specific cases, namely:
+--
+--   reallyUnsafePtrEquality :: a -> a -> Int#  -- not levity-polymorphic, nor hetero-typed
+--   sameArray# :: Array# a -> Array# a -> Int#
+--   sameMutableArray# :: MutableArray# s a -> MutableArray# s a -> Int#
+--   sameSmallArray# :: SmallArray# a -> SmallArray# a -> Int#
+--   sameSmallMutableArray# :: SmallMutableArray# s a -> SmallMutableArray# s a -> Int#
+--   sameByteArray# :: ByteArray# -> ByteArray# -> Int#
+--   sameMutableByteArray# :: MutableByteArray# s -> MutableByteArray# s -> Int#
+--   sameArrayArray# :: ArrayArray# -> ArrayArray# -> Int#
+--   sameMutableArrayArray# :: MutableArrayArray# s -> MutableArrayArray# s -> Int#
+--   sameMutVar# :: MutVar# s a -> MutVar# s a -> Int#
+--   sameTVar# :: TVar# s a -> TVar# s a -> Int#
+--   sameMVar# :: MVar# s a -> MVar# s a -> Int#
+--   sameIOPort# :: IOPort# s a -> IOPort# s a -> Int#
+--   eqStableName# :: StableName# a -> StableName# b -> Int#
+--
+-- These operations are all specialisations of reallyUnsafePtrEquality#.
+
+-- Note [reallyUnsafePtrEquality# can_fail]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 --
--- reallyUnsafePtrEquality# can't actually fail, per se, but we mark it can_fail
--- anyway. Until 5a9a1738023a, GHC considered primops okay for speculation only
--- when their arguments were known to be forced. This was unnecessarily
--- conservative, but it prevented reallyUnsafePtrEquality# from floating out of
--- places where its arguments were known to be forced. Unfortunately, GHC could
--- sometimes lose track of whether those arguments were forced, leading to let/app
--- invariant failures (see #13027 and the discussion in #11444). Now that
--- ok_for_speculation skips over lifted arguments, we need to explicitly prevent
--- reallyUnsafePtrEquality# from floating out. Imagine if we had
+-- reallyUnsafePtrEquality# can't actually fail, per se, but we mark it
+-- can_fail anyway. Until 5a9a1738023a, GHC considered primops okay for
+-- speculation only when their arguments were known to be forced. This was
+-- unnecessarily conservative, but it prevented reallyUnsafePtrEquality# from
+-- floating out of places where its arguments were known to be forced.
+-- Unfortunately, GHC could sometimes lose track of whether those arguments
+-- were forced, leading to let/app invariant failures (see #13027 and the
+-- discussion in #11444). Now that ok_for_speculation skips over lifted
+-- arguments, we need to explicitly prevent reallyUnsafePtrEquality#
+-- from floating out. Imagine if we had
 --
 --     \x y . case x of x'
 --              DEFAULT ->
@@ -3222,7 +3280,8 @@ section "Controlling object lifetime"
 
 -- See Note [keepAlive# magic] in GHC.CoreToStg.Prep.
 -- NB: "v" is the same as "a" except levity-polymorphic,
--- and "p" is the same as "b" except representation-polymorphic
+-- and "p" is the same as "b" except representation-polymorphic.
+-- See Note [Levity and representation polymorphic primops]
 primop KeepAliveOp "keepAlive#" GenPrimOp
    v -> State# RealWorld -> (State# RealWorld -> p) -> p
    { \tt{keepAlive# x s k} keeps the value \tt{x} alive during the execution
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index 542372105e..d61880a0e2 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -342,6 +342,8 @@ emitPrimOp dflags primop = case primop of
   StableNameToIntOp -> \[arg] -> opIntoRegs $ \[res] ->
     emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform))
 
+  EqStablePtrOp -> \args -> opTranslate args (mo_wordEq platform)
+
   ReallyUnsafePtrEqualityOp -> \[arg1, arg2] -> opIntoRegs $ \[res] ->
     emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq platform) [arg1,arg2])
 
@@ -1462,20 +1464,6 @@ emitPrimOp dflags primop = case primop of
   FloatToDoubleOp -> \args -> opTranslate args (MO_FF_Conv W32 W64)
   DoubleToFloatOp -> \args -> opTranslate args (MO_FF_Conv W64 W32)
 
--- Word comparisons masquerading as more exotic things.
-
-  SameMutVarOp            -> \args -> opTranslate args (mo_wordEq platform)
-  SameMVarOp              -> \args -> opTranslate args (mo_wordEq platform)
-  SameIOPortOp            -> \args -> opTranslate args (mo_wordEq platform)
-  SameMutableArrayOp      -> \args -> opTranslate args (mo_wordEq platform)
-  SameMutableByteArrayOp  -> \args -> opTranslate args (mo_wordEq platform)
-  SameMutableArrayArrayOp -> \args -> opTranslate args (mo_wordEq platform)
-  SameSmallMutableArrayOp -> \args -> opTranslate args (mo_wordEq platform)
-  SameTVarOp              -> \args -> opTranslate args (mo_wordEq platform)
-  EqStablePtrOp           -> \args -> opTranslate args (mo_wordEq platform)
--- See Note [Comparing stable names]
-  EqStableNameOp          -> \args -> opTranslate args (mo_wordEq platform)
-
   IntQuotRemOp -> \args -> opCallishHandledLater args $
     if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)
     then Left (MO_S_QuotRem  (wordWidth platform))
@@ -2092,17 +2080,6 @@ genericFabsOp w [res_r] [aa]
 
 genericFabsOp _ _ _ = panic "genericFabsOp"
 
--- Note [Comparing stable names]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- A StableName# is actually a pointer to a stable name object (SNO)
--- containing an index into the stable name table (SNT). We
--- used to compare StableName#s by following the pointers to the
--- SNOs and checking whether they held the same SNT indices. However,
--- this is not necessary: there is a one-to-one correspondence
--- between SNOs and entries in the SNT, so simple pointer equality
--- does the trick.
-
 ------------------------------------------------------------------------------
 -- Helpers for translating various minor variants of array indexing.
 
diff --git a/docs/users_guide/9.4.1-notes.rst b/docs/users_guide/9.4.1-notes.rst
index 68417b0a6b..655e672a1b 100644
--- a/docs/users_guide/9.4.1-notes.rst
+++ b/docs/users_guide/9.4.1-notes.rst
@@ -41,6 +41,32 @@ Version 9.4.1
 
         raise# :: forall (a :: Type) {r :: RuntimeRep} (b :: TYPE r). a -> b
 
+- ``GHC.Exts.reallyUnsafePtrEquality#`` has been made more general, as it is now
+   both levity-polymorphic and heterogeneous: ::
+
+        reallyUnsafePtrEquality#
+          :: forall {l :: Levity} (a :: TYPE (BoxedRep l))
+                    {k :: Levity} (b :: TYPE (BoxedRep k))
+          . a -> b -> Int#
+
+   This means that ``GHC.Exts.reallyUnsafePtrEquality#`` can be used
+   on primitive arrays such as ``GHC.Exts.Array#`` and ``GHC.Exts.ByteArray#``.
+   It can also be used on values of different types, without needing to call
+   ``GHC.Exts.unsafeCoerce#``.
+
+- Added ``GHC.Exts.reallyUnsafePtrEquality`` which recovers the
+  previous behaviour of ``GHC.Exts.reallyUnsafePtrEquality#``: ::
+
+        reallyUnsafePtrEquality :: forall (a :: Type). a -> a -> Int#
+
+- Added ``GHC.Exts.sameArray#``, ``GHC.Exts.sameSmallArray#``,
+  ``GHC.Exts.sameByteArray#`` and ``GHC.Exts.sameArrayArray#``: ::
+ 
+        sameArray# :: Array# a -> Array# a -> Int#
+        sameSmallArray# :: SmallArray# a -> SmallArray# a -> Int#
+        sameByteArray# :: ByteArray# -> ByteArray# -> Int#
+        sameArrayArray# :: ArrayArray# -> ArrayArray# -> Int#
+
 ``ghc`` library
 ~~~~~~~~~~~~~~~
 
diff --git a/libraries/base/GHC/Base.hs b/libraries/base/GHC/Base.hs
index b037951fa8..5a9d38f147 100644
--- a/libraries/base/GHC/Base.hs
+++ b/libraries/base/GHC/Base.hs
@@ -102,9 +102,10 @@ module GHC.Base
         module GHC.Magic,
         module GHC.Magic.Dict,
         module GHC.Types,
-        module GHC.Prim,        -- Re-export GHC.Prim and [boot] GHC.Err,
-        module GHC.Prim.Ext,    -- to avoid lots of people having to
-        module GHC.Err,         -- import it explicitly
+        module GHC.Prim,        -- Re-export GHC.Prim, GHC.Prim.Ext,
+        module GHC.Prim.Ext,    -- GHC.Prim.PtrEq and [boot] GHC.Err
+        module GHC.Prim.PtrEq,  -- to avoid lots of people having to
+        module GHC.Err,         -- import these modules explicitly
         module GHC.Maybe
   )
         where
@@ -116,6 +117,7 @@ import GHC.Magic
 import GHC.Magic.Dict
 import GHC.Prim
 import GHC.Prim.Ext
+import GHC.Prim.PtrEq
 import GHC.Err
 import GHC.Maybe
 import {-# SOURCE #-} GHC.IO (mkUserError, mplusIO)
diff --git a/libraries/base/GHC/Exts.hs b/libraries/base/GHC/Exts.hs
index 86890b6a8b..29f6bdaca0 100755
--- a/libraries/base/GHC/Exts.hs
+++ b/libraries/base/GHC/Exts.hs
@@ -38,7 +38,24 @@ module GHC.Exts
         module GHC.Prim.Ext,
         shiftL#, shiftRL#, iShiftL#, iShiftRA#, iShiftRL#,
         isTrue#,
-        Void#,  -- Previously exported by GHC.Prim
+        Void#, -- Previously exported by GHC.Prim
+
+        -- * Pointer comparison operations
+        -- See `Note [Pointer comparison operations]` in primops.txt.pp
+        reallyUnsafePtrEquality,
+        eqStableName#,
+        sameArray#,
+        sameMutableArray#,
+        sameSmallArray#,
+        sameSmallMutableArray#,
+        sameByteArray#,
+        sameMutableByteArray#,
+        sameArrayArray#,
+        sameMutableArrayArray#,
+        sameMVar#,
+        sameMutVar#,
+        sameTVar#,
+        sameIOPort#,
 
         -- * Compat wrapper
         atomicModifyMutVar#,
@@ -345,3 +362,4 @@ resizeSmallMutableArray# arr0 szNew a s0 =
 -- accessible\" by word.
 considerAccessible :: Bool
 considerAccessible = True
+
diff --git a/libraries/containers b/libraries/containers
-Subproject 7fb91ca53b1aca7c077b36a0c1f8f785d177da3
+Subproject f90e38cb170dcd68de8660dfd9d0e879921acc2
diff --git a/libraries/ghc-prim/GHC/Prim/PtrEq.hs b/libraries/ghc-prim/GHC/Prim/PtrEq.hs
new file mode 100644
index 0000000000..5e9d2e564b
--- /dev/null
+++ b/libraries/ghc-prim/GHC/Prim/PtrEq.hs
@@ -0,0 +1,140 @@
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MagicHash #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  GHC.Prim.PtrEq
+-- License     :  see libraries/ghc-prim/LICENSE
+--
+-- Maintainer  :  cvs-ghc@haskell.org
+-- Stability   :  internal
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Comparing underlying pointers for equality.
+--
+-- Use GHC.Exts from the base package instead of importing this
+-- module directly.
+--
+-----------------------------------------------------------------------------
+
+module GHC.Prim.PtrEq
+  ( reallyUnsafePtrEquality,
+    sameArray#,
+    sameMutableArray#,
+    sameSmallArray#,
+    sameSmallMutableArray#,
+    sameByteArray#,
+    sameMutableByteArray#,
+    sameArrayArray#,
+    sameMutableArrayArray#,
+    sameMutVar#,
+    sameTVar#,
+    sameMVar#,
+    sameIOPort#,
+    eqStableName#
+  ) where
+
+import GHC.Prim
+import GHC.Types () -- Make implicit dependency known to build system
+default () -- Double and Integer aren't available yet
+
+{- **********************************************************************
+*                                                                       *
+*                        Pointer equality                               *
+*                                                                       *
+********************************************************************** -}
+
+{- Note [Pointer equality operations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Many primitive types - such as Array#, ByteArray#, MVar#, ... - are boxed:
+they are represented by pointers to the underlying data. It is thus possible
+to directly compare these pointers for equality, as opposed to comparing
+the underlying data that the pointers refer to (for instance, comparing
+two arrays element-wise).
+
+To do this, GHC provides the primop reallyUnsafePtrEquality#, which is
+both levity-polymorphic and heterogeneous. As its name indicates, it is an
+unsafe operation which can yield unpredictable results, as explained in
+  Note [Pointer comparison operations] in primops.txt.pp
+
+For a more user-friendly interface, this module defines specialisations of
+the reallyUnsafePtrEquality# primop at various primitive types, such as
+Array#, ByteArray#, MVar#, ...
+-}
+
+-- | Compare the underlying pointers of two values for equality.
+--
+-- Returns @1@ if the pointers are equal and @0@ otherwise.
+--
+-- The two values must be of the same type, of kind 'Type'.
+-- See also 'GHC.Exts.reallyUnsafePtrEquality#', which doesn't have
+-- such restrictions.
+reallyUnsafePtrEquality :: a -> a -> Int#
+reallyUnsafePtrEquality = reallyUnsafePtrEquality#
+-- See Note [Pointer comparison operations]
+--   in primops.txt.pp
+
+-- | Compare the underlying pointers of two arrays.
+sameArray# :: Array# a -> Array# a -> Int#
+sameArray# = reallyUnsafePtrEquality#
+
+-- | Compare the underlying pointers of two mutable arrays.
+sameMutableArray# :: MutableArray# s a -> MutableArray# s a -> Int#
+sameMutableArray# = reallyUnsafePtrEquality#
+
+-- | Compare the underlying pointers of two small arrays.
+sameSmallArray# :: SmallArray# a -> SmallArray# a -> Int#
+sameSmallArray# = reallyUnsafePtrEquality#
+
+-- | Compare the underlying pointers of two small mutable arrays.
+sameSmallMutableArray# :: SmallMutableArray# s a -> SmallMutableArray# s a -> Int#
+sameSmallMutableArray# = reallyUnsafePtrEquality#
+
+-- | Compare the pointers of two byte arrays.
+sameByteArray# :: ByteArray# -> ByteArray# -> Int#
+sameByteArray# = reallyUnsafePtrEquality#
+
+-- | Compare the underlying pointers of two mutable byte arrays.
+sameMutableByteArray# :: MutableByteArray# s -> MutableByteArray# s -> Int#
+sameMutableByteArray# = reallyUnsafePtrEquality#
+
+-- | Compare the underlying pointers of two arrays of arrays.
+sameArrayArray# :: ArrayArray# -> ArrayArray# -> Int#
+sameArrayArray# = reallyUnsafePtrEquality#
+
+-- | Compare the underlying pointers of two mutable arrays of arrays.
+sameMutableArrayArray# :: MutableArrayArray# s -> MutableArrayArray# s -> Int#
+sameMutableArrayArray# = reallyUnsafePtrEquality#
+
+-- | Compare the underlying pointers of two 'MutVar#'s.
+sameMutVar# :: MutVar# s a -> MutVar# s a -> Int#
+sameMutVar# = reallyUnsafePtrEquality#
+
+-- | Compare the underlying pointers of two 'TVar#'s.
+sameTVar# :: TVar# s a -> TVar# s a -> Int#
+sameTVar# = reallyUnsafePtrEquality#
+
+-- | Compare the underlying pointers of two 'MVar#'s.
+sameMVar# :: MVar# s a -> MVar# s a -> Int#
+sameMVar# = reallyUnsafePtrEquality#
+
+-- | Compare the underlying pointers of two 'IOPort#'s.
+sameIOPort# :: IOPort# s a -> IOPort# s a -> Int#
+sameIOPort# = reallyUnsafePtrEquality#
+
+-- Note [Comparing stable names]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- A StableName# is actually a pointer to a stable name object (SNO)
+-- containing an index into the stable name table (SNT). We
+-- used to compare StableName#s by following the pointers to the
+-- SNOs and checking whether they held the same SNT indices. However,
+-- this is not necessary: there is a one-to-one correspondence
+-- between SNOs and entries in the SNT, so simple pointer equality
+-- does the trick.
+
+-- | Compare two stable names for equality.
+eqStableName# :: StableName# a -> StableName# b -> Int#
+eqStableName# = reallyUnsafePtrEquality#
diff --git a/libraries/ghc-prim/changelog.md b/libraries/ghc-prim/changelog.md
index 122856346f..5d27ec197a 100644
--- a/libraries/ghc-prim/changelog.md
+++ b/libraries/ghc-prim/changelog.md
@@ -39,6 +39,35 @@
   raise# :: forall (a :: Type) {r :: RuntimeRep} (b :: TYPE r). a -> b
   ```
 
+- `reallyUnsafePtrEquality#` has been made more general, as it is now
+   both levity-polymorphic and heterogeneous:
+
+  ```
+  reallyUnsafePtrEquality#
+    :: forall {l :: Levity} (a :: TYPE (BoxedRep l))
+              {k :: Levity} (b :: TYPE (BoxedRep k))
+    . a -> b -> Int#
+  ```
+
+   This means that `reallyUnsafePtrEquality#` can be used on primitive arrays
+   such as `Array#` and `ByteArray#`. It can also be used on values of
+   different types, without needing to call `unsafeCoerce#`.
+
+- The following functions have been moved from `GHC.Prim` to `GHC.Exts`:
+  - `sameMutableArray#`, `sameSmallMutableArray#`, `sameMutableByteArray#`
+     and `sameMutableArrayArray#`,
+  - `sameMutVar#`, `sameTVar#` and`sameMVar#`,
+  - `sameIOPort#`,
+  - `eqStableName#`.
+
+- The following functions have been added to `GHC.Exts`:
+ 
+  ```
+  sameArray# :: Array# a -> Array# a -> Int#
+  sameSmallArray# :: SmallArray# a -> SmallArray# a -> Int#
+  sameByteArray# :: ByteArray# -> ByteArray# -> Int#
+  sameArrayArray# :: ArrayArray# -> ArrayArray# -> Int#
+  ```
 
 ## 0.8.0 (edit as necessary)
 
diff --git a/libraries/ghc-prim/ghc-prim.cabal b/libraries/ghc-prim/ghc-prim.cabal
index 812324e117..e207b3f24c 100644
--- a/libraries/ghc-prim/ghc-prim.cabal
+++ b/libraries/ghc-prim/ghc-prim.cabal
@@ -48,6 +48,7 @@ Library
         GHC.Prim.Ext
         GHC.Prim.Panic
         GHC.Prim.Exception
+        GHC.Prim.PtrEq
         GHC.PrimopWrappers
         GHC.Tuple
         GHC.Types
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, [''])
diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs
index f5eaf757e2..06a4922aa3 100644
--- a/utils/genprimopcode/Main.hs
+++ b/utils/genprimopcode/Main.hs
@@ -854,8 +854,11 @@ ppTyVar "c" = "gammaTyVarSpec"
 ppTyVar "s" = "deltaTyVarSpec"
 ppTyVar "o" = "runtimeRep1TyVarInf, openAlphaTyVarSpec"
 ppTyVar "p" = "runtimeRep2TyVarInf, openBetaTyVarSpec"
-ppTyVar "v" = "levity1TyVarInf, levPolyTyVar1Spec"
+ppTyVar "v" = "levity1TyVarInf, levPolyAlphaTyVarSpec"
+ppTyVar "w" = "levity2TyVarInf, levPolyBetaTyVarSpec"
 ppTyVar _   = error "Unknown type var"
+-- o, p, v and w have a special meaning. See primops.txt.pp
+-- Note [Levity and representation polymorphic primops]
 
 ppType :: Ty -> String
 ppType (TyApp (TyCon "Any")         []) = "anyTy"
@@ -889,7 +892,10 @@ ppType (TyVar "c")                      = "gammaTy"
 ppType (TyVar "s")                      = "deltaTy"
 ppType (TyVar "o")                      = "openAlphaTy"
 ppType (TyVar "p")                      = "openBetaTy"
-ppType (TyVar "v")                      = "levPolyTy1"
+ppType (TyVar "v")                      = "levPolyAlphaTy"
+ppType (TyVar "w")                      = "levPolyBetaTy"
+-- o, p, v and w have a special meaning. See primops.txt.pp
+-- Note [Levity and representation polymorphic primops]
 
 ppType (TyApp (TyCon "State#") [x])             = "mkStatePrimTy " ++ ppType x
 ppType (TyApp (TyCon "MutVar#") [x,y])          = "mkMutVarPrimTy " ++ ppType x