blob: 574c26c97e5a02dff3cba093efdc19a57be000ec (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
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# #)
|
