From 310371ff2d5b73cdcb2439b67170ca5e613541c0 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Tue, 17 May 2016 19:05:26 +0200 Subject: rts: Add isPinnedByteArray# primop Adds a primitive operation to determine whether a particular `MutableByteArray#` is backed by a pinned buffer. Test Plan: Validate with included testcase Reviewers: austin, simonmar Reviewed By: austin, simonmar Subscribers: thomie Differential Revision: https://phabricator.haskell.org/D2217 GHC Trac Issues: #12059 --- compiler/prelude/primops.txt.pp | 5 +++++ docs/users_guide/8.2.1-notes.rst | 2 ++ includes/stg/MiscClosures.h | 1 + libraries/ghc-prim/changelog.md | 10 +++++++++ rts/PrimOps.cmm | 11 ++++++++++ rts/RtsSymbols.c | 1 + testsuite/tests/codeGen/should_run/T12059.hs | 27 ++++++++++++++++++++++++ testsuite/tests/codeGen/should_run/T12059.stdout | 3 +++ testsuite/tests/codeGen/should_run/all.T | 1 + utils/deriveConstants/Main.hs | 1 + 10 files changed, 62 insertions(+) create mode 100644 testsuite/tests/codeGen/should_run/T12059.hs create mode 100644 testsuite/tests/codeGen/should_run/T12059.stdout diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index d481d1ab72..53bc8a47d7 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -1077,6 +1077,11 @@ primop NewAlignedPinnedByteArrayOp_Char "newAlignedPinnedByteArray#" GenPrimOp with out_of_line = True has_side_effects = True +primop ByteArrayIsPinnedOp "isPinnedByteArray#" GenPrimOp + MutableByteArray# s -> Int# + {Determine whether a {\tt MutableByteArray\#} is guaranteed not to move.} + with out_of_line = True + primop ByteArrayContents_Char "byteArrayContents#" GenPrimOp ByteArray# -> Addr# {Intended for use with pinned arrays; otherwise very unsafe!} diff --git a/docs/users_guide/8.2.1-notes.rst b/docs/users_guide/8.2.1-notes.rst index 957552b302..b52f0ede25 100644 --- a/docs/users_guide/8.2.1-notes.rst +++ b/docs/users_guide/8.2.1-notes.rst @@ -127,6 +127,8 @@ ghc-prim - Version number XXXXX (was 0.3.1.0) +- Added new ``isPinnedbyteArray#`` operation. + haskell98 ~~~~~~~~~ diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h index 3fd412820b..337f586f76 100644 --- a/includes/stg/MiscClosures.h +++ b/includes/stg/MiscClosures.h @@ -347,6 +347,7 @@ RTS_FUN_DECL(stg_casArrayzh); RTS_FUN_DECL(stg_newByteArrayzh); RTS_FUN_DECL(stg_newPinnedByteArrayzh); RTS_FUN_DECL(stg_newAlignedPinnedByteArrayzh); +RTS_FUN_DECL(stg_isPinnedByteArrayzh); RTS_FUN_DECL(stg_shrinkMutableByteArrayzh); RTS_FUN_DECL(stg_resizzeMutableByteArrayzh); RTS_FUN_DECL(stg_casIntArrayzh); diff --git a/libraries/ghc-prim/changelog.md b/libraries/ghc-prim/changelog.md index 45daa64b26..0c9ca42fd8 100644 --- a/libraries/ghc-prim/changelog.md +++ b/libraries/ghc-prim/changelog.md @@ -1,5 +1,15 @@ +## 0.6.0.0 + +- Shipped with GHC 8.2.1 + +- Added to `GHC.Prim`: + + isPinnedByteArray# :: MutableByteArray# s -> Int# + ## 0.5.0.0 +- Shipped with GHC 8.0.1 + - `GHC.Classes`: new `class IP (a :: Symbol) b | a -> b` - `GHC.Prim`: changed type signatures from diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index a802e6780e..a8e2a1b66c 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -141,6 +141,17 @@ stg_newAlignedPinnedByteArrayzh ( W_ n, W_ alignment ) return (p); } +stg_isPinnedByteArrayzh ( gcptr mba ) +// MutableByteArray# s -> Int# +{ + W_ bd, flags; + bd = Bdescr(mba); + // pinned byte arrays live in blocks with the BF_PINNED flag set. + // See the comment in Storage.c:allocatePinned. + flags = TO_W_(bdescr_flags(bd)); + return (flags & BF_PINNED != 0); +} + // shrink size of MutableByteArray in-place stg_shrinkMutableByteArrayzh ( gcptr mba, W_ new_size ) // MutableByteArray# s -> Int# -> State# s -> State# s diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c index 11bc0e6880..f420c01ee1 100644 --- a/rts/RtsSymbols.c +++ b/rts/RtsSymbols.c @@ -514,6 +514,7 @@ SymI_HasProto(stg_casMutVarzh) \ SymI_HasProto(stg_newPinnedByteArrayzh) \ SymI_HasProto(stg_newAlignedPinnedByteArrayzh) \ + SymI_HasProto(stg_isPinnedByteArrayzh) \ SymI_HasProto(stg_shrinkMutableByteArrayzh) \ SymI_HasProto(stg_resizzeMutableByteArrayzh) \ SymI_HasProto(newSpark) \ diff --git a/testsuite/tests/codeGen/should_run/T12059.hs b/testsuite/tests/codeGen/should_run/T12059.hs new file mode 100644 index 0000000000..0b99bd36a4 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/T12059.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +-- Test the function of the isPinnedByteArray# primop + +import GHC.Exts +import GHC.IO + +main :: IO () +main = do + r <- IO $ \s0 -> + case newByteArray# 1024# s0 of + (# s1, mba #) -> + (# s1, isTrue# (isPinnedByteArray# mba) #) + print r + + r <- IO $ \s0 -> + case newPinnedByteArray# 1024# s0 of + (# s1, mba #) -> + (# s1, isTrue# (isPinnedByteArray# mba) #) + print r + + r <- IO $ \s0 -> + case newAlignedPinnedByteArray# 1024# 16# s0 of + (# s1, mba #) -> + (# s1, isTrue# (isPinnedByteArray# mba) #) + print r diff --git a/testsuite/tests/codeGen/should_run/T12059.stdout b/testsuite/tests/codeGen/should_run/T12059.stdout new file mode 100644 index 0000000000..70cea9e2ea --- /dev/null +++ b/testsuite/tests/codeGen/should_run/T12059.stdout @@ -0,0 +1,3 @@ +False +True +True diff --git a/testsuite/tests/codeGen/should_run/all.T b/testsuite/tests/codeGen/should_run/all.T index 1175f222e3..921f2c3aaa 100644 --- a/testsuite/tests/codeGen/should_run/all.T +++ b/testsuite/tests/codeGen/should_run/all.T @@ -140,3 +140,4 @@ test('T10521b', normal, compile_and_run, ['']) test('T10870', when(wordsize(32), skip), compile_and_run, ['']) test('PopCnt', omit_ways(['ghci']), multi_compile_and_run, ['PopCnt', [('PopCnt_cmm.cmm', '')], '']) +test('T12059', normal, compile_and_run, ['']) diff --git a/utils/deriveConstants/Main.hs b/utils/deriveConstants/Main.hs index 16f3255eb8..63e2233f8b 100644 --- a/utils/deriveConstants/Main.hs +++ b/utils/deriveConstants/Main.hs @@ -391,6 +391,7 @@ wanteds os = concat ,structField Both "bdescr" "blocks" ,structField C "bdescr" "gen_no" ,structField C "bdescr" "link" + ,structField C "bdescr" "flags" ,structSize C "generation" ,structField C "generation" "n_new_large_words" -- cgit v1.2.1