Don't consider large byte arrays/compact regions pinned.

Workaround for #22255 which showed how treating large/compact regions
as pinned could cause segfaults.

5 files changed, 18 insertions, 6 deletions

diff --git a/libraries/ghc-prim/changelog.md b/libraries/ghc-prim/changelog.md
index f62aa2474b..0e909da691 100644
--- a/libraries/ghc-prim/changelog.md
+++ b/libraries/ghc-prim/changelog.md
@@ -21,6 +21,13 @@
 - The `threadLabel#` primop was added, allowing the user to query the label of
   a given `ThreadId#`.
 
+- `isByteArrayPinned#` now only considers an array pinned if it was explicitly pinned
+  by the user. This is required to avoid ghc issue [#22255](https://gitlab.haskell.org/ghc/ghc/-/issues/22255)
+  which showed that the old behaviour could cause segfaults when used in combination
+  with compact regions.
+  We are working on ways to allow users and library authors to get back the
+  performance benefits of the old behaviour where possible.
+
 ## 0.9.0 *August 2022*
 
 - Shipped with GHC 9.4.1
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index 0868fdaa9e..adb48c97d9 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -209,7 +209,10 @@ stg_isByteArrayPinnedzh ( gcptr ba )
     // 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 | BF_COMPACT) != 0);
+
+    // We used to also consider BF_LARGE pinned, but stopped doing so
+    // because it interacted badly with compact regions. See #22255
+    return (flags & BF_PINNED != 0);
 }
 
 stg_isMutableByteArrayPinnedzh ( gcptr mba )
diff --git a/testsuite/tests/rts/T13894.hs b/testsuite/tests/rts/T13894.hs
index e09e90802c..226ba18aa7 100644
--- a/testsuite/tests/rts/T13894.hs
+++ b/testsuite/tests/rts/T13894.hs
@@ -1,5 +1,5 @@
--- Test that isByteArray# returns True for large but not explicitly pinned byte
--- arrays
+-- Test that isByteArray# returns False for large but not explicitly pinned byte
+-- arrays, see #22255
 
 {-# LANGUAGE MagicHash #-}
 {-# LANGUAGE UnboxedTuples  #-}
@@ -15,4 +15,4 @@ main = do
         (# s1, arr# #) ->
             case isMutableByteArrayPinned# arr# of
               n# -> (# s1, isTrue# n# #)
-    unless pinned $ putStrLn "BAD"
+    when pinned $ putStrLn "BAD"
diff --git a/testsuite/tests/rts/T14900.hs b/testsuite/tests/rts/T14900.hs
index 613f66d3a9..e1de9a6a89 100644
--- a/testsuite/tests/rts/T14900.hs
+++ b/testsuite/tests/rts/T14900.hs
@@ -13,6 +13,8 @@ newByteArray (I# sz) = IO $ \s -> case newByteArray# sz s of {
   (# s', arr# #) -> case unsafeFreezeByteArray# arr# s of {
   (# s'', barr# #) -> (# s', ByteArray barr# #) }}
 
+-- Currently we expect large/compact regions not to count as pinned.
+-- See #22255 for the reasoning.
 main :: IO ()
 main = do
   ByteArray arr1# <- fmap getCompact $ newByteArray 65000 >>= compact
diff --git a/testsuite/tests/rts/T14900.stdout b/testsuite/tests/rts/T14900.stdout
index fdc259d094..a74cb09c28 100644
--- a/testsuite/tests/rts/T14900.stdout
+++ b/testsuite/tests/rts/T14900.stdout
@@ -1,3 +1,3 @@
-1
-1
+0
+0
 Finished