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