Add unsafePtrEquality# restricted to UnliftedTypes

4 files changed, 70 insertions, 34 deletions

diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp
index 1fc7bd5f23..617abe5f9e 100644
--- a/compiler/GHC/Builtin/primops.txt.pp
+++ b/compiler/GHC/Builtin/primops.txt.pp
@@ -3429,29 +3429,47 @@ primop  ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp
 -- 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]
+-- (PE1) 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.
+-- (PE2) It is hetero-typed; you can compare pointers of different types.
+--       This is used in various packages such as containers & unordered-containers.
 --
--- * It is hetero-typed; you can compare pointers of different types.
---   This is used in various packages such as containers & unordered-containers.
+-- (PE3) It does not evaluate its arguments. The user of the primop is responsible
+--       for doing so.  Consider
+--            let { x = p+q; y = q+p } in reallyUnsafePtrEquality# x y
+--       Here `x` and `y` point to different closures, so the expression will
+--       probably return False; but if `x` and/or `y` were evaluated for some
+--       other reason, then it might return True.
 --
--- * 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).
+-- (PE4) It is obviously very dangerous, because replacing equals with equals
+--       in the program can change the result.  For example
+--           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]
+-- (PE5) 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
+-- The library GHC.Prim.PtrEq (and GHC.Exts) provides
+--
+--   unsafePtrEquality# ::
+--     forall (a :: UnliftedType) (b :: UnliftedType). a -> b -> Int#
+--
+-- It is still heterotyped (like (PE2)), but it's restricted to unlifted types
+-- (unlike (PE1)).  That means that (PE3) doesn't apply: unlifted types are
+-- always evaluated, which makes it a bit less unsafe.
+--
+-- However unsafePtrEquality# is /implemented/ by a call to
+-- reallyUnsafePtrEquality#, so using the former is really just a documentation
+-- hint to the reader of the code.  GHC behaves no differently.
+--
+-- The same library provides less Wild-West functions
 -- for use in specific cases, namely:
 --
 --   reallyUnsafePtrEquality :: a -> a -> Int#  -- not levity-polymorphic, nor hetero-typed
@@ -3469,7 +3487,7 @@ primop  ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp
 --   sameIOPort# :: IOPort# s a -> IOPort# s a -> Int#
 --   eqStableName# :: StableName# a -> StableName# b -> Int#
 --
