Rework the block allocator

The main goal here is to reduce fragmentation, which turns out to be
the case of #743.  While I was here I found some opportunities to
improve performance too.  The code is rather more complex, but it also
contains a long comment describing the strategy, so please take a look
at that for the details.

diff --git a/includes/Block.h b/includes/Block.h
index 4080880..dd3e201 100644 (file)
--- a/includes/Block.h
+++ b/includes/Block.h
@@ -130,6 +130,11 @@ INLINE_HEADER bdescr *Bdescr(StgPtr p)
 #define FIRST_BDESCR(m) \
    ((bdescr *)((FIRST_BLOCK_OFF>>(BLOCK_SHIFT-BDESCR_SHIFT)) + (W_)(m)))
 
 #define FIRST_BDESCR(m) \
    ((bdescr *)((FIRST_BLOCK_OFF>>(BLOCK_SHIFT-BDESCR_SHIFT)) + (W_)(m)))
 

+/* Last real block descriptor in a megablock */
+
+#define LAST_BDESCR(m) \
+  ((bdescr *)(((MBLOCK_SIZE-BLOCK_SIZE)>>(BLOCK_SHIFT-BDESCR_SHIFT)) + (W_)(m)))
+

 /* Number of usable blocks in a megablock */
 
 #define BLOCKS_PER_MBLOCK ((MBLOCK_SIZE - FIRST_BLOCK_OFF) / BLOCK_SIZE)
 /* Number of usable blocks in a megablock */
 
 #define BLOCKS_PER_MBLOCK ((MBLOCK_SIZE - FIRST_BLOCK_OFF) / BLOCK_SIZE)

@@ -161,6 +166,45 @@ dbl_link_onto(bdescr *bd, bdescr **list)
   *list = bd;
 }
 
   *list = bd;
 }
 

+INLINE_HEADER void
+dbl_link_remove(bdescr *bd, bdescr **list)
+{
+    if (bd->u.back) {
+        bd->u.back->link = bd->link;
+    } else {
+        *list = bd->link;
+    }
+    if (bd->link) {
+        bd->link->u.back = bd->u.back;
+    }
+}
+
+INLINE_HEADER void
+dbl_link_insert_after(bdescr *bd, bdescr *after)
+{
+    bd->link = after->link;
+    bd->u.back = after;
+    if (after->link) {
+        after->link->u.back = bd;
+    }
+    after->link = bd;
+}
+
+INLINE_HEADER void
+dbl_link_replace(bdescr *new, bdescr *old, bdescr **list)
+{
+    new->link = old->link;
+    new->u.back = old->u.back;
+    if (old->link) {
+        old->link->u.back = new;
+    }
+    if (old->u.back) {
+        old->u.back->link = new;
+    } else {
+        *list = new;
+    }
+}
+

 /* Initialisation ---------------------------------------------------------- */
 
 extern void initBlockAllocator(void);
 /* Initialisation ---------------------------------------------------------- */
 
 extern void initBlockAllocator(void);

diff --git a/rts/sm/BlockAlloc.c b/rts/sm/BlockAlloc.c
index 763f2e7..1c4899e 100644 (file)
--- a/rts/sm/BlockAlloc.c
+++ b/rts/sm/BlockAlloc.c
@@ -7,11 +7,11 @@
  * This is the architecture independent part of the block allocator.
  * It requires only the following support from the operating system: 
  *
  * This is the architecture independent part of the block allocator.
  * It requires only the following support from the operating system: 
  *

- *    void *getMBlock();
+ *    void *getMBlock(nat n);

  *
  *

- * returns the address of an MBLOCK_SIZE region of memory, aligned on
- * an MBLOCK_SIZE boundary.  There is no requirement for successive
- * calls to getMBlock to return strictly increasing addresses.
+ * returns the address of an n*MBLOCK_SIZE region of memory, aligned on
+ * an MBLOCK_SIZE boundary.  There are no other restrictions on the
+ * addresses of memory returned by getMBlock().

  *
  * ---------------------------------------------------------------------------*/
 
  *
  * ---------------------------------------------------------------------------*/
 

