diff options
| -rw-r--r-- | libraries/ghc-compact/tests/T18757.hs | 44 | ||||
| -rw-r--r-- | libraries/ghc-compact/tests/T18757.stdout-ws-32 | 1 | ||||
| -rw-r--r-- | libraries/ghc-compact/tests/T18757.stdout-ws-64 | 1 | ||||
| -rw-r--r-- | libraries/ghc-compact/tests/all.T | 1 | ||||
| -rw-r--r-- | rts/sm/CNF.c | 11 |
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 { |