Hi Simon,
Here's a HEAD patch for the block allocator that removes (I think ;-])
the more subtle O(N^2) portion of the allocator namely when performing
block descriptor initialisation.
I should also comment that I think there's a bug in the merge of
my original patch with HEAD where BF_ALLOCATED was switched to BF_FREE -
I think I'm correct in saying that if you do this, then the last block
descriptor in a block chunk must also have it's flags set to BF_FREE
so that predecessor coalescing may occur (in addition on allocation
these must also be cleared). I've remedied this (I hope ;-]) in the
attached patch.
Let me know your thoughts!
Cheers
Andy
On Sun, 5 Jun 2005, Andrew Cheadle wrote:
>Hi Simon,
>
>Here's a patch for the block allocator that reduces the coalescing
>algorithm from O(N^2) to N.
>
>I created the mods and tested them on my 6.2 builds and then prop'd them
>to the current 6.4 CVS HEAD. When I get a chance and HEAD is unb0rked
>I'll test them on it. Hopefully the attached patch as is fine though ;-)
>Any problems/bugs/idiocy let me know!
>
>Cheers
>
>Andy
>
>*********************************************************************
>* Andrew Cheadle email: [EMAIL PROTECTED] *
>* Department of Computing http://www.doc.ic.ac.uk/~amc4/ *
>* Imperial College *
>* University of London *
>*********************************************************************
*********************************************************************
* Andrew Cheadle email: [EMAIL PROTECTED] *
* Department of Computing http://www.doc.ic.ac.uk/~amc4/ *
* Imperial College *
* University of London *
*********************************************************************
diff -r -rcs --exclude=CVS ../clean/fptools/ghc/includes/Block.h
ghc/includes/Block.h
*** ../clean/fptools/ghc/includes/Block.h 2005-06-13 13:29:48.000000000
+0100
--- ghc/includes/Block.h 2005-06-30 10:22:48.652917328 +0100
***************
*** 87,92 ****
--- 87,94 ----
#define BF_COMPACTED 8
/* Block is free, and on the free list */
#define BF_FREE 16
+ /* Block is in process of being freed, and on a temporary free list */
+ #define BF_FREEING 32
/* Finding the block descriptor for a given block --------------------------
*/
***************
*** 159,164 ****
--- 161,180 ----
*list = bd;
}
+ INLINE_HEADER void
+ dbl_unlink_from(bdescr *bd, bdescr **list)
+ {
+ if (bd->u.back) {
+ bd->u.back->link = bd->link;
+ }
+ if (bd->link) {
+ bd->link->u.back = bd->u.back;
+ }
+ if (*list == bd) {
+ *list = bd->link;
+ }
+ }
+
/* Initialisation ----------------------------------------------------------
*/
extern void initBlockAllocator(void);
***************
*** 172,177 ****
--- 188,194 ----
extern void freeGroup(bdescr *p);
extern void freeChain(bdescr *p);
+ extern void prepareToFreeChain(bdescr **list_head, bdescr **list_tail, bdescr
*p);
/* Round a value to megablocks ---------------------------------------------
*/
diff -r -rcs --exclude=CVS ../clean/fptools/ghc/rts/Arena.c ghc/rts/Arena.c
*** ../clean/fptools/ghc/rts/Arena.c 2005-02-23 10:59:17.000000000 +0000
--- ghc/rts/Arena.c 2005-06-28 12:04:14.000000000 +0100
***************
*** 107,114 ****
next = bd->link;
arena_blocks -= bd->blocks;
ASSERT(arena_blocks >= 0);
- freeGroup(bd);
}
stgFree(arena);
}
--- 107,114 ----
next = bd->link;
arena_blocks -= bd->blocks;
ASSERT(arena_blocks >= 0);
}
+ freeChain(arena->current);
stgFree(arena);
}
diff -r -rcs --exclude=CVS ../clean/fptools/ghc/rts/BlockAlloc.c
ghc/rts/BlockAlloc.c
*** ../clean/fptools/ghc/rts/BlockAlloc.c 2005-06-13 13:29:49.000000000
+0100
--- ghc/rts/BlockAlloc.c 2005-07-02 10:41:20.411311384 +0100
***************
*** 27,32 ****
--- 27,33 ----
static void initMBlock(void *mblock);
static bdescr *allocMegaGroup(nat mblocks);
static void freeMegaGroup(bdescr *bd);
+ static void initTempFreeListGroup(bdescr *list);
static bdescr *free_list = NULL;
***************
*** 36,42 ****
void initBlockAllocator(void)
{
! // The free list starts off NULL
}
/*
-----------------------------------------------------------------------------
--- 37,43 ----
void initBlockAllocator(void)
{
! // The free list starts off NULL
}
/*
-----------------------------------------------------------------------------
***************
*** 46,60 ****
STATIC_INLINE void
initGroupTail(nat n, bdescr *head, bdescr *tail)
{
! bdescr *bd;
! nat i;
! for (i=0, bd = tail; i < n; i++, bd++) {
! bd->flags = 0;
! bd->free = 0;
! bd->blocks = 0;
! bd->link = head;
! }
}
STATIC_INLINE void
--- 47,61 ----
STATIC_INLINE void
initGroupTail(nat n, bdescr *head, bdescr *tail)
{
! bdescr *bd;
! nat i;
! for (i=0, bd = tail; i < n; i++, bd++) {
! bd->flags = 0;
! bd->free = 0;
! bd->blocks = 0;
! bd->link = head;
! }
}
STATIC_INLINE void
***************
*** 65,71 ****
head->free = head->start;
head->link = NULL;
head->flags = 0;
! initGroupTail( n-1, head, head+1 );
}
}
--- 66,72 ----
head->free = head->start;
head->link = NULL;
head->flags = 0;
! initGroupTail(n - 1, head, head + 1);
}
}
***************
*** 93,102 ****
--- 94,106 ----
bd->flags = 0;
bd->free = bd->start;
bd->link = NULL;
+ /* Not quite true - must clear tail block flags! */
+ ((bdescr *)(bd + bd->blocks - 1))->flags = 0;
return bd;
}
if (bd->blocks > n) { /* block too big... */
bd->blocks -= n; /* take a chunk off the *end* */
+ ((bdescr *)(bd + bd->blocks - 1))->flags = BF_FREE;
bd += bd->blocks;
initGroup(n, bd); /* initialise it */
return bd;
***************
*** 206,289 ****
/* coalesce the group p with its predecessor and successor groups, if possible
*
* Returns NULL if no coalescing was done, otherwise returns a
! * pointer to the newly enlarged group p.
*/
STATIC_INLINE bdescr *
! coalesce(bdescr *p)
{
! bdescr *first, *q, *result = NULL;
! /* Get first megablock descriptor */
! first = FIRST_BDESCR(MBLOCK_ROUND_DOWN(p->start));
! /* Attempt to coalesce with predecessor if not the first block */
! if (p != first) {
! q = p - 1;
! if (!q->blocks) { // not a block head?
! q = q->link; // find the head.
! }
! /* Predecessor is free? */
! if (q->flags & BF_FREE) {
! q->blocks += p->blocks;
! initGroupTail( p->blocks, q, p );
! p = result = q;
! }
}
! /* Attempt to coalesce with successor if not the last block */
! q = p + p->blocks;
! if (q != first + BLOCKS_PER_MBLOCK) {
! /* Successor is free */
! if (q->flags & BF_FREE) {
! if (result) {
! /* p is on free_list, q is on free_list, unlink
! * q completely and patch up list
! */
! if (q->u.back) {
! q->u.back->link = q->link;
! }
! if (q->link) {
! q->link->u.back = q->u.back;
! }
! if (free_list == q) {
! free_list = q->link;
! }
! } else {
! /* p is not on free_list just assume q's links */
! p->u.back = q->u.back;
! if (p->u.back) {
! p->u.back->link = p;
! }
! p->link = q->link;
! if (p->link) {
! p->link->u.back = p;
! }
! if (q == free_list) {
! free_list = p;
! free_list->u.back = NULL;
! }
! }
!
! p->blocks += q->blocks;
! initGroupTail( q->blocks, p, q );
! result = p;
! }
}
! return result;
}
void
freeGroup(bdescr *p)
{
/* are we dealing with a megablock group? */
if (p->blocks > BLOCKS_PER_MBLOCK) {
freeMegaGroup(p);
return;
}
! p->flags = BF_FREE;
p->u.back = NULL;
p->link = NULL;
p->step = NULL;
--- 210,307 ----
/* coalesce the group p with its predecessor and successor groups, if possible
*
* Returns NULL if no coalescing was done, otherwise returns a
! * pointer to the newly enlarged group p moved from free_list to
! * list if necessary.
*/
STATIC_INLINE bdescr *
! coalesce(bdescr *p, bdescr **list)
{
! bdescr *first, *q, *result = NULL;
! /* Get first megablock descriptor */
! first = FIRST_BDESCR(MBLOCK_ROUND_DOWN(p->start));
! /* Attempt to coalesce with predecessor if not the first block */
! if (p != first) {
! q = p - 1;
! if (!q->blocks) { // not a block head?
! q = q->link; // find the head.
}
+ /* Predecessor is free? */
+ if (q->flags & BF_FREE || q->flags & BF_FREEING) {
+ q->blocks += p->blocks;
+ p = q + (q->blocks - 1);
+ p->link = q;
+ p->flags = BF_FREEING;
+ p->blocks = 0;
+ if (q->flags & BF_FREE) {
+ q->flags = BF_FREEING;
+ dbl_unlink_from(q, &free_list);
+ dbl_link_onto(q, list);
+ }
+ p = result = q;
+ }
+ }
! /* Attempt to coalesce with successor if not the last block */
! q = p + p->blocks;
! if (q != first + BLOCKS_PER_MBLOCK) {
! /* Successor is free */
! if (q->flags & BF_FREE) {
! /* q is on free_list, unlink q */
! dbl_unlink_from(q, &free_list);
! if (!result) {
! dbl_link_onto(p, list);
! }
! p->blocks += q->blocks;
! q = p + (p->blocks - 1);
! q->flags = BF_FREEING;
! q->link = p;
! q->blocks = 0;
! result = p;
! } else if (q->flags & BF_FREEING) {
! if (result) {
! /* p is on list, q is on list, unlink q */
! dbl_unlink_from(q, list);
! } else {
! /* p is not on list just assume q's links */
! p->u.back = q->u.back;
! if (p->u.back) {
! p->u.back->link = p;
! }
! p->link = q->link;
! if (p->link) {
! p->link->u.back = p;
! }
! if (q == *list) {
! *list = p;
! (*list)->u.back = NULL;
! }
! }
! p->blocks += q->blocks;
! q = p + (p->blocks - 1);
! q->link = p;
! q->blocks = 0;
! result = p;
}
+ }
! return result;
}
void
freeGroup(bdescr *p)
{
+ bdescr *list = NULL;
+
/* are we dealing with a megablock group? */
if (p->blocks > BLOCKS_PER_MBLOCK) {
freeMegaGroup(p);
return;
}
! p->flags = BF_FREEING;
p->u.back = NULL;
p->link = NULL;
p->step = NULL;
***************
*** 291,298 ****
/* fill the block group with garbage if sanity checking is on */
IF_DEBUG(sanity,memset(p->start, 0xaa, p->blocks * BLOCK_SIZE));
! if (!coalesce(p)) {
dbl_link_onto(p, &free_list);
}
IF_DEBUG(sanity, checkFreeListSanity());
--- 309,355 ----
/* fill the block group with garbage if sanity checking is on */
IF_DEBUG(sanity,memset(p->start, 0xaa, p->blocks * BLOCK_SIZE));
! if (!coalesce(p, &list)) {
! p->flags = BF_FREE;
dbl_link_onto(p, &free_list);
+ p += p->blocks - 1;
+ p->flags = BF_FREE;
+ } else {
+ initTempFreeListGroup(list);
+ }
+
+ IF_DEBUG(sanity, checkFreeListSanity());
+ }
+
+ static void
+ tempFreeGroup(bdescr *p, bdescr **list)
+ {
+ /* are we dealing with a megablock group? */
+ if (p->blocks > BLOCKS_PER_MBLOCK) {
+ nat n;
+ void *q = p;
+
+ n = ((bdescr *)q)->blocks * BLOCK_SIZE / MBLOCK_SIZE + 1;
+ for (; n > 0; q += MBLOCK_SIZE, n--) {
+ initMBlock(MBLOCK_ROUND_DOWN(q));
+ initGroup(BLOCKS_PER_MBLOCK, (bdescr *)q);
+ tempFreeGroup((bdescr *)q, list);
+ }
+ return;
+ }
+
+ p->flags = BF_FREEING;
+ p->u.back = NULL;
+ p->link = NULL;
+ p->step = NULL;
+ p->gen_no = 0;
+ /* fill the block group with garbage if sanity checking is on */
+ IF_DEBUG(sanity,memset(p->start, 0xaa, p->blocks * BLOCK_SIZE));
+
+ if (!coalesce(p, list)) {
+ dbl_link_onto(p, list);
+ p += p->blocks - 1;
+ p->flags = BF_FREEING;
}
IF_DEBUG(sanity, checkFreeListSanity());
***************
*** 301,306 ****
--- 358,364 ----
static void
freeMegaGroup(bdescr *p)
{
+ bdescr *temp_free_list = NULL;
nat n;
void *q = p;
***************
*** 308,326 ****
for (; n > 0; q += MBLOCK_SIZE, n--) {
initMBlock(MBLOCK_ROUND_DOWN(q));
initGroup(BLOCKS_PER_MBLOCK, (bdescr *)q);
! freeGroup((bdescr *)q);
}
}
void
freeChain(bdescr *bd)
{
! bdescr *next_bd;
while (bd != NULL) {
next_bd = bd->link;
! freeGroup(bd);
bd = next_bd;
}
}
static void
--- 366,406 ----
for (; n > 0; q += MBLOCK_SIZE, n--) {
initMBlock(MBLOCK_ROUND_DOWN(q));
initGroup(BLOCKS_PER_MBLOCK, (bdescr *)q);
! tempFreeGroup((bdescr *)q, &temp_free_list);
}
+
+ initTempFreeListGroup(temp_free_list);
}
void
freeChain(bdescr *bd)
{
! bdescr *next_bd, *temp_free_list = NULL;
!
while (bd != NULL) {
next_bd = bd->link;
! tempFreeGroup(bd, &temp_free_list);
bd = next_bd;
}
+
+ initTempFreeListGroup(temp_free_list);
+ }
+
+ void
+ prepareToFreeChain(bdescr **list_head, bdescr **list_tail, bdescr *bd)
+ {
+ if (!*list_tail) {
+ *list_head = bd;
+ } else {
+ (*list_tail)->link = bd;
+ }
+
+ if (bd) {
+ do {
+ *list_tail = bd;
+ bd = bd->link;
+ } while (bd);
+ }
}
static void
***************
*** 342,347 ****
--- 422,449 ----
}
}
+ static void
+ initTempFreeListGroup(bdescr *list)
+ {
+ bdescr *bd, *tail_bd = NULL;
+ nat blocks;
+
+ for (bd = list; bd; bd = bd->link) {
+ blocks = bd->blocks - 1;
+ initGroupTail(blocks, bd, bd + 1);
+ bd->flags = BF_FREE;
+ tail_bd = bd + blocks;
+ tail_bd->flags = BF_FREE;
+ tail_bd = bd;
+ }
+
+ tail_bd->link = free_list;
+ if (free_list) {
+ free_list->u.back = tail_bd;
+ }
+ free_list = list;
+ }
+
/*
-----------------------------------------------------------------------------
Debugging
--------------------------------------------------------------------------
*/
***************
*** 350,362 ****
static void
checkWellFormedGroup(bdescr *bd)
{
! nat i;
! for (i = 1; i < bd->blocks; i++) {
! ASSERT(bd[i].blocks == 0);
! ASSERT(bd[i].free == 0);
! ASSERT(bd[i].link == bd);
! }
}
void
--- 452,464 ----
static void
checkWellFormedGroup(bdescr *bd)
{
! nat i;
! for (i = 1; i < bd->blocks; i++) {
! ASSERT(bd[i].blocks == 0);
! ASSERT(bd[i].free == 0);
! ASSERT(bd[i].link == bd);
! }
}
void
diff -r -rcs --exclude=CVS ../clean/fptools/ghc/rts/GC.c ghc/rts/GC.c
*** ../clean/fptools/ghc/rts/GC.c 2005-06-06 09:49:07.000000000 +0100
--- ghc/rts/GC.c 2005-06-30 10:47:08.000000000 +0100
***************
*** 300,306 ****
void
GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
{
! bdescr *bd;
step *stp;
lnat live, allocated, collected = 0, copied = 0;
lnat oldgen_saved_blocks = 0;
--- 300,306 ----
void
GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
{
! bdescr *bd, *free_bd_chain_hd = NULL, *free_bd_chain_tl = NULL;
step *stp;
lnat live, allocated, collected = 0, copied = 0;
lnat oldgen_saved_blocks = 0;
***************
*** 396,402 ****
// always has at least one block; this means we can avoid a check for
// NULL in recordMutable().
if (g != 0) {
! freeChain(generations[g].mut_list);
generations[g].mut_list = allocBlock();
}
--- 396,403 ----
// always has at least one block; this means we can avoid a check for
// NULL in recordMutable().
if (g != 0) {
! prepareToFreeChain(&free_bd_chain_hd,
! &free_bd_chain_tl, generations[g].mut_list);
generations[g].mut_list = allocBlock();
}
***************
*** 528,533 ****
--- 529,539 ----
for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
IF_PAR_DEBUG(verbose, printMutableList(&generations[g]));
scavenge_mutable_list(&generations[g]);
+ // free the old mut_list
+ prepareToFreeChain(&free_bd_chain_hd,
+ &free_bd_chain_tl,
+ generations[g].saved_mut_list);
+ generations[g].saved_mut_list = NULL;
evac_gen = g;
for (st = generations[g].n_steps-1; st >= 0; st--) {
scavenge(&generations[g].steps[st]);
***************
*** 777,783 ****
// add the new blocks to the block tally
stp->n_blocks += stp->n_to_blocks;
} else {
! freeChain(stp->blocks);
stp->blocks = stp->to_blocks;
stp->n_blocks = stp->n_to_blocks;
for (bd = stp->blocks; bd != NULL; bd = bd->link) {
--- 783,790 ----
// add the new blocks to the block tally
stp->n_blocks += stp->n_to_blocks;
} else {
! prepareToFreeChain(&free_bd_chain_hd,
! &free_bd_chain_tl, stp->blocks);
stp->blocks = stp->to_blocks;
stp->n_blocks = stp->n_to_blocks;
for (bd = stp->blocks; bd != NULL; bd = bd->link) {
***************
*** 793,803 ****
* collection from large_objects. Any objects left on
* large_objects list are therefore dead, so we free them here.
*/
! for (bd = stp->large_objects; bd != NULL; bd = next) {
! next = bd->link;
! freeGroup(bd);
! bd = next;
! }
// update the count of blocks used by large objects
for (bd = stp->scavenged_large_objects; bd != NULL; bd = bd->link) {
--- 800,807 ----
* collection from large_objects. Any objects left on
* large_objects list are therefore dead, so we free them here.
*/
! prepareToFreeChain(&free_bd_chain_hd,
! &free_bd_chain_tl, stp->large_objects);
// update the count of blocks used by large objects
for (bd = stp->scavenged_large_objects; bd != NULL; bd = bd->link) {
***************
*** 910,918 ****
* all have been copied into G0S1 now.
*/
if (small_alloc_list != NULL) {
! freeChain(small_alloc_list);
}
- small_alloc_list = NULL;
alloc_blocks = 0;
alloc_Hp = NULL;
alloc_HpLim = NULL;
--- 914,923 ----
* all have been copied into G0S1 now.
*/
if (small_alloc_list != NULL) {
! prepareToFreeChain(&free_bd_chain_hd,
! &free_bd_chain_tl, small_alloc_list);
! small_alloc_list = NULL;
}
alloc_blocks = 0;
alloc_Hp = NULL;
alloc_HpLim = NULL;
***************
*** 924,930 ****
/* Free the mark stack.
*/
if (mark_stack_bdescr != NULL) {
! freeGroup(mark_stack_bdescr);
}
/* Free any bitmaps.
--- 929,936 ----
/* Free the mark stack.
*/
if (mark_stack_bdescr != NULL) {
! prepareToFreeChain(&free_bd_chain_hd,
! &free_bd_chain_tl, mark_stack_bdescr);
}
/* Free any bitmaps.
***************
*** 933,939 ****
for (s = 0; s < generations[g].n_steps; s++) {
stp = &generations[g].steps[s];
if (stp->is_compacted && stp->bitmap != NULL) {
! freeGroup(stp->bitmap);
}
}
}
--- 939,946 ----
for (s = 0; s < generations[g].n_steps; s++) {
stp = &generations[g].steps[s];
if (stp->is_compacted && stp->bitmap != NULL) {
! prepareToFreeChain(&free_bd_chain_hd,
! &free_bd_chain_tl, stp->bitmap);
}
}
}
***************
*** 945,956 ****
nat blocks;
if (old_to_blocks != NULL) {
! freeChain(old_to_blocks);
}
for (bd = g0s0->to_blocks; bd != NULL; bd = bd->link) {
bd->flags = 0; // now from-space
}
/* For a two-space collector, we need to resize the nursery. */
/* set up a new nursery. Allocate a nursery size based on a
--- 952,967 ----
nat blocks;
if (old_to_blocks != NULL) {
! prepareToFreeChain(&free_bd_chain_hd,
! &free_bd_chain_tl, old_to_blocks);
}
for (bd = g0s0->to_blocks; bd != NULL; bd = bd->link) {
bd->flags = 0; // now from-space
}
+ /* Free all the blocks collected during the collection cycle */
+ freeChain(free_bd_chain_hd);
+
/* For a two-space collector, we need to resize the nursery. */
/* set up a new nursery. Allocate a nursery size based on a
***************
*** 997,1002 ****
--- 1008,1016 ----
* allocation area to make best use of the memory available.
*/
+ /* Free all the blocks collected during the collection cycle */
+ freeChain(free_bd_chain_hd);
+
if (RtsFlags.GcFlags.heapSizeSuggestion) {
long blocks;
nat needed = calcNeeded(); // approx blocks needed at next GC
***************
*** 3653,3662 ****
}
}
}
-
- // free the old mut_list
- freeChain(gen->saved_mut_list);
- gen->saved_mut_list = NULL;
}
--- 3667,3672 ----
diff -r -rcs --exclude=CVS ../clean/fptools/ghc/rts/Storage.c ghc/rts/Storage.c
*** ../clean/fptools/ghc/rts/Storage.c 2005-05-12 12:36:50.000000000 +0100
--- ghc/rts/Storage.c 2005-06-28 12:05:32.000000000 +0100
***************
*** 480,498 ****
stp->blocks = allocNursery(stp, stp->blocks, blocks-nursery_blocks);
}
else {
! bdescr *next_bd;
IF_DEBUG(gc, debugBelch("Decreasing size of nursery to %d blocks\n",
blocks));
bd = stp->blocks;
while (nursery_blocks > blocks) {
next_bd = bd->link;
next_bd->u.back = NULL;
nursery_blocks -= bd->blocks; // might be a large block
! freeGroup(bd);
bd = next_bd;
}
stp->blocks = bd;
// might have gone just under, by freeing a large block, so make
// up the difference.
--- 480,501 ----
stp->blocks = allocNursery(stp, stp->blocks, blocks-nursery_blocks);
}
else {
! bdescr *next_bd, *free_bd_chain = NULL;
IF_DEBUG(gc, debugBelch("Decreasing size of nursery to %d blocks\n",
blocks));
bd = stp->blocks;
+
while (nursery_blocks > blocks) {
next_bd = bd->link;
next_bd->u.back = NULL;
nursery_blocks -= bd->blocks; // might be a large block
! bd->link = free_bd_chain;
! free_bd_chain = bd;
bd = next_bd;
}
+ freeChain(free_bd_chain);
stp->blocks = bd;
// might have gone just under, by freeing a large block, so make
// up the difference.
_______________________________________________
Cvs-ghc mailing list
[EMAIL PROTECTED]
http://www.haskell.org/mailman/listinfo/cvs-ghc