@@ -25,12 +25,99 @@
 
 #include <string.h>
 
 
 #include <string.h>
 

-static void    initMBlock(void *mblock);
-static bdescr *allocMegaGroup(nat mblocks);
-static void    freeMegaGroup(bdescr *bd);
+static void  initMBlock(void *mblock);

 
 

+// The free_list is kept sorted by size, smallest first.

 // In THREADED_RTS mode, the free list is protected by sm_mutex.
 // In THREADED_RTS mode, the free list is protected by sm_mutex.

-static bdescr *free_list = NULL;
+
+/* -----------------------------------------------------------------------------
+
+  Implementation notes
+  ~~~~~~~~~~~~~~~~~~~~
+
+  Terminology:
+    - bdescr = block descriptor
+    - bgroup = block group (1 or more adjacent blocks)
+    - mblock = mega block
+    - mgroup = mega group (1 or more adjacent mblocks)
+
+   Invariants on block descriptors
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+   bd->start always points to the start of the block.
+
+   bd->free is either:
+      - zero for a non-group-head; bd->link points to the head
+      - (-1) for the head of a free block group
+      - or it points within the block
+
+   bd->blocks is either:
+      - zero for a non-group-head; bd->link points to the head
+      - number of blocks in this group otherwise
+
+   bd->link either points to a block descriptor or is NULL
+
+   The following fields are not used by the allocator:
+     bd->flags
+     bd->gen_no
+     bd->step
+
+  Exceptions: we don't maintain invariants for all the blocks within a
+  group on the free list, because it is expensive to modify every
+  bdescr in a group when coalescing.  Just the head and last bdescrs
+  will be correct for a group on the free list.
+
+
+  Free lists
+  ~~~~~~~~~~
+  Preliminaries:
+    - most allocations are for single blocks
+    - we cannot be dependent on address-space ordering; sometimes the
+      OS gives us new memory backwards in the address space, sometimes
+      forwards
+    - We want to avoid fragmentation in the free list
+    
+  Coalescing trick: when a bgroup is freed (freeGroup()), we can check
+  whether it can be coalesced with othre free bgroups by checking the
+  bdescrs for the blocks on either side of it.  This means that:
+
+    - freeGroup is O(1) if we coalesce with an existing free block
+      group.  Otherwise we have to insert in the free list, but since
+      most blocks are small and the free list is sorted by size, this
+      is usually quick.
+    - the free list must be double-linked, so we can insert into the
+      middle.
+    - every free group in the free list must have its head and tail
+      bdescrs initialised, the rest don't matter.
+    - we cannot play this trick with mblocks, because there is no
+      requirement that the bdescrs in the second and subsequent mblock
+      of an mgroup are initialised (the mgroup might be filled with a
+      large array, overwriting the bdescrs for example).
+
+  So there are two free lists:
+
+    - free_list contains bgroups smaller than an mblock.
+       - it is doubly-linked
+       - sorted in *size* order: allocation is best-fit
+       - free bgroups are always fully coalesced
+       - we do the coalescing trick in freeGroup()
+
+    - free_mblock_list contains mgroups only
+       - it is singly-linked (no need to double-link)
+       - sorted in *address* order, so we can coalesce using the list
+       - allocation is best-fit by traversing the whole list: we don't
+         expect this list to be long, avoiding fragmentation is more
+         important. 
+
+  freeGroup() might end up moving a block from free_list to
+  free_mblock_list, if after coalescing we end up with a full mblock.
+
+  checkFreeListSanity() checks all the invariants on the free lists.
+
+  --------------------------------------------------------------------------- */
+
+static bdescr *free_list;
+static bdescr *free_mblock_list;
+

 
 /* -----------------------------------------------------------------------------
    Initialisation
 
 /* -----------------------------------------------------------------------------
    Initialisation

@@ -38,7 +125,8 @@ static bdescr *free_list = NULL;
 
 void initBlockAllocator(void)
 {
 
 void initBlockAllocator(void)
 {

-    // The free list starts off NULL
+    free_list = NULL;
+    free_mblock_list = NULL;

 }
 
 /* -----------------------------------------------------------------------------
 }
 
 /* -----------------------------------------------------------------------------

@@ -52,7 +140,6 @@ initGroup(nat n, bdescr *head)
   nat i;
 
   if (n != 0) {
   nat i;
 
   if (n != 0) {

-    head->blocks = n;

     head->free   = head->start;
     head->link   = NULL;
     for (i=1, bd = head+1; i < n; i++, bd++) {
     head->free   = head->start;
     head->link   = NULL;
     for (i=1, bd = head+1; i < n; i++, bd++) {

@@ -63,44 +150,207 @@ initGroup(nat n, bdescr *head)
   }
 }
 
   }
 }
 

-bdescr *
-allocGroup(nat n)
+// when a block has been shortened by allocGroup(), we need to push
+// the remaining chunk backwards in the free list in order to keep the
+// list sorted by size.
+static void
+free_list_push_backwards (bdescr *bd)

 {
 {

-  void *mblock;
-  bdescr *bd, **last;
+    bdescr *p;

 
 

-  ASSERT_SM_LOCK();
-  ASSERT(n != 0);
+    p = bd->u.back;
+    while (p != NULL && p->blocks > bd->blocks) {
+        p = p->u.back;
+    }
+    if (p != bd->u.back) {
+        dbl_link_remove(bd, &free_list);
+        if (p != NULL)
+            dbl_link_insert_after(bd, p);
+        else
+            dbl_link_onto(bd, &free_list);
+    }
+}

 
 

-  if (n > BLOCKS_PER_MBLOCK) {
-    return allocMegaGroup(BLOCKS_TO_MBLOCKS(n));
-  }
+// when a block has been coalesced by freeGroup(), we need to push the
+// remaining chunk forwards in the free list in order to keep the list
+// sorted by size.
+static void
+free_list_push_forwards (bdescr *bd)
+{
+    bdescr *p;

 
 

-  last = &free_list;
-  for (bd = free_list; bd != NULL; bd = bd->link) {
-    if (bd->blocks == n) {     /* exactly the right size! */
-      *last = bd->link;
-      initGroup(n, bd);                /* initialise it */
-      return bd;
+    p = bd;
+    while (p->link != NULL && p->link->blocks < bd->blocks) {
+        p = p->link;

     }
     }

