diff options
author | Teo Camarasu <teofilcamarasu@gmail.com> | 2023-03-02 12:41:15 +0000 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2023-03-25 00:03:24 -0400 |
commit | 43bd76946233fd0b21293917be8fd455341cb6d3 (patch) | |
tree | be0fd8e5f8e395e02b0c6deda275655ff95ab772 | |
parent | 6a73655fd6d22f0fd7e1c24d0d07a573b6bdc042 (diff) | |
download | haskell-43bd76946233fd0b21293917be8fd455341cb6d3.tar.gz |
Add regression test for #17574
This test currently fails in the nonmoving way
-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']) |