1 files changed, 56 insertions, 0 deletions
diff --git a/testsuite/tests/rts/T19481.hs b/testsuite/tests/rts/T19481.hs
new file mode 100644
index 0000000000..bd3ed6895f
--- /dev/null
+++ b/testsuite/tests/rts/T19481.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE MagicHash #-}
+module Main where
+
+import GHC.Exts
+import GHC.IO
+import GHC.Stats
+import System.Mem
+import Control.Monad
+
+data BA = BA ByteArray#
+
+-- TODO: This shouldn't be hardcoded but MBLOCK_SIZE isn't exported by
+-- any RTS header I could find.
+mblockSize = 2 ^ 20
+
+main = do
+ -- Increasing this number increases the amount of fragmentation (but not
+ -- linearly)
+ ba <- replicateM 500 one
+ replicateM 100 performMajorGC
+ s <- getRTSStats
+ let mblocks = (gcdetails_mem_in_use_bytes (gc s) `div` mblockSize)
+ if mblocks < 15
+  then return ()
+  else error ("Heap is fragmented: " ++ show mblocks)
+ return ()
+
+one = do
+  ba <- mkBlock
+  bs <- mapM isP ba
+  return ()
+
+
+isP (BA ba) = IO $ \s0 -> (# s0, isTrue# (isByteArrayPinned# ba) #)
+
+mkN 0 = return []
+mkN k = (:) <$> mkBA <*> mkN (k - 1)
+
+-- Mixture of pinned and unpinned allocation so that allocatePinned takes
+-- some pinned blocks from the nursery.
+mkBlock = (++) <$> replicateM 100 mkBAP <*> replicateM 10000 mkBA
+
+mkBAP =
+    IO $ \s0 ->
+      -- 1024 is below large object threshold but fills up a block quickly
+      case newPinnedByteArray# 1024# s0 of
+        (# s1, mba #) -> case unsafeFreezeByteArray# mba s1 of
+           (# s2, ba #) -> (# s2, BA ba #)
+
+mkBA =
+    IO $ \s0 ->
+      -- 1024 is below large object threshold but fills up a block quickly
+      case newByteArray# 1024# s0 of
+        (# s1, mba #) -> case unsafeFreezeByteArray# mba s1 of
+           (# s2, ba #) -> (# s2, BA ba #)