[commit: ghc] master: prof: Fix heap census for large ARR_WORDS (#11627) (ba95f22)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/ba95f22eb98cc2ee2d8d76e56df80769c379413d/ghc

>---------------------------------------------------------------

commit ba95f22eb98cc2ee2d8d76e56df80769c379413d
Author: Jason Eisenberg <jasoneisenberg at gmail.com>
Date:   Sun Mar 20 17:49:24 2016 +0100

    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


>---------------------------------------------------------------

ba95f22eb98cc2ee2d8d76e56df80769c379413d
 rts/ProfHeap.c                                     | 14 ++++++++
 .../should_run/T11627a.hs}                         |  1 +
 .../should_run/T11627a.stdout}                     |  0
 testsuite/tests/profiling/should_run/T11627b.hs    | 42 ++++++++++++++++++++++
 testsuite/tests/profiling/should_run/all.T         |  8 +++++
 5 files changed, 65 insertions(+)

diff --git a/rts/ProfHeap.c b/rts/ProfHeap.c
index a7ea3eb..819faeb 100644
--- a/rts/ProfHeap.c
+++ b/rts/ProfHeap.c
@@ -937,6 +937,20 @@ 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).
+        // 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 = rtsTrue;
+            heapProfObject(census, (StgClosure *)p, size, prim);
+            continue;
+        }
+
         while (p < bd->free) {
             info = get_itbl((StgClosure *)p);
             prim = rtsFalse;
diff --git a/testsuite/tests/perf/space_leaks/space_leak_001.hs b/testsuite/tests/profiling/should_run/T11627a.hs
similarity index 65%
copy from testsuite/tests/perf/space_leaks/space_leak_001.hs
copy to testsuite/tests/profiling/should_run/T11627a.hs
index cabde0a..3e1ce3c 100644
--- a/testsuite/tests/perf/space_leaks/space_leak_001.hs
+++ b/testsuite/tests/profiling/should_run/T11627a.hs
@@ -1,3 +1,4 @@
+-- Original test case for #11627 (space_leak_001.hs)
 
 import Data.List
 
diff --git a/testsuite/tests/perf/space_leaks/space_leak_001.stdout b/testsuite/tests/profiling/should_run/T11627a.stdout
similarity index 100%
copy from testsuite/tests/perf/space_leaks/space_leak_001.stdout
copy to testsuite/tests/profiling/should_run/T11627a.stdout
diff --git a/testsuite/tests/profiling/should_run/T11627b.hs b/testsuite/tests/profiling/should_run/T11627b.hs
new file mode 100644
index 0000000..5e5545a
--- /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 41597a4..c6ce6d4 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
+                , [''])