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.

3 files changed, 134 insertions, 84 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.