diff options
author | sheaf <sam.derbyshire@gmail.com> | 2021-06-23 21:47:17 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-06-25 05:19:18 -0400 |
commit | d1f59540e8b7be96b55ab4b286539a70bc75416c (patch) | |
tree | f4727baa0a369a30056e3a67c82c25b6ea0f7484 | |
parent | fa6451b70faf0aaeb849dfeccb2c24e5d4c16fa6 (diff) | |
download | haskell-d1f59540e8b7be96b55ab4b286539a70bc75416c.tar.gz |
Make reallyUnsafePtrEquality# levity-polymorphic
fixes #17126, updates containers submodule
-rw-r--r-- | compiler/GHC/Builtin/primops.txt.pp | 2 | ||||
-rw-r--r-- | docs/users_guide/9.4.1-notes.rst | 7 | ||||
m--------- | libraries/containers | 0 | ||||
-rw-r--r-- | libraries/ghc-prim/changelog.md | 9 | ||||
-rw-r--r-- | testsuite/tests/primops/should_run/LevPolyPtrEquality1.hs | 25 | ||||
-rw-r--r-- | testsuite/tests/primops/should_run/LevPolyPtrEquality1.stdout | 2 | ||||
-rw-r--r-- | testsuite/tests/primops/should_run/LevPolyPtrEquality2.hs | 26 | ||||
-rw-r--r-- | testsuite/tests/primops/should_run/LevPolyPtrEquality2.stdout | 3 | ||||
-rw-r--r-- | testsuite/tests/primops/should_run/all.T | 3 |
9 files changed, 76 insertions, 1 deletions
diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp index 672b831ac7..145aed43a8 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 68417b0a6b..04b44dd0e6 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 -Subproject 7fb91ca53b1aca7c077b36a0c1f8f785d177da3 +Subproject f90e38cb170dcd68de8660dfd9d0e879921acc2 diff --git a/libraries/ghc-prim/changelog.md b/libraries/ghc-prim/changelog.md index 122856346f..ec8df7904b 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 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..39be43ed29 --- /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 0000000000..dfc7ac9454 --- /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 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, ['']) |