prof: Fix heap census for large ARR_WORDS (#11627)
authorJason Eisenberg <jasoneisenberg@gmail.com>
Sun, 20 Mar 2016 16:49:24 +0000 (17:49 +0100)
committerBen Gamari <ben@smart-cactus.org>
Sun, 20 Mar 2016 17:31:20 +0000 (18:31 +0100)
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

rts/ProfHeap.c
testsuite/tests/profiling/should_run/T11627a.hs [new file with mode: 0644]
testsuite/tests/profiling/should_run/T11627a.stdout [new file with mode: 0644]
testsuite/tests/profiling/should_run/T11627b.hs [new file with mode: 0644]
testsuite/tests/profiling/should_run/all.T

index a7ea3eb..819faeb 100644 (file)
@@ -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/profiling/should_run/T11627a.hs b/testsuite/tests/profiling/should_run/T11627a.hs
new file mode 100644 (file)
index 0000000..3e1ce3c
--- /dev/null
@@ -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 (file)
index 0000000..85dc418
--- /dev/null
@@ -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 (file)
index 0000000..5e5545a
--- /dev/null
@@ -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', () #)
index 41597a4..c6ce6d4 100644 (file)
@@ -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
+                , [''])