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

10 files changed, 62 insertions, 0 deletions

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"