rts: Refine memory retention behaviour to account for pinned/compacted objects

When using the copying collector there is still a lot of data which
isn't copied (such as pinned, compacted, large objects etc). The logic
to decide how much memory to retain didn't take into account that these
wouldn't be copied. Therefore we pessimistically retained 2* the amount
of memory for these blocks even though they wouldn't be copied by the
collector.

The solution is to split up the heap into two parts, the parts which
will be copied and the parts which won't be copied. Then the appropiate
factor is applied to each part individually (2 * for copying and 1.2 *
for not copying).

The T23221 test demonstrates this improvement with a program which first
allocates many unpinned ByteArray# followed by many pinned ByteArray#
and observes the difference in the ultimate memory baseline between the
two.

There are some charts on #23221.

Fixes #23221

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'])