[commit: ghc] master: Compacted arrays are pinned for isByteArrayPinned# (df2ea10)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/df2ea10655984234924ad9f2c237289ab8f4baa6/ghc

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

commit df2ea10655984234924ad9f2c237289ab8f4baa6
Author: Simon Marlow <marlowsd at gmail.com>
Date:   Thu Mar 8 08:54:01 2018 +0000

    Compacted arrays are pinned for isByteArrayPinned#
    
    Test Plan: New unit test
    
    Reviewers: andrewthad, niteria, bgamari, erikd
    
    Subscribers: rwbarton, thomie, carter
    
    GHC Trac Issues: #14900
    
    Differential Revision: https://phabricator.haskell.org/D4485


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

df2ea10655984234924ad9f2c237289ab8f4baa6
 rts/PrimOps.cmm                   |  3 ++-
 testsuite/tests/rts/T14900.hs     | 22 ++++++++++++++++++++++
 testsuite/tests/rts/T14900.stdout |  3 +++
 testsuite/tests/rts/all.T         |  2 ++
 4 files changed, 29 insertions(+), 1 deletion(-)

diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index 6d57fd8..67a2384 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -160,8 +160,9 @@ stg_isByteArrayPinnedzh ( gcptr ba )
     // Pinned byte arrays live in blocks with the BF_PINNED flag set.
     // We also consider BF_LARGE objects to be immovable. See #13894.
     // See the comment in Storage.c:allocatePinned.
+    // We also consider BF_COMPACT objects to be immovable. See #14900.
     flags = TO_W_(bdescr_flags(bd));
-    return (flags & (BF_PINNED | BF_LARGE) != 0);
+    return (flags & (BF_PINNED | BF_LARGE | BF_COMPACT) != 0);
 }
 
 stg_isMutableByteArrayPinnedzh ( gcptr mba )
diff --git a/testsuite/tests/rts/T14900.hs b/testsuite/tests/rts/T14900.hs
new file mode 100644
index 0000000..bd29289
--- /dev/null
+++ b/testsuite/tests/rts/T14900.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+
+import GHC.Compact
+import GHC.Int
+import GHC.Prim
+import GHC.IO
+import GHC.Exts
+
+data BA = ByteArray ByteArray#
+
+newByteArray :: Int -> IO BA
+newByteArray (I# sz) = IO $ \s -> case newByteArray# sz s of {
+  (# s', arr# #) -> case unsafeFreezeByteArray# arr# s of {
+  (# s'', barr# #) -> (# s', ByteArray barr# #) }}
+
+main :: IO ()
+main = do
+  ByteArray arr1# <- fmap getCompact $ newByteArray 65000 >>= compact
+  ByteArray arr2# <- newByteArray 65000
+  print (I# (isByteArrayPinned# arr1#))
+  print (I# (isByteArrayPinned# arr2#))
+  putStrLn "Finished"
diff --git a/testsuite/tests/rts/T14900.stdout b/testsuite/tests/rts/T14900.stdout
new file mode 100644
index 0000000..fdc259d
--- /dev/null
+++ b/testsuite/tests/rts/T14900.stdout
@@ -0,0 +1,3 @@
+1
+1
+Finished
diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T
index ef77d57..5000a91 100644
--- a/testsuite/tests/rts/all.T
+++ b/testsuite/tests/rts/all.T
@@ -388,3 +388,5 @@ test('T14702', [ ignore_stdout
                , extra_run_opts('+RTS -A32m -N8 -T -RTS')
                ]
                , compile_and_run, [''])
+
+test('T14900', normal, compile_and_run, ['-package ghc-compact'])