diff options
Diffstat (limited to 'testsuite')
| -rw-r--r-- | testsuite/tests/rts/T23221.hs | 70 | ||||
| -rw-r--r-- | testsuite/tests/rts/all.T | 2 |
2 files changed, 72 insertions, 0 deletions
diff --git a/testsuite/tests/rts/T23221.hs b/testsuite/tests/rts/T23221.hs new file mode 100644 index 0000000000..574c26c97e --- /dev/null +++ b/testsuite/tests/rts/T23221.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE MagicHash, UnboxedTuples, NumericUnderscores #-} + +module Main where + +import GHC.Exts +import GHC.IO +import System.Mem +import System.Environment +import Debug.Trace +import Control.Monad +import GHC.Stats +import Data.Word + +-- This test is for checking the memory return behaviour of blocks which will be +-- copied and blocks which are not copied (#23221) +main :: IO () +main = do + [sn] <- getArgs + let n = read sn + -- By checking that lower bound of unpinned is the upper bound of pinned then we + -- check that unpinned has lower memory baseline than pinned. + loop newByteArray 2 3 n + loop newPinnedByteArray 1 2 n + + +-- The upper_bound is the upper bound on how much total memory should be live at the end +-- of the test as a factor of the expected live bytes. +loop f lower_bound upper_bound n = do + ba <- mapM (\_ -> f 128) [0..n] + traceMarkerIO "Allocated_all" + performGC + let !ba' = take (n `div` 4) ba + evaluate (length ba') + traceMarkerIO "GC_4" + performGC + evaluate (length (reverse ba')) + replicateM_ 20 performGC + total_mem <- checkStats lower_bound upper_bound (n `div` 4) + evaluate (length (reverse ba')) + return total_mem + +checkStats :: Double -> Double -> Int -> IO () +checkStats lower_bound upper_bound n = do + stats <- getRTSStats + let expected_live_memory = fromIntegral n -- How many objects + * (3 -- One list cons + + 2 -- One BA constructor + + 18) -- ByteArray# object (size 16 + 2 overhead) + -- size of each object + * 8 -- word size + let bytes_used = gcdetails_mem_in_use_bytes (gc stats) + mblocks = bytes_used `div` (2 ^ 20) + when (truncate (expected_live_memory * upper_bound) < bytes_used) $ + error ("Upper Memory bound failed: " ++ show (truncate expected_live_memory, upper_bound, bytes_used)) + when (truncate (expected_live_memory * lower_bound) >= bytes_used) $ + error ("Lower Memory bound failed: " ++ show (truncate expected_live_memory, lower_bound, bytes_used)) + +data BA = BA ByteArray# + +newByteArray :: Int -> IO BA +newByteArray (I# sz#) = IO $ \s -> case newByteArray# sz# s of + (# s', k #) -> case unsafeFreezeByteArray# k s' of + (# s'', ba# #) -> (# s'', BA ba# #) + +newPinnedByteArray :: Int -> IO BA +newPinnedByteArray (I# sz#) = IO $ \s -> case newPinnedByteArray# sz# s of + (# s', k #) -> case unsafeFreezeByteArray# k s' of + (# s'', ba# #) -> (# s'', BA ba# #) + + diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T index 371a315786..29120a69be 100644 --- a/testsuite/tests/rts/all.T +++ b/testsuite/tests/rts/all.T @@ -590,4 +590,6 @@ test('T22795c', [only_ways(['normal']), js_skip], compile_and_run, ['-threaded - test('T17574', [js_skip], compile_and_run, ['-with-rtsopts -T']) +test('T23221', [js_skip, high_memory_usage, extra_run_opts('1500000'), unless(wordsize(64), skip)], compile_and_run, ['-O -with-rtsopts -T']) + test('T23142', [unless(debug_rts(), skip), req_interp], makefile_test, ['T23142']) |