Handle large ARR_WORDS in heap census (fix #17572)

We can do a heap census with a non-profiling RTS. With a non-profiling
RTS we don't zero superfluous bytes of shrunk arrays hence a need to
handle the case specifically to avoid a crash.

Revert part of a586b33f8e8ad60b5c5ef3501c89e9b71794bbed

4 files changed, 35 insertions, 0 deletions

diff --git a/rts/ProfHeap.c b/rts/ProfHeap.c
index c35b4bae4e..4f82b0ba83 100644
--- a/rts/ProfHeap.c
+++ b/rts/ProfHeap.c
@@ -1011,6 +1011,22 @@ heapCensusChain( Census *census, bdescr *bd )
 
         p = bd->start;
 
+        // When we shrink a large ARR_WORDS, we do not adjust the free pointer
+        // of the associated block descriptor, thus introducing slop at the end
+        // of the object.  This slop remains after GC, violating the assumption
+        // of the loop below that all slop has been eliminated (#11627).
+        // The slop isn't always zeroed (e.g. in non-profiling mode, cf
+        // OVERWRITING_CLOSURE_OFS).
+        // Consequently, we handle large ARR_WORDS objects as a special case.
+        if (bd->flags & BF_LARGE
+            && get_itbl((StgClosure *)p)->type == ARR_WORDS) {
+            size = arr_words_sizeW((StgArrBytes *)p);
+            prim = true;
+            heapProfObject(census, (StgClosure *)p, size, prim);
+            continue;
+        }
+
+
         while (p < bd->free) {
             info = get_itbl((const StgClosure *)p);
             prim = false;
diff --git a/testsuite/tests/profiling/should_run/T17572.hs b/testsuite/tests/profiling/should_run/T17572.hs
new file mode 100644
index 0000000000..8c36b4cefb
--- /dev/null
+++ b/testsuite/tests/profiling/should_run/T17572.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE UnboxedTuples, MagicHash, BlockArguments #-}
+
+import GHC.Exts
+import GHC.Types
+
+doSomething :: Word -> IO Word
+doSomething (W# x) = IO \s ->
+   case newByteArray# 7096# s of -- we need a large ByteArray#
+      (# s, mba #) -> case shrinkMutableByteArray# mba 7020# s of -- shrunk
+            s -> case unsafeFreezeByteArray# mba s of
+               (# s, ba #) -> (# s, W# (indexWordArray# ba 18#) #)
+
+main :: IO ()
+main = do
+   xs <- mapM doSomething [0..300000] -- we need enough elements (to trigger a GC maybe?)
+   print (length xs)
diff --git a/testsuite/tests/profiling/should_run/T17572.stdout b/testsuite/tests/profiling/should_run/T17572.stdout
new file mode 100644
index 0000000000..7b1239c6a5
--- /dev/null
+++ b/testsuite/tests/profiling/should_run/T17572.stdout
@@ -0,0 +1 @@
+300001
diff --git a/testsuite/tests/profiling/should_run/all.T b/testsuite/tests/profiling/should_run/all.T
index b711055667..fe98517d96 100644
--- a/testsuite/tests/profiling/should_run/all.T
+++ b/testsuite/tests/profiling/should_run/all.T
@@ -149,3 +149,5 @@ test('T15897',
       run_timeout_multiplier(2),
       fragile(15467)],
      makefile_test, ['T15897'])
+
+test('T17572', [], compile_and_run, [''])