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 // The free_list is kept sorted by size, smallest first.
  30 // In THREADED_RTS mode, the free list is protected by sm_mutex.
  31
  32 /* -----------------------------------------------------------------------------
  33
  34   Implementation notes
  35   ~~~~~~~~~~~~~~~~~~~~
  36
  37   Terminology:
  38     - bdescr = block descriptor
  39     - bgroup = block group (1 or more adjacent blocks)
  40     - mblock = mega block
  41     - mgroup = mega group (1 or more adjacent mblocks)
  42
  43    Invariants on block descriptors
  44    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  45    bd->start always points to the start of the block.
  46
  47    bd->free is either:
  48       - zero for a non-group-head; bd->link points to the head
  49       - (-1) for the head of a free block group
  50       - or it points within the block
  51
  52    bd->blocks is either:
  53       - zero for a non-group-head; bd->link points to the head
  54       - number of blocks in this group otherwise
  55
  56    bd->link either points to a block descriptor or is NULL
  57
  58    The following fields are not used by the allocator:
  59      bd->flags
  60      bd->gen_no
  61      bd->step
  62
  63   Exceptions: we don't maintain invariants for all the blocks within a
  64   group on the free list, because it is expensive to modify every
  65   bdescr in a group when coalescing.  Just the head and last bdescrs
  66   will be correct for a group on the free list.
  67
  68
  69   Free lists
  70   ~~~~~~~~~~
  71
  72   Preliminaries:
  73     - most allocations are for small blocks
  74     - sometimes the OS gives us new memory backwards in the address
  75       space, sometimes forwards, so we should not be biased towards
  76       any particular layout in the address space
  77     - We want to avoid fragmentation
  78     - We want allocation and freeing to be O(1) or close.
  79
  80   Coalescing trick: when a bgroup is freed (freeGroup()), we can check
  81   whether it can be coalesced with other free bgroups by checking the
  82   bdescrs for the blocks on either side of it.  This means that we can
  83   coalesce in O(1) time.  Every free bgroup must have its head and tail
  84   bdescrs initialised, the rest don't matter.
  85
  86   We keep the free list in buckets, using a heap-sort strategy.
  87   Bucket N contains blocks with sizes 2^N - 2^(N+1)-1.  The list of
  88   blocks in each bucket is doubly-linked, so that if a block is
  89   coalesced we can easily remove it from its current free list.
  90
  91   To allocate a new block of size S, grab a block from bucket
  92   log2ceiling(S) (i.e. log2() rounded up), in which all blocks are at
  93   least as big as S, and split it if necessary.  If there are no
  94   blocks in that bucket, look at bigger buckets until a block is found
  95   Allocation is therefore O(logN) time.
  96
  97   To free a block:
  98     - coalesce it with neighbours.
  99     - remove coalesced neighbour(s) from free list(s)
 100     - add the new (coalesced) block to the front of the appropriate
 101       bucket, given by log2(S) where S is the size of the block.
 102
 103   Free is O(1).
 104
 105   We cannot play this coalescing trick with mblocks, because there is
 106   no requirement that the bdescrs in the second and subsequent mblock
 107   of an mgroup are initialised (the mgroup might be filled with a
 108   large array, overwriting the bdescrs for example).
 109
 110   So there is a separate free list for megablocks, sorted in *address*
 111   order, so that we can coalesce.  Allocation in this list is best-fit
 112   by traversing the whole list: we don't expect this list to be long,
 113   and allocation/freeing of large blocks is rare; avoiding
 114   fragmentation is more important than performance here.
 115
 116   freeGroup() might end up moving a block from free_list to
 117   free_mblock_list, if after coalescing we end up with a full mblock.
 118
 119   checkFreeListSanity() checks all the invariants on the free lists.
 120
 121   --------------------------------------------------------------------------- */
 122
 123 #define MAX_FREE_LIST 9
 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         nat 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->step = 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    Debugging
 632    -------------------------------------------------------------------------- */
 633
 634 #ifdef DEBUG
 635 static void
 636 check_tail (bdescr *bd)
 637 {
 638     bdescr *tail = tail_of(bd);
 639
 640     if (tail != bd)
 641     {
 642         ASSERT(tail->blocks == 0);
 643         ASSERT(tail->free == 0);
 644         ASSERT(tail->link == bd);
 645     }
 646 }
 647
 648 void
 649 checkFreeListSanity(void)
 650 {
 651     bdescr *bd, *prev;
 652     nat ln, min;
 653
 654
 655     min = 1;
 656     for (ln = 0; ln < MAX_FREE_LIST; ln++) {
 657         IF_DEBUG(block_alloc, debugBelch("free block list [%d]:\n", ln));
 658
 659         prev = NULL;
 660         for (bd = free_list[ln]; bd != NULL; prev = bd, bd = bd->link)
 661         {
 662             IF_DEBUG(block_alloc,
 663                      debugBelch("group at %p, length %ld blocks\n",
 664                                 bd->start, (long)bd->blocks));
 665             ASSERT(bd->free == (P_)-1);
 666             ASSERT(bd->blocks > 0 && bd->blocks < BLOCKS_PER_MBLOCK);
 667             ASSERT(bd->blocks >= min && bd->blocks <= (min*2 - 1));
 668             ASSERT(bd->link != bd); // catch easy loops
 669
 670             check_tail(bd);
 671
 672             if (prev)
 673                 ASSERT(bd->u.back == prev);
 674             else
 675                 ASSERT(bd->u.back == NULL);
 676
 677             {
 678                 bdescr *next;
 679                 next = bd + bd->blocks;
 680                 if (next <= LAST_BDESCR(MBLOCK_ROUND_DOWN(bd)))
 681                 {
 682                     ASSERT(next->free != (P_)-1);
 683                 }
 684             }
 685         }
 686         min = min << 1;
 687     }
 688
 689     prev = NULL;
 690     for (bd = free_mblock_list; bd != NULL; prev = bd, bd = bd->link)
 691     {
 692         IF_DEBUG(block_alloc,
 693                  debugBelch("mega group at %p, length %ld blocks\n",
 694                             bd->start, (long)bd->blocks));
 695
 696         ASSERT(bd->link != bd); // catch easy loops
 697
 698         if (bd->link != NULL)
 699         {
 700             // make sure the list is sorted
 701             ASSERT(bd->start < bd->link->start);
 702         }
 703
 704         ASSERT(bd->blocks >= BLOCKS_PER_MBLOCK);
 705         ASSERT(MBLOCK_GROUP_BLOCKS(BLOCKS_TO_MBLOCKS(bd->blocks))
 706                == bd->blocks);
 707
 708         // make sure we're fully coalesced
 709         if (bd->link != NULL)
 710         {
 711             ASSERT (MBLOCK_ROUND_DOWN(bd->link) !=
 712                     (StgWord8*)MBLOCK_ROUND_DOWN(bd) +
 713                     BLOCKS_TO_MBLOCKS(bd->blocks) * MBLOCK_SIZE);
 714         }
 715     }
 716 }
 717
 718 nat /* BLOCKS */
 719 countFreeList(void)
 720 {
 721   bdescr *bd;
 722   lnat total_blocks = 0;
 723   nat ln;
 724
 725   for (ln=0; ln < MAX_FREE_LIST; ln++) {
 726       for (bd = free_list[ln]; bd != NULL; bd = bd->link) {
 727           total_blocks += bd->blocks;
 728       }
 729   }
 730   for (bd = free_mblock_list; bd != NULL; bd = bd->link) {
 731       total_blocks += BLOCKS_PER_MBLOCK * BLOCKS_TO_MBLOCKS(bd->blocks);
 732       // The caller of this function, memInventory(), expects to match
 733       // the total number of blocks in the system against mblocks *
 734       // BLOCKS_PER_MBLOCK, so we must subtract the space for the
 735       // block descriptors from *every* mblock.
 736   }
 737   return total_blocks;
 738 }
 739
 740 void
 741 markBlocks (bdescr *bd)
 742 {
 743     for (; bd != NULL; bd = bd->link) {
 744         bd->flags |= BF_KNOWN;
 745     }
 746 }
 747
 748 void
 749 reportUnmarkedBlocks (void)
 750 {
 751     void *mblock;
 752     bdescr *bd;
 753
 754     debugBelch("Unreachable blocks:\n");
 755     for (mblock = getFirstMBlock(); mblock != NULL;
 756          mblock = getNextMBlock(mblock)) {
 757         for (bd = FIRST_BDESCR(mblock); bd <= LAST_BDESCR(mblock); ) {
 758             if (!(bd->flags & BF_KNOWN) && bd->free != (P_)-1) {
 759                 debugBelch("  %p\n",bd);
 760             }
 761             if (bd->blocks >= BLOCKS_PER_MBLOCK) {
 762                 mblock = (StgWord8*)mblock +
 763                     (BLOCKS_TO_MBLOCKS(bd->blocks) - 1) * MBLOCK_SIZE;
 764                 break;
 765             } else {
 766                 bd += bd->blocks;
 767             }
 768         }
 769     }
 770 }
 771
 772 #endif