[commit: ghc] master: rts: Add isPinnedByteArray# primop (310371f)
git at git.haskell.org
git at git.haskell.org
Wed May 18 20:00:17 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/310371ff2d5b73cdcb2439b67170ca5e613541c0/ghc
>---------------------------------------------------------------
commit 310371ff2d5b73cdcb2439b67170ca5e613541c0
Author: Ben Gamari <bgamari.foss at gmail.com>
Date: Tue May 17 19:05:26 2016 +0200
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
>---------------------------------------------------------------
310371ff2d5b73cdcb2439b67170ca5e613541c0
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 ++++++++++++++++++++++
.../should_run/T12059.stdout} | 2 +-
testsuite/tests/codeGen/should_run/all.T | 1 +
utils/deriveConstants/Main.hs | 1 +
10 files changed, 60 insertions(+), 1 deletion(-)
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index d481d1a..53bc8a4 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 957552b..b52f0ed 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 3fd4128..337f586 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 45daa64..0c9ca42 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 a802e67..a8e2a1b 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 11bc0e6..f420c01 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 0000000..0b99bd3
--- /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/overloadedrecflds/should_run/overloadedlabelsrun01.stdout b/testsuite/tests/codeGen/should_run/T12059.stdout
similarity index 100%
copy from testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun01.stdout
copy to testsuite/tests/codeGen/should_run/T12059.stdout
index 4644fbc..70cea9e 100644
--- a/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun01.stdout
+++ b/testsuite/tests/codeGen/should_run/T12059.stdout
@@ -1,3 +1,3 @@
-True
False
True
+True
diff --git a/testsuite/tests/codeGen/should_run/all.T b/testsuite/tests/codeGen/should_run/all.T
index 1175f22..921f2c3 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 16f3255..63e2233 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"
More information about the ghc-commits
mailing list