Remove special case for large objects in allocateForCompact

allocateForCompact() is called when the current allocation for the
compact region does not fit in the nursery. It previously had a special
case for objects exceeding the large object threshold. In that case, it
would allocate a new compact region block just for that object. That led
to a lot of small blocks being allocated in compact regions with a
larger default block size (`autoBlockW`).

This commit removes this special case because having a lot of small
compact region blocks contributes significantly to memory fragmentation.

The removal should be valid because
- a more generic case for allocating a new compact region block follows
  at the end of allocateForCompact(), and that one takes `autoBlockW`
  into account
- the reason for allocating separate blocks for large objects in the
  main heap seems to be to avoid copying during GCs, but once inside
  the compact region, the object will never be copied anyway.

Fixes #18757.

A regression test T18757 was added.

5 files changed, 47 insertions, 11 deletions

diff --git a/libraries/ghc-compact/tests/T18757.hs b/libraries/ghc-compact/tests/T18757.hs
new file mode 100644
index 0000000000..70a93b9bd8
--- /dev/null
+++ b/libraries/ghc-compact/tests/T18757.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+import Control.Monad
+import GHC.Compact
+import GHC.Compact.Serialized
+import GHC.IO
+import GHC.Prim
+
+-- | Test case for #18757, ensuring that the compact region allocator doesn't produce blocks
+-- smaller than the chosen default block size.
+main :: IO ()
+main = do
+  let
+    -- Valid for the x86_64 target of GHC
+    blocksPerMBlock, blockSize, dataBytesInMegablock :: Integral a => a
+    blocksPerMBlock = 252
+    blockSize = 4096
+    dataBytesInMegablock = blocksPerMBlock * blockSize
+
+  region <- compactSized dataBytesInMegablock False ()
+  largeObject <- newLargeObject
+
+  -- Add the large object a few times to our compact region:
+  replicateM 510 $ void $ compactAdd region largeObject
+
+  -- Now check how many blocks were allocated,
+  -- and how much data they each contain
+  blockSizes <- withSerializedCompact region $ \serialized ->
+    pure $ map snd $ serializedCompactBlockList serialized
+
+  -- This should print a list with only two entries, as the allocated objects
+  -- should all fit within one megablock.
+  print blockSizes
+
+-- | Create an object larger than the large object threshold
+-- (valid for the x86_64 target of GHC)
+newLargeObject :: IO LargeObject
+newLargeObject = IO $ \s ->
+  case newByteArray# 4000# s of
+    (# s', arr #) -> case unsafeFreezeByteArray# arr s of
+      (# s'', frozenArr #) -> (# s'', LargeObject frozenArr #)
+
+data LargeObject = LargeObject ByteArray#
diff --git a/libraries/ghc-compact/tests/T18757.stdout-ws-32 b/libraries/ghc-compact/tests/T18757.stdout-ws-32
new file mode 100644
index 0000000000..34575b4202
--- /dev/null
+++ b/libraries/ghc-compact/tests/T18757.stdout-ws-32
@@ -0,0 +1 @@
+[1036268,1011956]
diff --git a/libraries/ghc-compact/tests/T18757.stdout-ws-64 b/libraries/ghc-compact/tests/T18757.stdout-ws-64
new file mode 100644
index 0000000000..94081bd9e3
--- /dev/null
+++ b/libraries/ghc-compact/tests/T18757.stdout-ws-64
@@ -0,0 +1 @@
+[1032152,1024296]
diff --git a/libraries/ghc-compact/tests/all.T b/libraries/ghc-compact/tests/all.T
index 45e8d5f378..97cc7bd40a 100644
--- a/libraries/ghc-compact/tests/all.T
+++ b/libraries/ghc-compact/tests/all.T
@@ -22,6 +22,7 @@ test('compact_share', omit_ways(['ghci', 'profasm', 'profthreaded']),
 test('compact_bench', [ ignore_stdout, extra_run_opts('100') ],
                        compile_and_run, [''])
 test('T17044', normal, compile_and_run, [''])
+test('T18757', normal, compile_and_run, [''])
 # N.B. Sanity check times out due to large list.
 test('T16992', [when(wordsize(32), skip), # Resource limit exceeded on 32-bit
                 high_memory_usage,
diff --git a/rts/sm/CNF.c b/rts/sm/CNF.c
index 25c50adcc3..a6bd3b69f0 100644
--- a/rts/sm/CNF.c
+++ b/rts/sm/CNF.c
@@ -489,17 +489,6 @@ allocateForCompact (Capability *cap,
     bd = Bdescr((P_)str->nursery);
     bd->free = str->hp;
 
-    // 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(StgCompactNFDataBlock));
-        block = compactAppendBlock(cap, str, next_size);
-        bd = Bdescr((P_)block);
-        to = bd->free;
-        bd->free += sizeW;
-        return to;
-    }
-
     // move the nursery past full blocks
     if (block_is_full (str->nursery)) {
         do {