Commit ba95f22e authored by Jason Eisenberg's avatar Jason Eisenberg Committed by Ben Gamari

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
parent 7186a01a
......@@ -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;
......
-- Original test case for #11627 (space_leak_001.hs)
import Data.List
main :: IO ()
main = print $ length $ show (foldl' (*) 1 [1..100000] :: Integer)
{-# 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', () #)
......@@ -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
, [''])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment