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  /* useful for debugging fragmentation */
 349         if ((W_)mblocks_allocated * BLOCKS_PER_MBLOCK * BLOCK_SIZE_W
 350              - (W_)((n_alloc_blocks - n) * BLOCK_SIZE_W) > (2*1024*1024)/sizeof(W_)) {
 351             debugBelch("Fragmentation, wanted %d blocks:", n);
 352             RtsFlags.DebugFlags.block_alloc = 1;
 353             checkFreeListSanity();
 354         }
 355 #endif
 356
 357         bd = alloc_mega_group(1);
 358         bd->blocks = n;
 359         initGroup(bd);                   // we know the group will fit
 360         rem = bd + n;
 361         rem->blocks = BLOCKS_PER_MBLOCK-n;
 362         initGroup(rem); // init the slop
 363         n_alloc_blocks += rem->blocks;
 364         freeGroup(rem);                  // add the slop on to the free list
 365         goto finish;
 366     }
 367
 368     bd = free_list[ln];
 369
 370     if (bd->blocks == n)                // exactly the right size!
 371     {
 372         dbl_link_remove(bd, &free_list[ln]);
 373         initGroup(bd);
 374     }
 375     else if (bd->blocks >  n)            // block too big...
 376     {
 377         bd = split_free_block(bd, n, ln);
 378         ASSERT(bd->blocks == n);
 379         initGroup(bd);
 380     }
 381     else
 382     {
 383         barf("allocGroup: free list corrupted");
 384     }
 385
 386 finish:
 387     IF_DEBUG(sanity, memset(bd->start, 0xaa, bd->blocks * BLOCK_SIZE));
 388     IF_DEBUG(sanity, checkFreeListSanity());
 389     return bd;
 390 }
 391
 392 bdescr *
 393 allocGroup_lock(nat n)
 394 {
 395     bdescr *bd;
 396     ACQUIRE_SM_LOCK;
 397     bd = allocGroup(n);
 398     RELEASE_SM_LOCK;
 399     return bd;
 400 }
 401
 402 bdescr *
 403 allocBlock(void)
 404 {
 405     return allocGroup(1);
 406 }
 407
 408 bdescr *
 409 allocBlock_lock(void)
 410 {
 411     bdescr *bd;
 412     ACQUIRE_SM_LOCK;
 413     bd = allocBlock();
 414     RELEASE_SM_LOCK;
 415     return bd;
 416 }
 417
 418 /* -----------------------------------------------------------------------------
 419    De-Allocation
 420    -------------------------------------------------------------------------- */
 421
 422 STATIC_INLINE bdescr *
 423 coalesce_mblocks (bdescr *p)
 424 {
 425     bdescr *q;
 426
 427     q = p->link;
 428     if (q != NULL &&
 429         MBLOCK_ROUND_DOWN(q) ==
 430         (StgWord8*)MBLOCK_ROUND_DOWN(p) +
 431         BLOCKS_TO_MBLOCKS(p->blocks) * MBLOCK_SIZE) {
 432         // can coalesce
 433         p->blocks  = MBLOCK_GROUP_BLOCKS(BLOCKS_TO_MBLOCKS(p->blocks) +
 434                                          BLOCKS_TO_MBLOCKS(q->blocks));
 435         p->link = q->link;
 436         return p;
 437     }
 438     return q;
 439 }
 440
 441 static void
 442 free_mega_group (bdescr *mg)
 443 {
 444     bdescr *bd, *prev;
 445
 446     // Find the right place in the free list.  free_mblock_list is
 447     // sorted by *address*, not by size as the free_list is.
 448     prev = NULL;
 449     bd = free_mblock_list;
 450     while (bd && bd->start < mg->start) {
 451         prev = bd;
 452         bd = bd->link;
 453     }
 454
 455     // coalesce backwards
 456     if (prev)
 457     {
 458         mg->link = prev->link;
 459         prev->link = mg;
 460         mg = coalesce_mblocks(prev);
 461     }
 462     else
 463     {
 464         mg->link = free_mblock_list;
 465         free_mblock_list = mg;
 466     }
 467     // coalesce forwards
 468     coalesce_mblocks(mg);
 469
 470     IF_DEBUG(sanity, checkFreeListSanity());
 471 }
 472
 473
 474 void
 475 freeGroup(bdescr *p)
 476 {
 477   nat ln;
 478
 479   // Todo: not true in multithreaded GC
 480   // ASSERT_SM_LOCK();
 481
 482   ASSERT(p->free != (P_)-1);
 483
 484   p->free = (void *)-1;  /* indicates that this block is free */
 485   p->gen = NULL;
 486   p->gen_no = 0;
 487   /* fill the block group with garbage if sanity checking is on */
 488   IF_DEBUG(sanity,memset(p->start, 0xaa, (W_)p->blocks * BLOCK_SIZE));
 489
 490   if (p->blocks == 0) barf("freeGroup: block size is zero");
 491
 492   if (p->blocks >= BLOCKS_PER_MBLOCK)
 493   {
 494       nat mblocks;
 495
 496       mblocks = BLOCKS_TO_MBLOCKS(p->blocks);
 497       // If this is an mgroup, make sure it has the right number of blocks
 498       ASSERT(p->blocks == MBLOCK_GROUP_BLOCKS(mblocks));
 499
 500       n_alloc_blocks -= mblocks * BLOCKS_PER_MBLOCK;
 501
 502       free_mega_group(p);
 503       return;
 504   }
 505
 506   ASSERT(n_alloc_blocks >= p->blocks);
 507   n_alloc_blocks -= p->blocks;
 508
 509   // coalesce forwards
 510   {
 511       bdescr *next;
 512       next = p + p->blocks;
 513       if (next <= LAST_BDESCR(MBLOCK_ROUND_DOWN(p)) && next->free == (P_)-1)
 514       {
 515           p->blocks += next->blocks;
 516           ln = log_2(next->blocks);
 517           dbl_link_remove(next, &free_list[ln]);
 518           if (p->blocks == BLOCKS_PER_MBLOCK)
 519           {
 520               free_mega_group(p);
 521               return;
 522           }
 523           setup_tail(p);
 524       }
 525   }
 526
 527   // coalesce backwards
 528   if (p != FIRST_BDESCR(MBLOCK_ROUND_DOWN(p)))
 529   {
 530       bdescr *prev;
 531       prev = p - 1;
 532       if (prev->blocks == 0) prev = prev->link; // find the head
 533
 534       if (prev->free == (P_)-1)
 535       {
 536           ln = log_2(prev->blocks);
 537           dbl_link_remove(prev, &free_list[ln]);
 538           prev->blocks += p->blocks;
 539           if (prev->blocks >= BLOCKS_PER_MBLOCK)
 540           {
 541               free_mega_group(prev);
 542               return;
 543           }
 544           p = prev;
 545       }
 546   }
 547
 548   setup_tail(p);
 549   free_list_insert(p);
 550
 551   IF_DEBUG(sanity, checkFreeListSanity());
 552 }
 553
 554 void
 555 freeGroup_lock(bdescr *p)
 556 {
 557     ACQUIRE_SM_LOCK;
 558     freeGroup(p);
 559     RELEASE_SM_LOCK;
 560 }
 561
 562 void
 563 freeChain(bdescr *bd)
 564 {
 565   bdescr *next_bd;
 566   while (bd != NULL) {
 567     next_bd = bd->link;
 568     freeGroup(bd);
 569     bd = next_bd;
 570   }
 571 }
 572
 573 void
 574 freeChain_lock(bdescr *bd)
 575 {
 576     ACQUIRE_SM_LOCK;
 577     freeChain(bd);
 578     RELEASE_SM_LOCK;
 579 }
 580
 581 static void
 582 initMBlock(void *mblock)
 583 {
 584     bdescr *bd;
 585     StgWord8 *block;
 586
 587     /* the first few Bdescr's in a block are unused, so we don't want to
 588      * put them all on the free list.
 589      */
 590     block = FIRST_BLOCK(mblock);
 591     bd    = FIRST_BDESCR(mblock);
 592
 593     /* Initialise the start field of each block descriptor
 594      */
 595     for (; block <= (StgWord8*)LAST_BLOCK(mblock); bd += 1,
 596              block += BLOCK_SIZE) {
 597         bd->start = (void*)block;
 598     }
 599 }
 600
 601 /* -----------------------------------------------------------------------------
 602    Stats / metrics
 603    -------------------------------------------------------------------------- */
 604
 605 nat
 606 countBlocks(bdescr *bd)
 607 {
 608     nat n;
 609     for (n=0; bd != NULL; bd=bd->link) {
 610         n += bd->blocks;
 611     }
 612     return n;
 613 }
 614
 615 // (*1) Just like countBlocks, except that we adjust the count for a
 616 // megablock group so that it doesn't include the extra few blocks
 617 // that would be taken up by block descriptors in the second and
 618 // subsequent megablock.  This is so we can tally the count with the
 619 // number of blocks allocated in the system, for memInventory().
 620 nat
 621 countAllocdBlocks(bdescr *bd)
 622 {
 623     nat n;
 624     for (n=0; bd != NULL; bd=bd->link) {
 625         n += bd->blocks;
 626         // hack for megablock groups: see (*1) above
 627         if (bd->blocks > BLOCKS_PER_MBLOCK) {
 628             n -= (MBLOCK_SIZE / BLOCK_SIZE - BLOCKS_PER_MBLOCK)
 629                 * (bd->blocks/(MBLOCK_SIZE/BLOCK_SIZE));
 630         }
 631     }
 632     return n;
 633 }
 634
 635 void returnMemoryToOS(nat n /* megablocks */)
 636 {
 637     static bdescr *bd;
 638     nat size;
 639
 640     bd = free_mblock_list;
 641     while ((n > 0) && (bd != NULL)) {
 642         size = BLOCKS_TO_MBLOCKS(bd->blocks);
 643         if (size > n) {
 644             nat newSize = size - n;
 645             char *freeAddr = MBLOCK_ROUND_DOWN(bd->start);
 646             freeAddr += newSize * MBLOCK_SIZE;
 647             bd->blocks = MBLOCK_GROUP_BLOCKS(newSize);
 648             freeMBlocks(freeAddr, n);
 649             n = 0;
 650         }
 651         else {
 652             char *freeAddr = MBLOCK_ROUND_DOWN(bd->start);
 653             n -= size;
 654             bd = bd->link;
 655             freeMBlocks(freeAddr, size);
 656         }
 657     }
 658     free_mblock_list = bd;
 659
 660     osReleaseFreeMemory();
 661
 662     IF_DEBUG(gc,
 663         if (n != 0) {
 664             debugBelch("Wanted to free %d more MBlocks than are freeable\n",
 665                        n);
 666         }
 667     );
 668 }
 669
 670 /* -----------------------------------------------------------------------------
 671    Debugging
 672    -------------------------------------------------------------------------- */
 673
 674 #ifdef DEBUG
 675 static void
 676 check_tail (bdescr *bd)
 677 {
 678     bdescr *tail = tail_of(bd);
 679
 680     if (tail != bd)
 681     {
 682         ASSERT(tail->blocks == 0);
 683         ASSERT(tail->free == 0);
 684         ASSERT(tail->link == bd);
 685     }
 686 }
 687
 688 void
 689 checkFreeListSanity(void)
 690 {
 691     bdescr *bd, *prev;
 692     nat ln, min;
 693
 694
 695     min = 1;
 696     for (ln = 0; ln < MAX_FREE_LIST; ln++) {
 697         IF_DEBUG(block_alloc, debugBelch("free block list [%d]:\n", ln));
 698
 699         prev = NULL;
 700         for (bd = free_list[ln]; bd != NULL; prev = bd, bd = bd->link)
 701         {
 702             IF_DEBUG(block_alloc,
 703                      debugBelch("group at %p, length %ld blocks\n",
 704                                 bd->start, (long)bd->blocks));
 705             ASSERT(bd->free == (P_)-1);
 706             ASSERT(bd->blocks > 0 && bd->blocks < BLOCKS_PER_MBLOCK);
 707             ASSERT(bd->blocks >= min && bd->blocks <= (min*2 - 1));
 708             ASSERT(bd->link != bd); // catch easy loops
 709
 710             check_tail(bd);
 711
 712             if (prev)
 713                 ASSERT(bd->u.back == prev);
 714             else
 715                 ASSERT(bd->u.back == NULL);
 716
 717             {
 718                 bdescr *next;
 719                 next = bd + bd->blocks;
 720                 if (next <= LAST_BDESCR(MBLOCK_ROUND_DOWN(bd)))
 721                 {
 722                     ASSERT(next->free != (P_)-1);
 723                 }
 724             }
 725         }
 726         min = min << 1;
 727     }
 728
 729     prev = NULL;
 730     for (bd = free_mblock_list; bd != NULL; prev = bd, bd = bd->link)
 731     {
 732         IF_DEBUG(block_alloc,
 733                  debugBelch("mega group at %p, length %ld blocks\n",
 734                             bd->start, (long)bd->blocks));
 735
 736         ASSERT(bd->link != bd); // catch easy loops
 737
 738         if (bd->link != NULL)
 739         {
 740             // make sure the list is sorted
 741             ASSERT(bd->start < bd->link->start);
 742         }
 743
 744         ASSERT(bd->blocks >= BLOCKS_PER_MBLOCK);
 745         ASSERT(MBLOCK_GROUP_BLOCKS(BLOCKS_TO_MBLOCKS(bd->blocks))
 746                == bd->blocks);
 747
 748         // make sure we're fully coalesced
 749         if (bd->link != NULL)
 750         {
 751             ASSERT (MBLOCK_ROUND_DOWN(bd->link) !=
 752                     (StgWord8*)MBLOCK_ROUND_DOWN(bd) +
 753                     BLOCKS_TO_MBLOCKS(bd->blocks) * MBLOCK_SIZE);
 754         }
 755     }
 756 }
 757
 758 nat /* BLOCKS */
 759 countFreeList(void)
 760 {
 761   bdescr *bd;
 762   lnat total_blocks = 0;
 763   nat ln;
 764
 765   for (ln=0; ln < MAX_FREE_LIST; ln++) {
 766       for (bd = free_list[ln]; bd != NULL; bd = bd->link) {
 767           total_blocks += bd->blocks;
 768       }
 769   }
 770   for (bd = free_mblock_list; bd != NULL; bd = bd->link) {
 771       total_blocks += BLOCKS_PER_MBLOCK * BLOCKS_TO_MBLOCKS(bd->blocks);
 772       // The caller of this function, memInventory(), expects to match
 773       // the total number of blocks in the system against mblocks *
 774       // BLOCKS_PER_MBLOCK, so we must subtract the space for the
 775       // block descriptors from *every* mblock.
 776   }
 777   return total_blocks;
 778 }
 779
 780 void
 781 markBlocks (bdescr *bd)
 782 {
 783     for (; bd != NULL; bd = bd->link) {
 784         bd->flags |= BF_KNOWN;
 785     }
 786 }
 787
 788 void
 789 reportUnmarkedBlocks (void)
 790 {
 791     void *mblock;
 792     bdescr *bd;
 793
 794     debugBelch("Unreachable blocks:\n");
 795     for (mblock = getFirstMBlock(); mblock != NULL;
 796          mblock = getNextMBlock(mblock)) {
 797         for (bd = FIRST_BDESCR(mblock); bd <= LAST_BDESCR(mblock); ) {
 798             if (!(bd->flags & BF_KNOWN) && bd->free != (P_)-1) {
 799                 debugBelch("  %p\n",bd);
 800             }
 801             if (bd->blocks >= BLOCKS_PER_MBLOCK) {
 802                 mblock = (StgWord8*)mblock +
 803                     (BLOCKS_TO_MBLOCKS(bd->blocks) - 1) * MBLOCK_SIZE;
 804                 break;
 805             } else {
 806                 bd += bd->blocks;
 807             }
 808         }
 809     }
 810 }
 811
 812 #endif