--- These operations are all specialisations of reallyUnsafePtrEquality#.
+-- These operations are all specialisations of unsafePtrEquality#.
 
 -- Note [reallyUnsafePtrEquality# can_fail]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/libraries/base/GHC/ArrayArray.hs b/libraries/base/GHC/ArrayArray.hs
index 199bac3a15..bd154c1943 100644
--- a/libraries/base/GHC/ArrayArray.hs
+++ b/libraries/base/GHC/ArrayArray.hs
@@ -49,6 +49,7 @@ module GHC.ArrayArray
   where
 
 import GHC.Prim
+import GHC.Prim.PtrEq ( unsafePtrEquality# )
 import GHC.Types ( Type, UnliftedType, isTrue# )
 import Unsafe.Coerce ( unsafeCoerce, unsafeCoerceUnlifted )
 default ()
@@ -148,8 +149,8 @@ copyMutableArrayArray# = unsafeCoerce copyMutableArray#
 
 -- | Compare the underlying pointers of two arrays of arrays.
 sameArrayArray# :: ArrayArray# -> ArrayArray# -> Int#
-sameArrayArray# (ArrayArray# arr1) (ArrayArray# arr2) = reallyUnsafePtrEquality# arr1 arr2
+sameArrayArray# (ArrayArray# arr1) (ArrayArray# arr2) = unsafePtrEquality# arr1 arr2
 
 -- | Compare the underlying pointers of two mutable arrays of arrays.
 sameMutableArrayArray# :: MutableArrayArray# s -> MutableArrayArray# s -> Int#
-sameMutableArrayArray# (MutableArrayArray# marr1) (MutableArrayArray# marr2 ) = reallyUnsafePtrEquality# marr1 marr2
+sameMutableArrayArray# (MutableArrayArray# marr1) (MutableArrayArray# marr2 ) = unsafePtrEquality# marr1 marr2
diff --git a/libraries/base/GHC/Exts.hs b/libraries/base/GHC/Exts.hs
index 90a37be35b..9114a398e7 100755
--- a/libraries/base/GHC/Exts.hs
+++ b/libraries/base/GHC/Exts.hs
@@ -48,6 +48,7 @@ module GHC.Exts
         -- ** Pointer comparison operations
         -- See `Note [Pointer comparison operations]` in primops.txt.pp
         reallyUnsafePtrEquality,
+        unsafePtrEquality#,
         eqStableName#,
         sameArray#,
         sameMutableArray#,
diff --git a/libraries/ghc-prim/GHC/Prim/PtrEq.hs b/libraries/ghc-prim/GHC/Prim/PtrEq.hs
index 49e78b1713..9e8e0d04a0 100644
--- a/libraries/ghc-prim/GHC/Prim/PtrEq.hs
+++ b/libraries/ghc-prim/GHC/Prim/PtrEq.hs
@@ -1,6 +1,8 @@
 {-# LANGUAGE Unsafe #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE MagicHash #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE KindSignatures #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -20,6 +22,7 @@
 
 module GHC.Prim.PtrEq
   ( reallyUnsafePtrEquality,
+    unsafePtrEquality#,
     sameArray#,
     sameMutableArray#,
     sameSmallArray#,
@@ -35,7 +38,7 @@ module GHC.Prim.PtrEq
   ) where
 
 import GHC.Prim
-import GHC.Types () -- Make implicit dependency known to build system
+import GHC.Types (UnliftedType) -- Also make implicit dependency known to build system
 default () -- Double and Integer aren't available yet
 
 {- **********************************************************************
@@ -74,49 +77,62 @@ reallyUnsafePtrEquality = reallyUnsafePtrEquality#
 -- See Note [Pointer comparison operations]
 --   in primops.txt.pp
 
+-- | Compare the underlying pointers of two unlifted values for equality.
+--
+-- This is less dangerous than 'reallyUnsafePtrEquality',
+-- since the arguments are guaranteed to be evaluated.
+-- This means there is no risk of accidentally comparing
+-- a thunk.
+-- It's however still more dangerous than e.g. 'sameArray#'.
+--
+unsafePtrEquality# :: forall (a :: UnliftedType) (b :: UnliftedType). a -> b -> Int#
+unsafePtrEquality# = 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#
+sameArray# = unsafePtrEquality#
 
 -- | Compare the underlying pointers of two mutable arrays.
 sameMutableArray# :: MutableArray# s a -> MutableArray# s a -> Int#
-sameMutableArray# = reallyUnsafePtrEquality#
+sameMutableArray# = unsafePtrEquality#
 
 -- | Compare the underlying pointers of two small arrays.
 sameSmallArray# :: SmallArray# a -> SmallArray# a -> Int#
-sameSmallArray# = reallyUnsafePtrEquality#
+sameSmallArray# = unsafePtrEquality#
 
 -- | Compare the underlying pointers of two small mutable arrays.
 sameSmallMutableArray# :: SmallMutableArray# s a -> SmallMutableArray# s a -> Int#
-sameSmallMutableArray# = reallyUnsafePtrEquality#
+sameSmallMutableArray# = unsafePtrEquality#
 
 -- | Compare the pointers of two byte arrays.
 sameByteArray# :: ByteArray# -> ByteArray# -> Int#
-sameByteArray# = reallyUnsafePtrEquality#
+sameByteArray# = unsafePtrEquality#
 
 -- | Compare the underlying pointers of two mutable byte arrays.
 sameMutableByteArray# :: MutableByteArray# s -> MutableByteArray# s -> Int#
-sameMutableByteArray# = reallyUnsafePtrEquality#
+sameMutableByteArray# = unsafePtrEquality#
 
 -- | Compare the underlying pointers of two 'MutVar#'s.
 sameMutVar# :: MutVar# s a -> MutVar# s a -> Int#
-sameMutVar# = reallyUnsafePtrEquality#
+sameMutVar# = unsafePtrEquality#
 
 -- | Compare the underlying pointers of two 'TVar#'s.
 sameTVar# :: TVar# s a -> TVar# s a -> Int#
-sameTVar# = reallyUnsafePtrEquality#
+sameTVar# = unsafePtrEquality#
 
 -- | Compare the underlying pointers of two 'MVar#'s.
 sameMVar# :: MVar# s a -> MVar# s a -> Int#
-sameMVar# = reallyUnsafePtrEquality#
+sameMVar# = unsafePtrEquality#
 
 -- | Compare the underlying pointers of two 'IOPort#'s.
 sameIOPort# :: IOPort# s a -> IOPort# s a -> Int#
-sameIOPort# = reallyUnsafePtrEquality#
+sameIOPort# = unsafePtrEquality#
 
 -- | Compare the underlying pointers of two 'PromptTag#'s.
 samePromptTag# :: PromptTag# a -> PromptTag# a -> Int#
-samePromptTag# = reallyUnsafePtrEquality#
+samePromptTag# = unsafePtrEquality#
 
 -- Note [Comparing stable names]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -130,4 +146,4 @@ samePromptTag# = reallyUnsafePtrEquality#
 
 -- | Compare two stable names for equality.
 eqStableName# :: StableName# a -> StableName# b -> Int#
-eqStableName# = reallyUnsafePtrEquality#
+eqStableName# = unsafePtrEquality#