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