prof: Fix heap census for large ARR_WORDS (#11627)

The heap census now handles large ARR_WORDS objects which have
been shrunk by shrinkMutableByteArray# or resizeMutableByteArray#.

Test Plan: ./validate && make test WAY=profasm

Reviewers: hvr, bgamari, austin, thomie

Reviewed By: thomie

Subscribers: thomie

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

GHC Trac Issues: #11627

4 files changed, 57 insertions, 0 deletions

diff --git a/testsuite/tests/profiling/should_run/T11627a.hs b/testsuite/tests/profiling/should_run/T11627a.hs
new file mode 100644
index 0000000000..3e1ce3cf8f
--- /dev/null
+++ b/testsuite/tests/profiling/should_run/T11627a.hs
@@ -0,0 +1,6 @@
+-- Original test case for #11627 (space_leak_001.hs)
+
+import Data.List
+
+main :: IO ()
+main = print $ length $ show (foldl' (*) 1 [1..100000] :: Integer)
diff --git a/testsuite/tests/profiling/should_run/T11627a.stdout b/testsuite/tests/profiling/should_run/T11627a.stdout
new file mode 100644
index 0000000000..85dc4185fa
--- /dev/null
+++ b/testsuite/tests/profiling/should_run/T11627a.stdout
@@ -0,0 +1 @@
+456574
diff --git a/testsuite/tests/profiling/should_run/T11627b.hs b/testsuite/tests/profiling/should_run/T11627b.hs
new file mode 100644
index 0000000000..5e5545a4eb
--- /dev/null
+++ b/testsuite/tests/profiling/should_run/T11627b.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE MagicHash     #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+
+-- A reduced test case for #11627
+
+
+import GHC.Prim
+import GHC.Types (Int(..),IO(..))
+import System.Mem
+
+
+main :: IO ()
+main = do
+    -- Allocate a large object (size >= 8/10 of one block = 8/10 * 4096 B)
+    let nBytes = 123 * 4096
+    b <- newBlob nBytes
+
+    -- Shrink it by at least one word
+    let delta = 100
+    shrinkBlob b $ nBytes - delta
+
+    -- Perform a heap census (assumes we are running with -i0, so a census is
+    -- run after every GC)
+    performGC
+
+    -- Hold on to b so it is not GCed before the census
+    shrinkBlob b $ nBytes - delta
+
+------------------------------------------------------------------------------
+
+data Blob = Blob# !(MutableByteArray# RealWorld)
+
+newBlob :: Int -> IO Blob
+newBlob (I# n#) =
+    IO $ \s -> case newByteArray# n# s of
+                   (# s', mba# #) -> (# s', Blob# mba# #)
+
+shrinkBlob :: Blob -> Int -> IO ()
+shrinkBlob (Blob# mba#) (I# n#) =
+    IO $ \s -> case shrinkMutableByteArray# mba# n# s of
+                   s' -> (# s', () #)
diff --git a/testsuite/tests/profiling/should_run/all.T b/testsuite/tests/profiling/should_run/all.T
index 41597a44cc..c6ce6d45a4 100644
--- a/testsuite/tests/profiling/should_run/all.T
+++ b/testsuite/tests/profiling/should_run/all.T
@@ -98,3 +98,11 @@ test('callstack002', [], compile_and_run,
 test('T5363', [], compile_and_run, [''])
 
 test('profinline001', [], compile_and_run, [''])
+
+test('T11627a', [extra_ways(extra_prof_ways)], compile_and_run, [''])
+
+test('T11627b', [ extra_run_opts('+RTS -i0 -RTS')  # census after each GC
+                , extra_ways(extra_prof_ways)
+                ]
+                , compile_and_run
+                , [''])