Fix new compact block allocation in allocateForCompact

allocateForCompact() is called when nursery of a compact region is
full, to add new blocks to the compact. New blocks added to an existing
region needs a StgCompactNFDataBlock header, not a StgCompactNFData.

This fixes allocateForCompact() so that it now correctly allocates space
for StgCompactNFDataBlock instead of StgCompactNFData as before.

Fixes #17044.

A regression test T17044 added.

3 files changed, 32 insertions, 2 deletions

diff --git a/libraries/ghc-compact/tests/T17044.hs b/libraries/ghc-compact/tests/T17044.hs
new file mode 100644
index 0000000000..1e4a73f5a6
--- /dev/null
+++ b/libraries/ghc-compact/tests/T17044.hs
@@ -0,0 +1,30 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+import Data.Traversable (for)
+import GHC.Compact
+import GHC.Exts
+import GHC.IO
+
+main :: IO ()
+main = do
+  c <- compact ()
+  big <- newByteArray 1032128
+  bigFrozen <- unsafeFreezeByteArray big
+  c' <- compactAdd c bigFrozen
+
+  _placeholders <- for [0 :: Int .. 2044] $ \i -> do
+    getCompact <$> compactAdd c' i
+
+  return ()
+
+data ByteArray = ByteArray ByteArray#
+
+data MutableByteArray s = MutableByteArray (MutableByteArray# s)
+
+newByteArray :: Int -> IO (MutableByteArray RealWorld)
+newByteArray (I# n#) = IO (\s# -> case newByteArray# n# s# of (# s'#, arr# #) -> (# s'#, MutableByteArray arr# #))
+
+unsafeFreezeByteArray :: MutableByteArray RealWorld -> IO ByteArray
+unsafeFreezeByteArray (MutableByteArray arr#) = IO (\s# -> case unsafeFreezeByteArray# arr# s# of (# s'#, arr'# #) -> (# s'#, ByteArray arr'# #))
diff --git a/libraries/ghc-compact/tests/all.T b/libraries/ghc-compact/tests/all.T
index ec0d20fe05..4a1bab9336 100644
--- a/libraries/ghc-compact/tests/all.T
+++ b/libraries/ghc-compact/tests/all.T
@@ -21,3 +21,4 @@ test('compact_share', omit_ways(['ghci', 'profasm', 'profthreaded']),
 		      compile_and_run, [''])
 test('compact_bench', [ ignore_stdout, extra_run_opts('100') ],
                        compile_and_run, [''])
+test('T17044', normal, compile_and_run, [''])
diff --git a/rts/sm/CNF.c b/rts/sm/CNF.c
index 0432505cd2..597b7853bc 100644
--- a/rts/sm/CNF.c
+++ b/rts/sm/CNF.c
@@ -488,8 +488,7 @@ allocateForCompact (Capability *cap,
     // We know it doesn't fit in the nursery
     // if it is a large object, allocate a new block
     if (sizeW > LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
-        next_size = BLOCK_ROUND_UP(sizeW*sizeof(W_) +
-                                   sizeof(StgCompactNFData));
+        next_size = BLOCK_ROUND_UP(sizeW*sizeof(W_) + sizeof(StgCompactNFDataBlock));
         block = compactAppendBlock(cap, str, next_size);
         bd = Bdescr((P_)block);
         to = bd->free;