Compacted arrays are pinned for isByteArrayPinned#
authorSimon Marlow <marlowsd@gmail.com>
Thu, 8 Mar 2018 08:54:01 +0000 (08:54 +0000)
committerSimon Marlow <marlowsd@gmail.com>
Fri, 9 Mar 2018 09:27:17 +0000 (09:27 +0000)
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

rts/PrimOps.cmm
testsuite/tests/rts/T14900.hs [new file with mode: 0644]
testsuite/tests/rts/T14900.stdout [new file with mode: 0644]
testsuite/tests/rts/all.T

index 6d57fd8..67a2384 100644 (file)
@@ -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 (file)
index 0000000..bd29289
--- /dev/null
@@ -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 (file)
index 0000000..fdc259d
--- /dev/null
@@ -0,0 +1,3 @@
+1
+1
+Finished
index ef77d57..5000a91 100644 (file)
@@ -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'])