[commit: ghc] ghc-8.2: rts: Fix isByteArrayPinned#'s treatment of large arrays (32dd9b8)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-8.2
Link       : http://ghc.haskell.org/trac/ghc/changeset/32dd9b8b84dfc2a395551f38bc3f1c8b470a2eb9/ghc

>---------------------------------------------------------------

commit 32dd9b8b84dfc2a395551f38bc3f1c8b470a2eb9
Author: Ben Gamari <bgamari.foss at gmail.com>
Date:   Mon Jul 3 19:09:03 2017 -0400

    rts: Fix isByteArrayPinned#'s treatment of large arrays
    
    It should respond with True to both BF_PINNED and BF_LARGE byte arrays.
    However, previously it would only check the BF_PINNED flag.
    
    Test Plan: Validate
    
    Reviewers: simonmar, austin, erikd
    
    Subscribers: winterland1989, rwbarton, thomie
    
    GHC Trac Issues: #13894
    
    Differential Revision: https://phabricator.haskell.org/D3685
    
    (cherry picked from commit a6f3d1b00e9c37a56cd4db9e519309e94a65d181)


>---------------------------------------------------------------

32dd9b8b84dfc2a395551f38bc3f1c8b470a2eb9
 rts/PrimOps.cmm               |  5 +++--
 testsuite/tests/rts/T13894.hs | 18 ++++++++++++++++++
 testsuite/tests/rts/all.T     |  1 +
 3 files changed, 22 insertions(+), 2 deletions(-)

diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index 4baf63a..06b17c3 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -147,10 +147,11 @@ stg_isByteArrayPinnedzh ( gcptr ba )
 {
     W_ bd, flags;
     bd = Bdescr(ba);
-    // pinned byte arrays live in blocks with the BF_PINNED flag set.
+    // Pinned byte arrays live in blocks with the BF_PINNED flag set.
+    // We also consider BF_LARGE objects to be unmoveable. See #13894.
     // See the comment in Storage.c:allocatePinned.
     flags = TO_W_(bdescr_flags(bd));
-    return (flags & BF_PINNED != 0);
+    return (flags & (BF_PINNED | BF_LARGE) != 0);
 }
 
 stg_isMutableByteArrayPinnedzh ( gcptr mba )
diff --git a/testsuite/tests/rts/T13894.hs b/testsuite/tests/rts/T13894.hs
new file mode 100644
index 0000000..e09e908
--- /dev/null
+++ b/testsuite/tests/rts/T13894.hs
@@ -0,0 +1,18 @@
+-- Test that isByteArray# returns True for large but not explicitly pinned byte
+-- arrays
+
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples  #-}
+
+import Control.Monad
+import GHC.Exts
+import GHC.IO
+
+main :: IO ()
+main = do
+    pinned <- IO $ \s0 ->
+      case newByteArray# 1000000# s0 of
+        (# s1, arr# #) ->
+            case isMutableByteArrayPinned# arr# of
+              n# -> (# s1, isTrue# n# #)
+    unless pinned $ putStrLn "BAD"
diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T
index e02f880..e819404 100644
--- a/testsuite/tests/rts/all.T
+++ b/testsuite/tests/rts/all.T
@@ -377,3 +377,4 @@ test('T12497', [ unless(opsys('mingw32'), skip)
 
 test('T12903', [when(opsys('mingw32'), skip)], compile_and_run, [''])
 test('T13832', exit_code(1), compile_and_run, ['-threaded'])
+test('T13894', normal, compile_and_run, [''])