rts/sm/BlockAlloc.c

   1 /* -----------------------------------------------------------------------------
   2  *
   3  * (c) The GHC Team 1998-2008
   4  *
   5  * The block allocator and free list manager.
   6  *
   7  * This is the architecture independent part of the block allocator.
   8  * It requires only the following support from the operating system:
   9  *
  10  *    void *getMBlock(nat n);
  11  *
  12  * returns the address of an n*MBLOCK_SIZE region of memory, aligned on
  13  * an MBLOCK_SIZE boundary.  There are no other restrictions on the
  14  * addresses of memory returned by getMBlock().
  15  *
  16  * ---------------------------------------------------------------------------*/
  17
  18 #include "PosixSource.h"
  19 #include "Rts.h"
  20
  21 #include "Storage.h"
  22 #include "RtsUtils.h"
  23 #include "BlockAlloc.h"
  24
  25 #include <string.h>
  26
  27 static void  initMBlock(void *mblock);
  28
  29 /* -----------------------------------------------------------------------------
  30
  31   Implementation notes
  32   ~~~~~~~~~~~~~~~~~~~~
  33
  34   Terminology:
  35     - bdescr = block descriptor
  36     - bgroup = block group (1 or more adjacent blocks)
  37     - mblock = mega block
  38     - mgroup = mega group (1 or more adjacent mblocks)
  39
  40    Invariants on block descriptors
  41    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  42    bd->start always points to the start of the block.
  43
  44    bd->free is either:
  45       - zero for a non-group-head; bd->link points to the head
  46       - (-1) for the head of a free block group
  47       - or it points within the block
  48
  49    bd->blocks is either:
  50       - zero for a non-group-head; bd->link points to the head
  51       - number of blocks in this group otherwise
  52
  53    bd->link either points to a block descriptor or is NULL
  54
  55    The following fields are not used by the allocator:
  56      bd->flags
  57      bd->gen_no
  58      bd->gen
  59      bd->dest
  60
  61   Exceptions: we don't maintain invariants for all the blocks within a
  62   group on the free list, because it is expensive to modify every
  63   bdescr in a group when coalescing.  Just the head and last bdescrs
  64   will be correct for a group on the free list.
  65
  66
  67   Free lists
  68   ~~~~~~~~~~
  69
  70   Preliminaries:
  71     - most allocations are for a small number of blocks
  72     - sometimes the OS gives us new memory backwards in the address
  73       space, sometimes forwards, so we should not be biased towards
  74       any particular layout in the address space
  75     - We want to avoid fragmentation
  76     - We want allocation and freeing to be O(1) or close.
  77
  78   Coalescing trick: when a bgroup is freed (freeGroup()), we can check
  79   whether it can be coalesced with other free bgroups by checking the
  80   bdescrs for the blocks on either side of it.  This means that we can
  81   coalesce in O(1) time.  Every free bgroup must have its head and tail
  82   bdescrs initialised, the rest don't matter.
  83
  84   We keep the free list in buckets, using a heap-sort strategy.
  85   Bucket N contains blocks with sizes 2^N - 2^(N+1)-1.  The list of
  86   blocks in each bucket is doubly-linked, so that if a block is
  87   coalesced we can easily remove it from its current free list.
  88
  89   To allocate a new block of size S, grab a block from bucket
  90   log2ceiling(S) (i.e. log2() rounded up), in which all blocks are at
  91   least as big as S, and split it if necessary.  If there are no
  92   blocks in that bucket, look at bigger buckets until a block is found
  93   Allocation is therefore O(logN) time.
  94
  95   To free a block:
  96     - coalesce it with neighbours.
  97     - remove coalesced neighbour(s) from free list(s)
  98     - add the new (coalesced) block to the front of the appropriate
  99       bucket, given by log2(S) where S is the size of the block.
 100
 101   Free is O(1).
 102
 103   We cannot play this coalescing trick with mblocks, because there is
 104   no requirement that the bdescrs in the second and subsequent mblock
 105   of an mgroup are initialised (the mgroup might be filled with a
 106   large array, overwriting the bdescrs for example).
 107
 108   So there is a separate free list for megablocks, sorted in *address*
 109   order, so that we can coalesce.  Allocation in this list is best-fit
 110   by traversing the whole list: we don't expect this list to be long,
 111   and allocation/freeing of large blocks is rare; avoiding
 112   fragmentation is more important than performance here.
 113
 114   freeGroup() might end up moving a block from free_list to
 115   free_mblock_list, if after coalescing we end up with a full mblock.
 116
 117   checkFreeListSanity() checks all the invariants on the free lists.
 118
 119   --------------------------------------------------------------------------- */
 120
 121 #define MAX_FREE_LIST 9
 122
 123 // In THREADED_RTS mode, the free list is protected by sm_mutex.
 124
 125 static bdescr *free_list[MAX_FREE_LIST];
 126 static bdescr *free_mblock_list;
 127
 128 // free_list[i] contains blocks that are at least size 2^i, and at
 129 // most size 2^(i+1) - 1.
 130 //
 131 // To find the free list in which to place a block, use log_2(size).
 132 // To find a free block of the right size, use log_2_ceil(size).
 133
 134 lnat n_alloc_blocks;   // currently allocated blocks
 135 lnat hw_alloc_blocks;  // high-water allocated blocks
 136
 137 /* -----------------------------------------------------------------------------
 138    Initialisation
 139    -------------------------------------------------------------------------- */
 140
 141 void initBlockAllocator(void)
 142 {
 143     nat i;
 144     for (i=0; i < MAX_FREE_LIST; i++) {
 145         free_list[i] = NULL;
 146     }
 147     free_mblock_list = NULL;
 148     n_alloc_blocks = 0;
 149     hw_alloc_blocks = 0;
 150 }
 151
 152 /* -----------------------------------------------------------------------------
 153    Allocation
 154    -------------------------------------------------------------------------- */
 155
 156 STATIC_INLINE void
 157 initGroup(bdescr *head)
 158 {
 159   bdescr *bd;
 160   nat i, n;
 161
 162   n = head->blocks;
 163   head->free   = head->start;
 164   head->link   = NULL;
 165   for (i=1, bd = head+1; i < n; i++, bd++) {
 166       bd->free = 0;
 167       bd->blocks = 0;
 168       bd->link = head;
 169   }
 170 }
 171
 172 // There are quicker non-loopy ways to do log_2, but we expect n to be
 173 // usually small, and MAX_FREE_LIST is also small, so the loop version
 174 // might well be the best choice here.
 175 STATIC_INLINE nat
 176 log_2_ceil(nat n)
 177 {
 178     nat i, x;
 179     x = 1;
 180     for (i=0; i < MAX_FREE_LIST; i++) {
 181         if (x >= n) return i;
 182         x = x << 1;
 183     }
 184     return MAX_FREE_LIST;
 185 }
 186
 187 STATIC_INLINE nat
 188 log_2(nat n)
 189 {
 190     nat i, x;
 191     x = n;
 192     for (i=0; i < MAX_FREE_LIST; i++) {
 193         x = x >> 1;
 194         if (x == 0) return i;
 195     }
 196     return MAX_FREE_LIST;
 197 }
 198
 199 STATIC_INLINE void
 200 free_list_insert (bdescr *bd)
 201 {
 202     nat ln;
 203
 204     ASSERT(bd->blocks < BLOCKS_PER_MBLOCK);
 205     ln = log_2(bd->blocks);
 206
 207     dbl_link_onto(bd, &free_list[ln]);
 208 }
 209
 210
 211 STATIC_INLINE bdescr *
 212 tail_of (bdescr *bd)
 213 {
 214     return bd + bd->blocks - 1;
 215 }
 216
 217 // After splitting a group, the last block of each group must have a
 218 // tail that points to the head block, to keep our invariants for
 219 // coalescing.
 220 STATIC_INLINE void
 221 setup_tail (bdescr *bd)
 222 {
 223     bdescr *tail;
 224     tail = tail_of(bd);
 225     if (tail != bd) {
 226         tail->blocks = 0;
 227         tail->free = 0;
 228         tail->link = bd;
 229     }
 230 }
 231
 232
 233 // Take a free block group bd, and split off a group of size n from
 234 // it.  Adjust the free list as necessary, and return the new group.
 235 static bdescr *
 236 split_free_block (bdescr *bd, nat n, nat ln)
 237 {
 238     bdescr *fg; // free group
 239
 240     ASSERT(bd->blocks > n);
 241     dbl_link_remove(bd, &free_list[ln]);
 242     fg = bd + bd->blocks - n; // take n blocks off the end
 243     fg->blocks = n;
 244     bd->blocks -= n;
 245     setup_tail(bd);
 246     ln = log_2(bd->blocks);
 247     dbl_link_onto(bd, &free_list[ln]);
 248     return fg;
 249 }
 250
 251 static bdescr *
 252 alloc_mega_group (nat mblocks)
 253 {
 254     bdescr *best, *bd, *prev;
 255     nat n;
 256
 257     n = MBLOCK_GROUP_BLOCKS(mblocks);
 258
 259     best = NULL;
 260     prev = NULL;
 261     for (bd = free_mblock_list; bd != NULL; prev = bd, bd = bd->link)
 262     {
 263         if (bd->blocks == n)
 264         {
 265             if (prev) {
 266                 prev->link = bd->link;
 267             } else {
 268                 free_mblock_list = bd->link;
 269             }
 270             initGroup(bd);
 271             return bd;
 272         }
 273         else if (bd->blocks > n)
 274         {
 275             if (!best || bd->blocks < best->blocks)
 276             {
 277                 best = bd;
 278             }
 279         }
 280     }
 281
 282     if (best)
 283     {
 284         // we take our chunk off the end here.
 285         StgWord best_mblocks  = BLOCKS_TO_MBLOCKS(best->blocks);
 286         bd = FIRST_BDESCR((StgWord8*)MBLOCK_ROUND_DOWN(best) +
 287                           (best_mblocks-mblocks)*MBLOCK_SIZE);
 288
 289         best->blocks = MBLOCK_GROUP_BLOCKS(best_mblocks - mblocks);
 290         initMBlock(MBLOCK_ROUND_DOWN(bd));
 291     }
 292     else
 293     {
 294         void *mblock = getMBlocks(mblocks);
 295         initMBlock(mblock);             // only need to init the 1st one
 296         bd = FIRST_BDESCR(mblock);
 297     }
 298     bd->blocks = MBLOCK_GROUP_BLOCKS(mblocks);
 299     return bd;
 300 }
 301
 302 bdescr *
 303 allocGroup (nat n)
 304 {
 305     bdescr *bd, *rem;
 306     nat ln;
 307
 308     if (n == 0) barf("allocGroup: requested zero blocks");
 309
 310     if (n >= BLOCKS_PER_MBLOCK)
 311     {
 312         nat mblocks;
 313
 314         mblocks = BLOCKS_TO_MBLOCKS(n);
 315
 316         // n_alloc_blocks doesn't count the extra blocks we get in a
 317         // megablock group.
 318         n_alloc_blocks += mblocks * BLOCKS_PER_MBLOCK;
 319         if (n_alloc_blocks > hw_alloc_blocks) hw_alloc_blocks = n_alloc_blocks;
 320
 321         bd = alloc_mega_group(mblocks);
 322         // only the bdescrs of the first MB are required to be initialised
 323         initGroup(bd);
 324
 325         IF_DEBUG(sanity, checkFreeListSanity());
 326         return bd;
 327     }
 328
 329     n_alloc_blocks += n;
 330     if (n_alloc_blocks > hw_alloc_blocks) hw_alloc_blocks = n_alloc_blocks;
 331
 332     ln = log_2_ceil(n);
 333
 334     while (ln < MAX_FREE_LIST && free_list[ln] == NULL) {
 335         ln++;
 336     }
 337
 338     if (ln == MAX_FREE_LIST) {
 339 #if 0
 340         if ((mblocks_allocated * MBLOCK_SIZE_W - n_alloc_blocks * BLOCK_SIZE_W) > (1024*1024)/sizeof(W_)) {
 341             debugBelch("Fragmentation, wanted %d blocks:", n);
 342             RtsFlags.DebugFlags.block_alloc = 1;
 343             checkFreeListSanity();
 344         }
 345 #endif
 346
 347         bd = alloc_mega_group(1);
 348         bd->blocks = n;
 349         initGroup(bd);                   // we know the group will fit
 350         rem = bd + n;
 351         rem->blocks = BLOCKS_PER_MBLOCK-n;
 352         initGroup(rem); // init the slop
 353         n_alloc_blocks += rem->blocks;
 354         freeGroup(rem);                  // add the slop on to the free list
 355         IF_DEBUG(sanity, checkFreeListSanity());
 356         return bd;
 357     }
 358
 359     bd = free_list[ln];
 360
 361     if (bd->blocks == n)                // exactly the right size!
 362     {
 363         dbl_link_remove(bd, &free_list[ln]);
 364     }
 365     else if (bd->blocks >  n)            // block too big...
 366     {
 367         bd = split_free_block(bd, n, ln);
 368     }
 369     else
 370     {
 371         barf("allocGroup: free list corrupted");
 372     }
 373     initGroup(bd);              // initialise it
 374     IF_DEBUG(sanity, checkFreeListSanity());
 375     ASSERT(bd->blocks == n);
 376     return bd;
 377 }
 378
 379 bdescr *
 380 allocGroup_lock(nat n)
 381 {
 382     bdescr *bd;
 383     ACQUIRE_SM_LOCK;
 384     bd = allocGroup(n);
 385     RELEASE_SM_LOCK;
 386     return bd;
 387 }
 388
 389 bdescr *
 390 allocBlock(void)
 391 {
 392     return allocGroup(1);
 393 }
 394
 395 bdescr *
 396 allocBlock_lock(void)
 397 {
 398     bdescr *bd;
 399     ACQUIRE_SM_LOCK;
 400     bd = allocBlock();
 401     RELEASE_SM_LOCK;
 402     return bd;
 403 }
 404
 405 /* -----------------------------------------------------------------------------
 406    De-Allocation
 407    -------------------------------------------------------------------------- */
 408
 409 STATIC_INLINE bdescr *
 410 coalesce_mblocks (bdescr *p)
 411 {
 412     bdescr *q;
 413
 414     q = p->link;
 415     if (q != NULL &&
 416         MBLOCK_ROUND_DOWN(q) ==
 417         (StgWord8*)MBLOCK_ROUND_DOWN(p) +
 418         BLOCKS_TO_MBLOCKS(p->blocks) * MBLOCK_SIZE) {
 419         // can coalesce
 420         p->blocks  = MBLOCK_GROUP_BLOCKS(BLOCKS_TO_MBLOCKS(p->blocks) +
 421                                          BLOCKS_TO_MBLOCKS(q->blocks));
 422         p->link = q->link;
 423         return p;
 424     }
 425     return q;
 426 }
 427
 428 static void
 429 free_mega_group (bdescr *mg)
 430 {
 431     bdescr *bd, *prev;
 432
 433     // Find the right place in the free list.  free_mblock_list is
 434     // sorted by *address*, not by size as the free_list is.
 435     prev = NULL;
 436     bd = free_mblock_list;
 437     while (bd && bd->start < mg->start) {
 438         prev = bd;
 439         bd = bd->link;
 440     }
 441
 442     // coalesce backwards
 443     if (prev)
 444     {
 445         mg->link = prev->link;
 446         prev->link = mg;
 447         mg = coalesce_mblocks(prev);
 448     }
 449     else
 450     {
 451         mg->link = free_mblock_list;
 452         free_mblock_list = mg;
 453     }
 454     // coalesce forwards
 455     coalesce_mblocks(mg);
 456
 457     IF_DEBUG(sanity, checkFreeListSanity());
 458 }
 459
 460
 461 void
 462 freeGroup(bdescr *p)
 463 {
 464   nat ln;
 465
 466   // Todo: not true in multithreaded GC
 467   // ASSERT_SM_LOCK();
 468
 469   ASSERT(p->free != (P_)-1);
 470
 471   p->free = (void *)-1;  /* indicates that this block is free */
 472   p->gen = NULL;
 473   p->gen_no = 0;
 474   /* fill the block group with garbage if sanity checking is on */
 475   IF_DEBUG(sanity,memset(p->start, 0xaa, p->blocks * BLOCK_SIZE));
 476
 477   if (p->blocks == 0) barf("freeGroup: block size is zero");
 478
 479   if (p->blocks >= BLOCKS_PER_MBLOCK)
 480   {
 481       nat mblocks;
 482
 483       mblocks = BLOCKS_TO_MBLOCKS(p->blocks);
 484       // If this is an mgroup, make sure it has the right number of blocks
 485       ASSERT(p->blocks == MBLOCK_GROUP_BLOCKS(mblocks));
 486
 487       n_alloc_blocks -= mblocks * BLOCKS_PER_MBLOCK;
 488
 489       free_mega_group(p);
 490       return;
 491   }
 492
 493   ASSERT(n_alloc_blocks >= p->blocks);
 494   n_alloc_blocks -= p->blocks;
 495
 496   // coalesce forwards
 497   {
 498       bdescr *next;
 499       next = p + p->blocks;
 500       if (next <= LAST_BDESCR(MBLOCK_ROUND_DOWN(p)) && next->free == (P_)-1)
 501       {
 502           p->blocks += next->blocks;
 503           ln = log_2(next->blocks);
 504           dbl_link_remove(next, &free_list[ln]);
 505           if (p->blocks == BLOCKS_PER_MBLOCK)
 506           {
 507               free_mega_group(p);
 508               return;
 509           }
 510           setup_tail(p);
 511       }
 512   }
 513
 514   // coalesce backwards
 515   if (p != FIRST_BDESCR(MBLOCK_ROUND_DOWN(p)))
 516   {
 517       bdescr *prev;
 518       prev = p - 1;
 519       if (prev->blocks == 0) prev = prev->link; // find the head
 520
 521       if (prev->free == (P_)-1)
 522       {
 523           ln = log_2(prev->blocks);
 524           dbl_link_remove(prev, &free_list[ln]);
 525           prev->blocks += p->blocks;
 526           if (prev->blocks >= BLOCKS_PER_MBLOCK)
 527           {
 528               free_mega_group(prev);
 529               return;
 530           }
 531           p = prev;
 532       }
 533   }
 534
 535   setup_tail(p);
 536   free_list_insert(p);
 537
 538   IF_DEBUG(sanity, checkFreeListSanity());
 539 }
 540
 541 void
 542 freeGroup_lock(bdescr *p)
 543 {
 544     ACQUIRE_SM_LOCK;
 545     freeGroup(p);
 546     RELEASE_SM_LOCK;
 547 }
 548
 549 void
 550 freeChain(bdescr *bd)
 551 {
 552   bdescr *next_bd;
 553   while (bd != NULL) {
 554     next_bd = bd->link;
 555     freeGroup(bd);
 556     bd = next_bd;
 557   }
 558 }
 559
 560 void
 561 freeChain_lock(bdescr *bd)
 562 {
 563     ACQUIRE_SM_LOCK;
 564     freeChain(bd);
 565     RELEASE_SM_LOCK;
 566 }
 567
 568 // splitBlockGroup(bd,B) splits bd in two.  Afterward, bd will have B
 569 // blocks, and a new block descriptor pointing to the remainder is
 570 // returned.
 571 bdescr *
 572 splitBlockGroup (bdescr *bd, nat blocks)
 573 {
 574     bdescr *new_bd;
 575
 576     if (bd->blocks <= blocks) {
 577         barf("splitLargeBlock: too small");
 578     }
 579
 580     if (bd->blocks > BLOCKS_PER_MBLOCK) {
 581         nat low_mblocks, high_mblocks;
 582         void *new_mblock;
 583         if ((blocks - BLOCKS_PER_MBLOCK) % (MBLOCK_SIZE / BLOCK_SIZE) != 0) {
 584             barf("splitLargeBlock: not a multiple of a megablock");
 585         }
 586         low_mblocks = 1 + (blocks - BLOCKS_PER_MBLOCK) / (MBLOCK_SIZE / BLOCK_SIZE);
 587         high_mblocks = (bd->blocks - blocks) / (MBLOCK_SIZE / BLOCK_SIZE);
 588
 589         new_mblock = (void *) ((P_)MBLOCK_ROUND_DOWN(bd) + low_mblocks * MBLOCK_SIZE_W);
 590         initMBlock(new_mblock);
 591         new_bd = FIRST_BDESCR(new_mblock);
 592         new_bd->blocks = MBLOCK_GROUP_BLOCKS(high_mblocks);
 593
 594         ASSERT(blocks + new_bd->blocks ==
 595                bd->blocks + BLOCKS_PER_MBLOCK - MBLOCK_SIZE/BLOCK_SIZE);
 596     }
 597     else
 598     {
 599         // NB. we're not updating all the bdescrs in the split groups to
 600         // point to the new heads, so this can only be used for large
 601         // objects which do not start in the non-head block.
 602         new_bd = bd + blocks;
 603         new_bd->blocks = bd->blocks - blocks;
 604     }
 605     bd->blocks = blocks;
 606
 607     return new_bd;
 608 }
 609
 610 static void
 611 initMBlock(void *mblock)
 612 {
 613     bdescr *bd;
 614     StgWord8 *block;
 615
 616     /* the first few Bdescr's in a block are unused, so we don't want to
 617      * put them all on the free list.
 618      */
 619     block = FIRST_BLOCK(mblock);
 620     bd    = FIRST_BDESCR(mblock);
 621
 622     /* Initialise the start field of each block descriptor
 623      */
 624     for (; block <= (StgWord8*)LAST_BLOCK(mblock); bd += 1,
 625              block += BLOCK_SIZE) {
 626         bd->start = (void*)block;
 627     }
 628 }
 629
 630 /* -----------------------------------------------------------------------------
 631    Stats / metrics
 632    -------------------------------------------------------------------------- */
 633
 634 nat
 635 countBlocks(bdescr *bd)
 636 {
 637     nat n;
 638     for (n=0; bd != NULL; bd=bd->link) {
 639         n += bd->blocks;
 640     }
 641     return n;
 642 }
 643
 644 // (*1) Just like countBlocks, except that we adjust the count for a
 645 // megablock group so that it doesn't include the extra few blocks
 646 // that would be taken up by block descriptors in the second and
 647 // subsequent megablock.  This is so we can tally the count with the
 648 // number of blocks allocated in the system, for memInventory().
 649 nat
 650 countAllocdBlocks(bdescr *bd)
 651 {
 652     nat n;
 653     for (n=0; bd != NULL; bd=bd->link) {
 654         n += bd->blocks;
 655         // hack for megablock groups: see (*1) above
 656         if (bd->blocks > BLOCKS_PER_MBLOCK) {
 657             n -= (MBLOCK_SIZE / BLOCK_SIZE - BLOCKS_PER_MBLOCK)
 658                 * (bd->blocks/(MBLOCK_SIZE/BLOCK_SIZE));
 659         }
 660     }
 661     return n;
 662 }
 663
 664 /* -----------------------------------------------------------------------------
 665    Debugging
 666    -------------------------------------------------------------------------- */
 667
 668 #ifdef DEBUG
 669 static void
 670 check_tail (bdescr *bd)
 671 {
 672     bdescr *tail = tail_of(bd);
 673
 674     if (tail != bd)
 675     {
 676         ASSERT(tail->blocks == 0);
 677         ASSERT(tail->free == 0);
 678         ASSERT(tail->link == bd);
 679     }
 680 }
 681
 682 void
 683 checkFreeListSanity(void)
 684 {
 685     bdescr *bd, *prev;
 686     nat ln, min;
 687
 688
 689     min = 1;
 690     for (ln = 0; ln < MAX_FREE_LIST; ln++) {
 691         IF_DEBUG(block_alloc, debugBelch("free block list [%d]:\n", ln));
 692
 693         prev = NULL;
 694         for (bd = free_list[ln]; bd != NULL; prev = bd, bd = bd->link)
 695         {
 696             IF_DEBUG(block_alloc,
 697                      debugBelch("group at %p, length %ld blocks\n",
 698                                 bd->start, (long)bd->blocks));
 699             ASSERT(bd->free == (P_)-1);
 700             ASSERT(bd->blocks > 0 && bd->blocks < BLOCKS_PER_MBLOCK);
 701             ASSERT(bd->blocks >= min && bd->blocks <= (min*2 - 1));
 702             ASSERT(bd->link != bd); // catch easy loops
 703
 704             check_tail(bd);
 705
 706             if (prev)
 707                 ASSERT(bd->u.back == prev);
 708             else
 709                 ASSERT(bd->u.back == NULL);
 710
 711             {
 712                 bdescr *next;
 713                 next = bd + bd->blocks;
 714                 if (next <= LAST_BDESCR(MBLOCK_ROUND_DOWN(bd)))
 715                 {
 716                     ASSERT(next->free != (P_)-1);
 717                 }
 718             }
 719         }
 720         min = min << 1;
 721     }
 722
 723     prev = NULL;
 724     for (bd = free_mblock_list; bd != NULL; prev = bd, bd = bd->link)
 725     {
 726         IF_DEBUG(block_alloc,
 727                  debugBelch("mega group at %p, length %ld blocks\n",
 728                             bd->start, (long)bd->blocks));
 729
 730         ASSERT(bd->link != bd); // catch easy loops
 731
 732         if (bd->link != NULL)
 733         {
 734             // make sure the list is sorted
 735             ASSERT(bd->start < bd->link->start);
 736         }
 737
 738         ASSERT(bd->blocks >= BLOCKS_PER_MBLOCK);
 739         ASSERT(MBLOCK_GROUP_BLOCKS(BLOCKS_TO_MBLOCKS(bd->blocks))
 740                == bd->blocks);
 741
 742         // make sure we're fully coalesced
 743         if (bd->link != NULL)
 744         {
 745             ASSERT (MBLOCK_ROUND_DOWN(bd->link) !=
 746                     (StgWord8*)MBLOCK_ROUND_DOWN(bd) +
 747                     BLOCKS_TO_MBLOCKS(bd->blocks) * MBLOCK_SIZE);
 748         }
 749     }
 750 }
 751
 752 nat /* BLOCKS */
 753 countFreeList(void)
 754 {
 755   bdescr *bd;
 756   lnat total_blocks = 0;
 757   nat ln;
 758
 759   for (ln=0; ln < MAX_FREE_LIST; ln++) {
 760       for (bd = free_list[ln]; bd != NULL; bd = bd->link) {
 761           total_blocks += bd->blocks;
 762       }
 763   }
 764   for (bd = free_mblock_list; bd != NULL; bd = bd->link) {
 765       total_blocks += BLOCKS_PER_MBLOCK * BLOCKS_TO_MBLOCKS(bd->blocks);
 766       // The caller of this function, memInventory(), expects to match
 767       // the total number of blocks in the system against mblocks *
 768       // BLOCKS_PER_MBLOCK, so we must subtract the space for the
 769       // block descriptors from *every* mblock.
 770   }
 771   return total_blocks;
 772 }
 773
 774 void
 775 markBlocks (bdescr *bd)
 776 {
 777     for (; bd != NULL; bd = bd->link) {
 778         bd->flags |= BF_KNOWN;
 779     }
 780 }
 781
 782 void
 783 reportUnmarkedBlocks (void)
 784 {
 785     void *mblock;
 786     bdescr *bd;
 787
 788     debugBelch("Unreachable blocks:\n");
 789     for (mblock = getFirstMBlock(); mblock != NULL;
 790          mblock = getNextMBlock(mblock)) {
 791         for (bd = FIRST_BDESCR(mblock); bd <= LAST_BDESCR(mblock); ) {
 792             if (!(bd->flags & BF_KNOWN) && bd->free != (P_)-1) {
 793                 debugBelch("  %p\n",bd);
 794             }
 795             if (bd->blocks >= BLOCKS_PER_MBLOCK) {
 796                 mblock = (StgWord8*)mblock +
 797                     (BLOCKS_TO_MBLOCKS(bd->blocks) - 1) * MBLOCK_SIZE;
 798                 break;
 799             } else {
 800                 bd += bd->blocks;
 801             }
 802         }
 803     }
 804 }
 805
 806 #endif