-    if (bd->blocks >  n) {     /* block too big... */
-      bd->blocks -= n;         /* take a chunk off the *end* */
-      bd += bd->blocks;
-      initGroup(n, bd);                /* initialise it */
-      return bd;
+    if (p != bd) {
+        dbl_link_remove(bd, &free_list);
+        dbl_link_insert_after(bd, p);

     }
     }

-    last = &bd->link;
-  }
-  
-  mblock = getMBlock();                /* get a new megablock */
-  initMBlock(mblock);          /* initialise the start fields */
-  bd = FIRST_BDESCR(mblock);
-  initGroup(n,bd);             /* we know the group will fit */
-  if (n < BLOCKS_PER_MBLOCK) {
-    initGroup(BLOCKS_PER_MBLOCK-n, bd+n);
-    freeGroup(bd+n);           /* add the rest on to the free list */
-  }
-  return bd;
+}
+
+static void
+free_list_insert (bdescr *bd)
+{
+    bdescr *p, *prev;
+
+    if (!free_list) {
+        dbl_link_onto(bd, &free_list);
+        return;
+    }
+
+    prev = NULL;
+    p = free_list;
+    while (p != NULL && p->blocks < bd->blocks) {
+        prev = p;
+        p = p->link;
+    }
+    if (prev == NULL)
+    {
+        dbl_link_onto(bd, &free_list);
+    }
+    else 
+    {
+        dbl_link_insert_after(bd, prev);
+    }
+}
+
+
+STATIC_INLINE bdescr *
+tail_of (bdescr *bd)
+{
+    return bd + bd->blocks - 1;
+}
+
+// After splitting a group, the last block of each group must have a
+// tail that points to the head block, to keep our invariants for
+// coalescing. 
+STATIC_INLINE void
+setup_tail (bdescr *bd)
+{
+    bdescr *tail;
+    tail = tail_of(bd);
+    if (tail != bd) {
+        tail->blocks = 0;
+        tail->free = 0;
+        tail->link = bd;
+    }
+}
+
+
+// Take a free block group bd, and split off a group of size n from
+// it.  Adjust the free list as necessary, and return the new group.
+static bdescr *
+split_free_block (bdescr *bd, nat n)
+{
+    bdescr *fg; // free group
+
+    ASSERT(bd->blocks > n);
+    fg = bd + bd->blocks - n; // take n blocks off the end
+    fg->blocks = n;
+    bd->blocks -= n;
+    setup_tail(bd);
+    free_list_push_backwards(bd);
+    return fg;
+}
+
+static bdescr *
+alloc_mega_group (nat mblocks)
+{
+    bdescr *best, *bd, *prev;
+    nat n;
+
+    n = MBLOCK_GROUP_BLOCKS(mblocks);
+
+    best = NULL;
+    prev = NULL;
+    for (bd = free_mblock_list; bd != NULL; prev = bd, bd = bd->link)
+    {
+        if (bd->blocks == n) 
+        {
+            if (prev) {
+                prev->link = bd->link;
+            } else {
+                free_mblock_list = bd->link;
+            }
+            initGroup(n, bd);
+            return bd;
+        }
+        else if (bd->blocks > n)
+        {
+            if (!best || bd->blocks < best->blocks)
+            {
+                best = bd;
+            }
+        }
+    }
+
+    if (best)
+    {
+        // we take our chunk off the end here.
+        nat best_mblocks  = BLOCKS_TO_MBLOCKS(best->blocks);
+        bd = FIRST_BDESCR(MBLOCK_ROUND_DOWN(best) + 
+                          (best_mblocks-mblocks)*MBLOCK_SIZE);
+
+        best->blocks = MBLOCK_GROUP_BLOCKS(best_mblocks - mblocks);
+        initMBlock(MBLOCK_ROUND_DOWN(bd));
+    }
+    else
+    {
+        void *mblock = getMBlocks(mblocks);
+        initMBlock(mblock);            // only need to init the 1st one
+        bd = FIRST_BDESCR(mblock);
+    }
+    bd->blocks = MBLOCK_GROUP_BLOCKS(mblocks);
+    return bd;
+}
+
+bdescr *
+allocGroup (nat n)
+{
+    bdescr *bd, *rem;
+
+    ASSERT_SM_LOCK();
+
+    if (n == 0) barf("allocGroup: requested zero blocks");
+    
+    if (n >= BLOCKS_PER_MBLOCK)
+    {
+        bd = alloc_mega_group(BLOCKS_TO_MBLOCKS(n));
+        // only the bdescrs of the first MB are required to be initialised
+        initGroup(BLOCKS_PER_MBLOCK, bd);
+        IF_DEBUG(sanity, checkFreeListSanity());
+        return bd;
+    }
+    
+    // The free list is sorted by size, so we get best fit.
+    for (bd = free_list; bd != NULL; bd = bd->link)
+    {
+        if (bd->blocks == n)           // exactly the right size!
+        {
+            dbl_link_remove(bd, &free_list);
+            initGroup(n, bd);          // initialise it
+            IF_DEBUG(sanity, checkFreeListSanity());
+            return bd;
+        }
+        if (bd->blocks >  n)            // block too big...
+        {                              
+            bd = split_free_block(bd, n);
+            initGroup(n, bd);          // initialise the new chunk
+            IF_DEBUG(sanity, checkFreeListSanity());
+            return bd;
+        }
+    }
+
+    bd = alloc_mega_group(1);
+    bd->blocks = n;
+    initGroup(n,bd);                    // we know the group will fit
+    rem = bd + n;
+    rem->blocks = BLOCKS_PER_MBLOCK-n;
+    initGroup(BLOCKS_PER_MBLOCK-n, rem); // init the slop
+    freeGroup(rem);                     // add the slop on to the free list
+    IF_DEBUG(sanity, checkFreeListSanity());
+    return bd;

 }
 
 bdescr *
 }
 
 bdescr *

