diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp index 672b831ac7ca7a42e2a0f5daecf0afd7ace834e0..145aed43a836bc2e5fe7da5a0418ef9ce8b4cc28 100644 --- a/compiler/GHC/Builtin/primops.txt.pp +++ b/compiler/GHC/Builtin/primops.txt.pp @@ -3058,7 +3058,7 @@ section "Unsafe pointer equality" ------------------------------------------------------------------------ primop ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp - a -> a -> Int# + v -> v -> Int# { Returns {\texttt 1\#} if the given pointers are equal and {\texttt 0\#} otherwise. } with can_fail = True -- See Note [reallyUnsafePtrEquality#] diff --git a/docs/users_guide/9.4.1-notes.rst b/docs/users_guide/9.4.1-notes.rst index 68417b0a6ba4751c43d30e59bfd014a3997e60f5..04b44dd0e651c472913e84474d3bcb2766fa62bf 100644 --- a/docs/users_guide/9.4.1-notes.rst +++ b/docs/users_guide/9.4.1-notes.rst @@ -41,6 +41,13 @@ Version 9.4.1 raise# :: forall (a :: Type) {r :: RuntimeRep} (b :: TYPE r). a -> b +- ``GHC.Exts.reallyUnsafePtrEquality#`` is now levity-polymorphic: :: + + reallyUnsafePtrEquality# :: forall {l :: Levity} (a :: TYPE (BoxedRep l)). a -> a -> Int# + + This means that ``GHC.Exts.reallyUnsafePtrEquality#`` now works on primitive arrays, + such as ``GHC.Exts.Array#`` and ``GHC.Exts.ByteArray#``. + ``ghc`` library ~~~~~~~~~~~~~~~ diff --git a/libraries/containers b/libraries/containers index 7fb91ca53b1aca7c077b36a0c1f8f785d177da34..f90e38cb170dcd68de8660dfd9d0e879921acc28 160000 --- a/libraries/containers +++ b/libraries/containers @@ -1 +1 @@ -Subproject commit 7fb91ca53b1aca7c077b36a0c1f8f785d177da34 +Subproject commit f90e38cb170dcd68de8660dfd9d0e879921acc28 diff --git a/libraries/ghc-prim/changelog.md b/libraries/ghc-prim/changelog.md index 122856346f1c7a80f153f5e80a7deb6b472219a2..ec8df7904b47b09463377d518cddb3845afa24a7 100644 --- a/libraries/ghc-prim/changelog.md +++ b/libraries/ghc-prim/changelog.md @@ -39,6 +39,15 @@ raise# :: forall (a :: Type) {r :: RuntimeRep} (b :: TYPE r). a -> b ``` +- `reallyUnsafePtrEquality#` is now levity-polymorphic: + + ``` + reallyUnsafePtrEquality# :: forall {l :: Levity} (a :: TYPE (BoxedRep l)). a -> a -> Int# + ``` + + This means that `reallyUnsafePtrEquality#` now works on primitive arrays, + such as `Array#` and `ByteArray#`. + ## 0.8.0 (edit as necessary) diff --git a/testsuite/tests/primops/should_run/LevPolyPtrEquality1.hs b/testsuite/tests/primops/should_run/LevPolyPtrEquality1.hs new file mode 100644 index 0000000000000000000000000000000000000000..bbd4819c7d752b4428a0e7f2b65cb8259da5f562 --- /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 0000000000000000000000000000000000000000..aaf2e46dcf25b82077db70ca46a70394f5e5da25 --- /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 0000000000000000000000000000000000000000..39be43ed299183dfb81ccf8ba3e409993acf6096 --- /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 0000000000000000000000000000000000000000..dfc7ac9454b1f681617f975ca861fae6259e5d64 --- /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 cad58c1909e315c7f0e2ad4a31a10c629a406992..ef046f34aefe9d56a3ec79db6f0f011bf00ea7b5 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, [''])