diff options
-rw-r--r-- | testsuite/tests/rts/T17574.hs | 40 | ||||
-rw-r--r-- | testsuite/tests/rts/T17574.stdout | 2 | ||||
-rw-r--r-- | testsuite/tests/rts/all.T | 2 |
3 files changed, 44 insertions, 0 deletions
diff --git a/testsuite/tests/rts/T17574.hs b/testsuite/tests/rts/T17574.hs new file mode 100644 index 0000000000..2af8d156b1 --- /dev/null +++ b/testsuite/tests/rts/T17574.hs @@ -0,0 +1,40 @@ +-- | Check that large objects are properly accounted for by GHC.Stats +module Main (main) where + +import Control.Monad +import Control.Exception +import Control.Concurrent +import System.Mem +import System.Exit +import GHC.Stats +import GHC.Compact +import Data.List (replicate) + +import qualified Data.ByteString.Char8 as BS + +doGC :: IO () +doGC = do + performMajorGC + threadDelay 1000 -- small delay to allow GC to run when using concurrent gc + +main :: IO () +main = do + let size = 4096*2 + largeString <- evaluate $ BS.replicate size 'A' + compactString <- compact $ replicate size 'A' + doGC + doGC -- run GC twice to make sure the objects end up in the oldest gen + stats <- getRTSStats + let large_obj_bytes = gcdetails_large_objects_bytes $ gc stats + let compact_obj_bytes = gcdetails_compact_bytes $ gc stats + -- assert that large_obj_bytes is at least as big as size + -- this indicates that `largeString` is being accounted for by the stats department + when (large_obj_bytes < fromIntegral size) $ do + putStrLn $ "large_obj_bytes is: " <> show large_obj_bytes <> " but expected at least: " <> show size + exitFailure + when (compact_obj_bytes < fromIntegral size) $ do + putStrLn $ "compact_obj_bytes is: " <> show large_obj_bytes <> " but expected at least: " <> show size + exitFailure + -- keep them alive + print $ BS.length largeString + print $ length $ getCompact compactString diff --git a/testsuite/tests/rts/T17574.stdout b/testsuite/tests/rts/T17574.stdout new file mode 100644 index 0000000000..82950d41bb --- /dev/null +++ b/testsuite/tests/rts/T17574.stdout @@ -0,0 +1,2 @@ +8192 +8192 diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T index 407c653655..ba18e32d35 100644 --- a/testsuite/tests/rts/all.T +++ b/testsuite/tests/rts/all.T @@ -573,3 +573,5 @@ test('decodeMyStack_emptyListForMissingFlag', test('T22795a', [only_ways(['normal']), js_skip], compile_and_run, ['-threaded']) test('T22795b', [only_ways(['normal']), js_skip], compile_and_run, ['-single-threaded']) test('T22795c', [only_ways(['normal']), js_skip], compile_and_run, ['-threaded -single-threaded']) + +test('T17574', [js_skip], compile_and_run, ['-with-rtsopts -T']) |