@@ -116,7 +366,7 @@ allocGroup_lock(nat n)
 bdescr *
 allocBlock(void)
 {
 bdescr *
 allocBlock(void)
 {

-  return allocGroup(1);
+    return allocGroup(1);

 }
 
 bdescr *
 }
 
 bdescr *

@@ -130,132 +380,68 @@ allocBlock_lock(void)
 }
 
 /* -----------------------------------------------------------------------------
 }
 
 /* -----------------------------------------------------------------------------

-   Any request larger than BLOCKS_PER_MBLOCK needs a megablock group.
-   First, search the free list for enough contiguous megablocks to
-   fulfill the request - if we don't have enough, we need to
-   allocate some new ones.
-
-   A megablock group looks just like a normal block group, except that
-   the blocks field in the head will be larger than BLOCKS_PER_MBLOCK.
-
-   Note that any objects placed in this group must start in the first
-   megablock, since the other blocks don't have block descriptors.
+   De-Allocation

    -------------------------------------------------------------------------- */
    -------------------------------------------------------------------------- */

-   
-static bdescr *
-allocMegaGroup(nat n)
-{
-  nat mbs_found;
-  bdescr *bd, *last, *grp_start, *grp_prev;
-
-  mbs_found = 0;
-  grp_start = NULL;
-  grp_prev  = NULL;
-  last      = NULL;
-  for (bd = free_list; bd != NULL; bd = bd->link) {
-
-    if (bd->blocks == BLOCKS_PER_MBLOCK) {     /* whole megablock found */
-
-      /* is it the first one we've found or a non-contiguous megablock? */
-      if (grp_start == NULL ||
-          bd->start != last->start + MBLOCK_SIZE/sizeof(W_)) {
-       grp_start = bd;
-       grp_prev  = last;
-       mbs_found = 1;
-      } else {
-       mbs_found++;
-      }
-
-      if (mbs_found == n) {    /* found enough contig megablocks? */
-       break;
-      }
-    } 
-
-    else {                     /* only a partial megablock, start again */
-      grp_start = NULL;
-    }
-
-    last = bd;
-  }

 
 

-  /* found all the megablocks we need on the free list
-   */
-  if (mbs_found == n) {
-    /* remove the megablocks from the free list */
-    if (grp_prev == NULL) {    /* bd now points to the last mblock */
-      free_list = bd->link;
-    } else {
-      grp_prev->link = bd->link;
+STATIC_INLINE bdescr *
+coalesce_mblocks (bdescr *p)
+{
+    bdescr *q;
+
+    q = p->link;
+    if (q != NULL && 
+        MBLOCK_ROUND_DOWN(q) == 
+        MBLOCK_ROUND_DOWN(p) + BLOCKS_TO_MBLOCKS(p->blocks) * MBLOCK_SIZE) {
+        // can coalesce
+        p->blocks  = MBLOCK_GROUP_BLOCKS(BLOCKS_TO_MBLOCKS(p->blocks) +
+                                         BLOCKS_TO_MBLOCKS(q->blocks));
+        p->link = q->link;
+        return p;

     }
     }

-  }
-
-  /* the free list wasn't sufficient, allocate all new mblocks.
-   */
-  else {
-    void *mblock = getMBlocks(n);
-    initMBlock(mblock);                /* only need to init the 1st one */
-    grp_start = FIRST_BDESCR(mblock);
-  }
-
-  /* set up the megablock group */
-  initGroup(BLOCKS_PER_MBLOCK, grp_start);
-  grp_start->blocks = MBLOCK_GROUP_BLOCKS(n);
-  return grp_start;
+    return q;

 }
 
 }
 

