Make RTS keep less memory (fixes #14702)

Currently runtime keeps hold to 4*used_memory. This includes, in
particular, nursery, which can be quite large on multiprocessor
machines: 16 CPUs x 64Mb each is 1GB. Multiplying it by 4 means whatever
actual memory usage is, runtime will never release memory under 4GB, and
this is quite excessive for processes which only need a lot of memory
shortly (think building data structures from large files).

This diff makes multiplier to apply only to GC-managed memory, leaving
all "static" allocations alone.

Test Plan: make test TEST="T14702"

Reviewers: bgamari, erikd, simonmar

Reviewed By: simonmar

Subscribers: rwbarton, thomie, carter

GHC Trac Issues: #14702

Differential Revision: https://phabricator.haskell.org/D4338

2 files changed, 41 insertions, 0 deletions

diff --git a/testsuite/tests/rts/T14702.hs b/testsuite/tests/rts/T14702.hs
new file mode 100644
index 0000000000..8e07529f47
--- /dev/null
+++ b/testsuite/tests/rts/T14702.hs
@@ -0,0 +1,36 @@
+module Main where
+
+import Control.Monad
+import Data.Array.IO.Safe
+import Data.Word
+import GHC.Stats
+import System.Exit
+import System.Mem
+
+printAlloc :: String -> IO (Word64, Word64)
+printAlloc name = do
+    performGC
+    details <- gc <$> getRTSStats
+    let dat = (gcdetails_live_bytes details, gcdetails_mem_in_use_bytes details)
+    putStrLn $ name ++ ": " ++ show dat
+    pure dat
+
+allocateAndPrint :: IO ()
+allocateAndPrint = do
+    -- allocate and touch a lot of memory (4MB * 260 ~ 1GB)
+    memoryHog <- forM [1 .. 300] $ \_ ->
+        (newArray (0, 1000000) 0 :: IO (IOUArray Word Word32))
+    _ <- printAlloc "with large allocation"
+    -- do something with memory to prevent it from being GC'ed until now
+    forM_ memoryHog $ \a -> void $ readArray a 0
+
+main :: IO ()
+main = do
+    (firstLive, firstTotal) <- printAlloc "initial"
+    allocateAndPrint
+    (lastLive, lastTotal) <- printAlloc "final"
+
+    -- Now there is no reason to have more memory allocated than at start
+    let ratio = fromIntegral lastTotal / fromIntegral firstTotal
+    putStrLn $ "alloc ratio " ++ show ratio
+    when (ratio > 1.5) $ exitFailure
diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T
index fe86dd1146..ef77d5766e 100644
--- a/testsuite/tests/rts/all.T
+++ b/testsuite/tests/rts/all.T
@@ -383,3 +383,8 @@ test('T13832', exit_code(1), compile_and_run, ['-threaded'])
 test('T13894', normal, compile_and_run, [''])
 test('T14497', normal, compile_and_run, ['-O'])
 test('T14695', normal, run_command, ['$MAKE -s --no-print-directory T14695'])
+test('T14702', [ ignore_stdout
+               , only_ways(['threaded1', 'threaded2'])
+               , extra_run_opts('+RTS -A32m -N8 -T -RTS')
+               ]
+               , compile_and_run, [''])