Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : ghc-7.6
http://hackage.haskell.org/trac/ghc/changeset/33de4fb027f90c188b1040bd930636a7e43b96b0 >--------------------------------------------------------------- commit 33de4fb027f90c188b1040bd930636a7e43b96b0 Author: Simon Marlow <marlo...@gmail.com> Date: Fri Sep 7 13:36:09 2012 +0100 Some further tweaks to reduce fragmentation when allocating the nursery MERGED from commit a8179622f84bbd52e127a9596d2d4a918ca64e0c >--------------------------------------------------------------- rts/sm/BlockAlloc.c | 48 ++++++++++++++++++++++++++++++++---------------- rts/sm/BlockAlloc.h | 2 +- rts/sm/Storage.c | 6 ++++-- 3 files changed, 37 insertions(+), 19 deletions(-) diff --git a/rts/sm/BlockAlloc.c b/rts/sm/BlockAlloc.c index 5d1b1c0..93e06da 100644 --- a/rts/sm/BlockAlloc.c +++ b/rts/sm/BlockAlloc.c @@ -390,35 +390,51 @@ finish: } // -// Allocate a chunk of blocks that is at most a megablock in size. -// This API is used by the nursery allocator that wants contiguous -// memory preferably, but doesn't require it. When memory is -// fragmented we might have lots of large chunks that are less than a -// full megablock, so allowing the nursery allocator to use these -// reduces fragmentation considerably. e.g. on a GHC build with +RTS -// -H, I saw fragmentation go from 17MB down to 3MB on a single compile. +// Allocate a chunk of blocks that is at least min and at most max +// blocks in size. This API is used by the nursery allocator that +// wants contiguous memory preferably, but doesn't require it. When +// memory is fragmented we might have lots of large chunks that are +// less than a full megablock, so allowing the nursery allocator to +// use these reduces fragmentation considerably. e.g. on a GHC build +// with +RTS -H, I saw fragmentation go from 17MB down to 3MB on a +// single compile. // bdescr * -allocLargeChunk (void) +allocLargeChunk (nat min, nat max) { bdescr *bd; - nat ln; + nat ln, lnmax; - ln = 5; // start in the 32-63 block bucket - while (ln < MAX_FREE_LIST && free_list[ln] == NULL) { + if (min >= BLOCKS_PER_MBLOCK) { + return allocGroup(max); + } + + ln = log_2_ceil(min); + lnmax = log_2_ceil(max); // tops out at MAX_FREE_LIST + + while (ln < lnmax && free_list[ln] == NULL) { ln++; } - if (ln == MAX_FREE_LIST) { - return allocGroup(BLOCKS_PER_MBLOCK); + if (ln == lnmax) { + return allocGroup(max); } bd = free_list[ln]; + if (bd->blocks <= max) // exactly the right size! + { + dbl_link_remove(bd, &free_list[ln]); + initGroup(bd); + } + else // block too big... + { + bd = split_free_block(bd, max, ln); + ASSERT(bd->blocks == max); + initGroup(bd); + } + n_alloc_blocks += bd->blocks; if (n_alloc_blocks > hw_alloc_blocks) hw_alloc_blocks = n_alloc_blocks; - dbl_link_remove(bd, &free_list[ln]); - initGroup(bd); - IF_DEBUG(sanity, memset(bd->start, 0xaa, bd->blocks * BLOCK_SIZE)); IF_DEBUG(sanity, checkFreeListSanity()); return bd; diff --git a/rts/sm/BlockAlloc.h b/rts/sm/BlockAlloc.h index d40cc42..1288e4d 100644 --- a/rts/sm/BlockAlloc.h +++ b/rts/sm/BlockAlloc.h @@ -11,7 +11,7 @@ #include "BeginPrivate.h" -bdescr *allocLargeChunk (void); +bdescr *allocLargeChunk (nat min, nat max); /* Debugging -------------------------------------------------------------- */ diff --git a/rts/sm/Storage.c b/rts/sm/Storage.c index 45b6b89..e504c28 100644 --- a/rts/sm/Storage.c +++ b/rts/sm/Storage.c @@ -438,8 +438,10 @@ allocNursery (bdescr *tail, W_ blocks) // tiny optimisation (~0.5%), but it's free. while (blocks > 0) { - if (blocks >= BLOCKS_PER_MBLOCK) { - bd = allocLargeChunk(); // see comment with allocLargeChunk() + if (blocks >= BLOCKS_PER_MBLOCK / 4) { + n = stg_min(BLOCKS_PER_MBLOCK, blocks); + bd = allocLargeChunk(16, n); // see comment with allocLargeChunk() + // NB. we want a nice power of 2 for the minimum here n = bd->blocks; } else { bd = allocGroup(blocks); _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