-/* -----------------------------------------------------------------------------
-   De-Allocation
-   -------------------------------------------------------------------------- */
-
-/* coalesce the group p with p->link if possible.
- *
- * Returns p->link if no coalescing was done, otherwise returns a
- * pointer to the newly enlarged group p.
- */
-
-STATIC_INLINE bdescr *
-coalesce(bdescr *p)
+static void
+free_mega_group (bdescr *mg)

 {
 {

-  bdescr *q;
+    bdescr *bd, *prev;
+
+    // Find the right place in the free list.  free_mblock_list is
+    // sorted by *address*, not by size as the free_list is.
+    prev = NULL;
+    bd = free_mblock_list;
+    while (bd && bd->start < mg->start) {
+        prev = bd;
+        bd = bd->link;
+    }

 
 

-  q = p->link;
-  if (q != NULL && p->start + p->blocks * BLOCK_SIZE_W == q->start) {
-    /* can coalesce */
-    p->blocks += q->blocks;
-    p->link    = q->link;
-#ifdef DEBUG
+    // coalesce backwards
+    if (prev)

     {
     {

-       nat i, blocks;
-       bdescr *bd;
-       blocks = q->blocks;
-       // not strictly necessary to do this, but helpful if we have a 
-       // random ptr and want to figure out what block it belongs to.
-       // Also required for sanity checking (see checkFreeListSanity()).
-       for (i = 0, bd = q; i < blocks; bd++, i++) {
-           bd->free = 0;
-           bd->blocks = 0;
-           bd->link = p;
-       }
+        mg->link = prev->link;
+        prev->link = mg;
+        mg = coalesce_mblocks(prev);

     }
     }

-#endif
-    return p;
-  }
-  return q;
-}
+    else
+    {
+        mg->link = free_mblock_list;
+        free_mblock_list = mg;
+    }
+    // coalesce forwards
+    coalesce_mblocks(mg);
+
+    IF_DEBUG(sanity, checkFreeListSanity());
+}    
+

 
 void
 freeGroup(bdescr *p)
 {
 
 void
 freeGroup(bdescr *p)
 {

-  bdescr *bd, *last;
-  
-  ASSERT_SM_LOCK();
+  nat p_on_free_list = 0;

 
 

-  /* are we dealing with a megablock group? */
-  if (p->blocks > BLOCKS_PER_MBLOCK) {
-    freeMegaGroup(p);
-    return;
-  }
+  ASSERT_SM_LOCK();

 
 

+  ASSERT(p->free != (P_)-1);

 
   p->free = (void *)-1;  /* indicates that this block is free */
   p->step = NULL;
 
   p->free = (void *)-1;  /* indicates that this block is free */
   p->step = NULL;

@@ -263,26 +449,74 @@ freeGroup(bdescr *p)
   /* fill the block group with garbage if sanity checking is on */
   IF_DEBUG(sanity,memset(p->start, 0xaa, p->blocks * BLOCK_SIZE));
 
   /* fill the block group with garbage if sanity checking is on */
   IF_DEBUG(sanity,memset(p->start, 0xaa, p->blocks * BLOCK_SIZE));
 

-  /* find correct place in free list to place new group */
-  last = NULL;
-  for (bd = free_list; bd != NULL && bd->start < p->start; 
-       bd = bd->link) {
-    last = bd;
+  if (p->blocks == 0) barf("freeGroup: block size is zero");
+
+  if (p->blocks >= BLOCKS_PER_MBLOCK)
+  {
+      // If this is an mgroup, make sure it has the right number of blocks
+      ASSERT(p->blocks == MBLOCK_GROUP_BLOCKS(BLOCKS_TO_MBLOCKS(p->blocks)));
+      free_mega_group(p);
+      return;

   }
 
   }
 

-  /* now, last = previous group (or NULL) */
-  if (last == NULL) {
-    p->link = free_list;
-    free_list = p;
-  } else {
-    /* coalesce with previous group if possible */
-    p->link = last->link;
-    last->link = p;
-    p = coalesce(last);
+  // coalesce forwards
+  {
+      bdescr *next;
+      next = p + p->blocks;
+      if (next <= LAST_BDESCR(MBLOCK_ROUND_DOWN(p)) && next->free == (P_)-1)
+      {
+          p->blocks += next->blocks;
+          if (p->blocks == BLOCKS_PER_MBLOCK)
+          {
+              dbl_link_remove(next, &free_list);
+              free_mega_group(p);
+              return;
+          }
+          dbl_link_replace(p, next, &free_list);
+          setup_tail(p);
+          free_list_push_forwards(p);
+          p_on_free_list = 1;
+      }
+  }
+
+  // coalesce backwards
+  if (p != FIRST_BDESCR(MBLOCK_ROUND_DOWN(p)))
+  {
+      bdescr *prev;
+      prev = p - 1;
+      if (prev->blocks == 0) prev = prev->link; // find the head
+
+      if (prev->free == (P_)-1)
+      {
+          prev->blocks += p->blocks;
+          if (prev->blocks >= BLOCKS_PER_MBLOCK)
+          {
+              if (p_on_free_list)
+              {
+                  dbl_link_remove(p, &free_list);
+              }
+              dbl_link_remove(prev, &free_list);
+              free_mega_group(prev);
+              return;
+          }
+          else if (p_on_free_list)
+          {
+              // p was already coalesced forwards
+              dbl_link_remove(p, &free_list);
+          }
+          setup_tail(prev);
+          free_list_push_forwards(prev);
+          p = prev;
+          p_on_free_list = 1;
+      }
+  }
+      
+  if (!p_on_free_list)
+  {
+      setup_tail(p);
+      free_list_insert(p);

   }
 
   }
 

-  /* coalesce with next group if possible */
-  coalesce(p);

   IF_DEBUG(sanity, checkFreeListSanity());
 }
 
   IF_DEBUG(sanity, checkFreeListSanity());
 }
 

@@ -294,20 +528,6 @@ freeGroup_lock(bdescr *p)
     RELEASE_SM_LOCK;
 }
 
     RELEASE_SM_LOCK;
 }
 

-static void
-freeMegaGroup(bdescr *p)
-{
-  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);
-    freeGroup((bdescr *)q);
-  }
-}
-

 void
 freeChain(bdescr *bd)
 {
 void
 freeChain(bdescr *bd)
 {

@@ -352,34 +572,84 @@ initMBlock(void *mblock)
 
 #ifdef DEBUG
 static void
 
 #ifdef DEBUG
 static void

-checkWellFormedGroup( bdescr *bd )
+check_tail (bdescr *bd)

 {
 {

-    nat i;
+    bdescr *tail = tail_of(bd);

 
 

-    for (i = 1; i < bd->blocks; i++) {
-       ASSERT(bd[i].blocks == 0);
-       ASSERT(bd[i].free   == 0);
-       ASSERT(bd[i].link   == bd);
+    if (tail != bd)
+    {
+        ASSERT(tail->blocks == 0);
+        ASSERT(tail->free == 0);
+        ASSERT(tail->link == bd);

     }
 }
 
 void
 checkFreeListSanity(void)
 {
     }
 }
 
 void
 checkFreeListSanity(void)
 {

-  bdescr *bd;
+    bdescr *bd, *prev;

 
 

-  for (bd = free_list; bd != NULL; bd = bd->link) {
-    IF_DEBUG(block_alloc,
-            debugBelch("group at 0x%p, length %ld blocks\n", 
-                       bd->start, (long)bd->blocks));
-    ASSERT(bd->blocks > 0);
-    checkWellFormedGroup(bd);
-    if (bd->link != NULL) {
-      /* make sure we're fully coalesced */
-      ASSERT(bd->start + bd->blocks * BLOCK_SIZE_W != bd->link->start);
-      ASSERT(bd->start < bd->link->start);
+    IF_DEBUG(block_alloc, debugBelch("free block list:\n"));
+
+    prev = NULL;
+    for (bd = free_list; bd != NULL; prev = bd, bd = bd->link)
+    {
+        IF_DEBUG(block_alloc,
+                 debugBelch("group at %p, length %ld blocks\n", 
+                            bd->start, (long)bd->blocks));
+        ASSERT(bd->blocks > 0 && bd->blocks < BLOCKS_PER_MBLOCK);
+        ASSERT(bd->link != bd); // catch easy loops
+
+        check_tail(bd);
+
+        if (prev)
+            ASSERT(bd->u.back == prev);
+        else 
+            ASSERT(bd->u.back == NULL);
+
+        if (bd->link != NULL)
+        {
+            // make sure the list is sorted
+            ASSERT(bd->blocks <= bd->link->blocks);
+        }
+
+        {
+            bdescr *next;
+            next = bd + bd->blocks;
+            if (next <= LAST_BDESCR(MBLOCK_ROUND_DOWN(bd)))
+            {
+                ASSERT(next->free != (P_)-1);
+            }
+        }
+    }
+
+    prev = NULL;
+    for (bd = free_mblock_list; bd != NULL; prev = bd, bd = bd->link)
+    {
+        IF_DEBUG(block_alloc,
+                 debugBelch("mega group at %p, length %ld blocks\n", 
+                            bd->start, (long)bd->blocks));
+
+        ASSERT(bd->link != bd); // catch easy loops
+
+        if (bd->link != NULL)
+        {
+            // make sure the list is sorted
+            ASSERT(bd->start < bd->link->start);
+        }
+
+        ASSERT(bd->blocks >= BLOCKS_PER_MBLOCK);
+        ASSERT(MBLOCK_GROUP_BLOCKS(BLOCKS_TO_MBLOCKS(bd->blocks))
+               == bd->blocks);
+
+        // make sure we're fully coalesced
+        if (bd->link != NULL)
+        {
+            ASSERT (MBLOCK_ROUND_DOWN(bd->link) != 
+                    MBLOCK_ROUND_DOWN(bd) + 
+                    BLOCKS_TO_MBLOCKS(bd->blocks) * MBLOCK_SIZE);
+        }

     }
     }

-  }

 }
 
 nat /* BLOCKS */
 }
 
 nat /* BLOCKS */

@@ -389,7 +659,14 @@ countFreeList(void)
   lnat total_blocks = 0;
 
   for (bd = free_list; bd != NULL; bd = bd->link) {
   lnat total_blocks = 0;
 
   for (bd = free_list; bd != NULL; bd = bd->link) {

-    total_blocks += bd->blocks;
+      total_blocks += bd->blocks;
+  }
+  for (bd = free_mblock_list; bd != NULL; bd = bd->link) {
+      total_blocks += BLOCKS_PER_MBLOCK * BLOCKS_TO_MBLOCKS(bd->blocks);
+      // The caller of this function, memInventory(), expects to match
+      // the total number of blocks in the system against mblocks *
+      // BLOCKS_PER_MBLOCK, so we must subtract the space for the
+      // block descriptors from *every* mblock.

   }
   return total_blocks;
 }
   }
   return total_blocks;
 }

diff --git a/rts/sm/Storage.c b/rts/sm/Storage.c
index fba30bb..1d08a85 100644 (file)
--- a/rts/sm/Storage.c
+++ b/rts/sm/Storage.c
@@ -1049,14 +1049,7 @@ void freeExec (void *addr)
     // the head of the queue.
     if (bd->gen_no == 0 && bd != exec_block) {
        debugTrace(DEBUG_gc, "free exec block %p", bd->start);
     // the head of the queue.
     if (bd->gen_no == 0 && bd != exec_block) {
        debugTrace(DEBUG_gc, "free exec block %p", bd->start);

-       if (bd->u.back) {
-           bd->u.back->link = bd->link;
-       } else {
-           exec_block = bd->link;
-       }
-       if (bd->link) {
-           bd->link->u.back = bd->u.back;
-       }
+        dbl_link_remove(bd, &exec_block);

        setExecutable(bd->start, bd->blocks * BLOCK_SIZE, rtsFalse);
        freeGroup(bd);
     }
        setExecutable(bd->start, bd->blocks * BLOCK_SIZE, rtsFalse);
        freeGroup(bd);
     }