ghc/rts/Storage.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: Storage.c,v 1.34 2001/01/29 17:23:41 simonmar Exp $
   3  *
   4  * (c) The GHC Team, 1998-1999
   5  *
   6  * Storage manager front end
   7  *
   8  * ---------------------------------------------------------------------------*/
   9
  10 #include "Rts.h"
  11 #include "RtsUtils.h"
  12 #include "RtsFlags.h"
  13 #include "Stats.h"
  14 #include "Hooks.h"
  15 #include "BlockAlloc.h"
  16 #include "MBlock.h"
  17 #include "Weak.h"
  18 #include "Sanity.h"
  19
  20 #include "Storage.h"
  21 #include "Schedule.h"
  22 #include "StoragePriv.h"
  23
  24 #ifndef SMP
  25 nat nursery_blocks;             /* number of blocks in the nursery */
  26 #endif
  27
  28 StgClosure    *caf_list         = NULL;
  29
  30 bdescr *small_alloc_list;       /* allocate()d small objects */
  31 bdescr *large_alloc_list;       /* allocate()d large objects */
  32 nat alloc_blocks;               /* number of allocate()d blocks since GC */
  33 nat alloc_blocks_lim;           /* approximate limit on alloc_blocks */
  34
  35 StgPtr alloc_Hp    = NULL;      /* next free byte in small_alloc_list */
  36 StgPtr alloc_HpLim = NULL;      /* end of block at small_alloc_list   */
  37
  38 generation *generations;        /* all the generations */
  39 generation *g0;                 /* generation 0, for convenience */
  40 generation *oldest_gen;         /* oldest generation, for convenience */
  41 step *g0s0;                     /* generation 0, step 0, for convenience */
  42
  43 lnat total_allocated = 0;       /* total memory allocated during run */
  44
  45 /*
  46  * Storage manager mutex:  protects all the above state from
  47  * simultaneous access by two STG threads.
  48  */
  49 #ifdef SMP
  50 pthread_mutex_t sm_mutex = PTHREAD_MUTEX_INITIALIZER;
  51 #endif
  52
  53 /*
  54  * Forward references
  55  */
  56 static void *stgAllocForGMP   (size_t size_in_bytes);
  57 static void *stgReallocForGMP (void *ptr, size_t old_size, size_t new_size);
  58 static void  stgDeallocForGMP (void *ptr, size_t size);
  59
  60 void
  61 initStorage (void)
  62 {
  63   nat g, s;
  64   step *stp;
  65   generation *gen;
  66
  67   /* If we're doing heap profiling, we want a two-space heap with a
  68    * fixed-size allocation area so that we get roughly even-spaced
  69    * samples.
  70    */
  71 #if defined(PROFILING) || defined(DEBUG)
  72   if (RtsFlags.ProfFlags.doHeapProfile) {
  73     RtsFlags.GcFlags.generations = 1;
  74     RtsFlags.GcFlags.steps = 1;
  75     RtsFlags.GcFlags.oldGenFactor = 0;
  76     RtsFlags.GcFlags.heapSizeSuggestion = 0;
  77   }
  78 #endif
  79
  80   if (RtsFlags.GcFlags.heapSizeSuggestion >
  81       RtsFlags.GcFlags.maxHeapSize) {
  82     RtsFlags.GcFlags.maxHeapSize = RtsFlags.GcFlags.heapSizeSuggestion;
  83   }
  84
  85   initBlockAllocator();
  86
  87   /* allocate generation info array */
  88   generations = (generation *)stgMallocBytes(RtsFlags.GcFlags.generations
  89                                              * sizeof(struct _generation),
  90                                              "initStorage: gens");
  91
  92   /* Initialise all generations */
  93   for(g = 0; g < RtsFlags.GcFlags.generations; g++) {
  94     gen = &generations[g];
  95     gen->no = g;
  96     gen->mut_list = END_MUT_LIST;
  97     gen->mut_once_list = END_MUT_LIST;
  98     gen->collections = 0;
  99     gen->failed_promotions = 0;
 100     gen->max_blocks = 0;
 101   }
 102
 103   /* A couple of convenience pointers */
 104   g0 = &generations[0];
 105   oldest_gen = &generations[RtsFlags.GcFlags.generations-1];
 106
 107   /* Allocate step structures in each generation */
 108   if (RtsFlags.GcFlags.generations > 1) {
 109     /* Only for multiple-generations */
 110
 111     /* Oldest generation: one step */
 112     oldest_gen->n_steps = 1;
 113     oldest_gen->steps =
 114       stgMallocBytes(1 * sizeof(struct _step), "initStorage: last step");
 115
 116     /* set up all except the oldest generation with 2 steps */
 117     for(g = 0; g < RtsFlags.GcFlags.generations-1; g++) {
 118       generations[g].n_steps = RtsFlags.GcFlags.steps;
 119       generations[g].steps  =
 120         stgMallocBytes (RtsFlags.GcFlags.steps * sizeof(struct _step),
 121                         "initStorage: steps");
 122     }
 123
 124   } else {
 125     /* single generation, i.e. a two-space collector */
 126     g0->n_steps = 1;
 127     g0->steps = stgMallocBytes (sizeof(struct _step), "initStorage: steps");
 128   }
 129
 130   /* Initialise all steps */
 131   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 132     for (s = 0; s < generations[g].n_steps; s++) {
 133       stp = &generations[g].steps[s];
 134       stp->no = s;
 135       stp->blocks = NULL;
 136       stp->n_blocks = 0;
 137       stp->gen = &generations[g];
 138       stp->hp = NULL;
 139       stp->hpLim = NULL;
 140       stp->hp_bd = NULL;
 141       stp->scan = NULL;
 142       stp->scan_bd = NULL;
 143       stp->large_objects = NULL;
 144       stp->new_large_objects = NULL;
 145       stp->scavenged_large_objects = NULL;
 146     }
 147   }
 148
 149   /* Set up the destination pointers in each younger gen. step */
 150   for (g = 0; g < RtsFlags.GcFlags.generations-1; g++) {
 151     for (s = 0; s < generations[g].n_steps-1; s++) {
 152       generations[g].steps[s].to = &generations[g].steps[s+1];
 153     }
 154     generations[g].steps[s].to = &generations[g+1].steps[0];
 155   }
 156
 157   /* The oldest generation has one step and its destination is the
 158    * same step. */
 159   oldest_gen->steps[0].to = &oldest_gen->steps[0];
 160
 161   /* generation 0 is special: that's the nursery */
 162   generations[0].max_blocks = 0;
 163
 164   /* G0S0: the allocation area.  Policy: keep the allocation area
 165    * small to begin with, even if we have a large suggested heap
 166    * size.  Reason: we're going to do a major collection first, and we
 167    * don't want it to be a big one.  This vague idea is borne out by
 168    * rigorous experimental evidence.
 169    */
 170   g0s0 = &generations[0].steps[0];
 171
 172   allocNurseries();
 173
 174   weak_ptr_list = NULL;
 175   caf_list = NULL;
 176
 177   /* initialise the allocate() interface */
 178   small_alloc_list = NULL;
 179   large_alloc_list = NULL;
 180   alloc_blocks = 0;
 181   alloc_blocks_lim = RtsFlags.GcFlags.minAllocAreaSize;
 182
 183   /* Tell GNU multi-precision pkg about our custom alloc functions */
 184   mp_set_memory_functions(stgAllocForGMP, stgReallocForGMP, stgDeallocForGMP);
 185
 186 #ifdef SMP
 187   pthread_mutex_init(&sm_mutex, NULL);
 188 #endif
 189
 190   IF_DEBUG(gc, stat_describe_gens());
 191 }
 192
 193 void
 194 exitStorage (void)
 195 {
 196     stat_exit(calcAllocated());
 197 }
 198
 199 /* -----------------------------------------------------------------------------
 200    CAF management.
 201
 202    The entry code for every CAF does the following:
 203
 204       - builds a CAF_BLACKHOLE in the heap
 205       - pushes an update frame pointing to the CAF_BLACKHOLE
 206       - invokes UPD_CAF(), which:
 207           - calls newCaf, below
 208           - updates the CAF with a static indirection to the CAF_BLACKHOLE
 209
 210    Why do we build a BLACKHOLE in the heap rather than just updating
 211    the thunk directly?  It's so that we only need one kind of update
 212    frame - otherwise we'd need a static version of the update frame too.
 213
 214    newCaf() does the following:
 215
 216       - it puts the CAF on the oldest generation's mut-once list.
 217         This is so that we can treat the CAF as a root when collecting
 218         younger generations.
 219
 220    For GHCI, we have additional requirements when dealing with CAFs:
 221
 222       - we must *retain* all dynamically-loaded CAFs ever entered,
 223         just in case we need them again.
 224       - we must be able to *revert* CAFs that have been evaluated, to
 225         their pre-evaluated form.
 226
 227       To do this, we use an additional CAF list.  When newCaf() is
 228       called on a dynamically-loaded CAF, we add it to the CAF list
 229       instead of the old-generation mutable list, and save away its
 230       old info pointer (in caf->saved_info) for later reversion.
 231
 232       To revert all the CAFs, we traverse the CAF list and reset the
 233       info pointer to caf->saved_info, then throw away the CAF list.
 234       (see GC.c:revertCAFs()).
 235
 236       -- SDM 29/1/01
 237
 238    -------------------------------------------------------------------------- */
 239
 240 void
 241 newCAF(StgClosure* caf)
 242 {
 243   /* Put this CAF on the mutable list for the old generation.
 244    * This is a HACK - the IND_STATIC closure doesn't really have
 245    * a mut_link field, but we pretend it has - in fact we re-use
 246    * the STATIC_LINK field for the time being, because when we
 247    * come to do a major GC we won't need the mut_link field
 248    * any more and can use it as a STATIC_LINK.
 249    */
 250   ACQUIRE_LOCK(&sm_mutex);
 251
 252 #ifdef GHCI
 253   if (is_dynamically_loaded_rwdata_ptr((StgPtr)caf)) {
 254       ((StgIndStatic *)caf)->saved_info  = (StgInfoTable *)caf->header.info;
 255       ((StgIndStatic *)caf)->static_link = caf_list;
 256       caf_list = caf;
 257   } else {
 258       ((StgIndStatic *)caf)->saved_info = NULL;
 259       ((StgMutClosure *)caf)->mut_link = oldest_gen->mut_once_list;
 260       oldest_gen->mut_once_list = (StgMutClosure *)caf;
 261   }
 262 #else
 263   ASSERT( ((StgMutClosure*)caf)->mut_link == NULL );
 264   ((StgMutClosure *)caf)->mut_link = oldest_gen->mut_once_list;
 265   oldest_gen->mut_once_list = (StgMutClosure *)caf;
 266 #endif
 267
 268   RELEASE_LOCK(&sm_mutex);
 269 }
 270
 271 #ifdef GHCI
 272 void
 273 markCafs( void )
 274 {
 275     StgClosure *p;
 276
 277     for (p = caf_list; p != NULL; p = STATIC_LINK2(get_itbl(p),p)) {
 278         MarkRoot(p);
 279     }
 280 }
 281 #endif /* GHCI */
 282
 283 /* -----------------------------------------------------------------------------
 284    Nursery management.
 285    -------------------------------------------------------------------------- */
 286
 287 void
 288 allocNurseries( void )
 289 {
 290 #ifdef SMP
 291   {
 292     Capability *cap;
 293     bdescr *bd;
 294
 295     g0s0->blocks = NULL;
 296     g0s0->n_blocks = 0;
 297     for (cap = free_capabilities; cap != NULL; cap = cap->link) {
 298       cap->rNursery = allocNursery(NULL, RtsFlags.GcFlags.minAllocAreaSize);
 299       cap->rCurrentNursery = cap->rNursery;
 300       for (bd = cap->rNursery; bd != NULL; bd = bd->link) {
 301         bd->back = (bdescr *)cap;
 302       }
 303     }
 304     /* Set the back links to be equal to the Capability,
 305      * so we can do slightly better informed locking.
 306      */
 307   }
 308 #else /* SMP */
 309   nursery_blocks  = RtsFlags.GcFlags.minAllocAreaSize;
 310   g0s0->blocks    = allocNursery(NULL, nursery_blocks);
 311   g0s0->n_blocks  = nursery_blocks;
 312   g0s0->to_space  = NULL;
 313   MainRegTable.rNursery        = g0s0->blocks;
 314   MainRegTable.rCurrentNursery = g0s0->blocks;
 315   /* hp, hpLim, hp_bd, to_space etc. aren't used in G0S0 */
 316 #endif
 317 }
 318
 319 void
 320 resetNurseries( void )
 321 {
 322   bdescr *bd;
 323 #ifdef SMP
 324   Capability *cap;
 325
 326   /* All tasks must be stopped */
 327   ASSERT(n_free_capabilities == RtsFlags.ParFlags.nNodes);
 328
 329   for (cap = free_capabilities; cap != NULL; cap = cap->link) {
 330     for (bd = cap->rNursery; bd; bd = bd->link) {
 331       bd->free = bd->start;
 332       ASSERT(bd->gen == g0);
 333       ASSERT(bd->step == g0s0);
 334       IF_DEBUG(sanity,memset(bd->start, 0xaa, BLOCK_SIZE));
 335     }
 336     cap->rCurrentNursery = cap->rNursery;
 337   }
 338 #else
 339   for (bd = g0s0->blocks; bd; bd = bd->link) {
 340     bd->free = bd->start;
 341     ASSERT(bd->gen == g0);
 342     ASSERT(bd->step == g0s0);
 343     IF_DEBUG(sanity,memset(bd->start, 0xaa, BLOCK_SIZE));
 344   }
 345   MainRegTable.rNursery = g0s0->blocks;
 346   MainRegTable.rCurrentNursery = g0s0->blocks;
 347 #endif
 348 }
 349
 350 bdescr *
 351 allocNursery (bdescr *last_bd, nat blocks)
 352 {
 353   bdescr *bd;
 354   nat i;
 355
 356   /* Allocate a nursery */
 357   for (i=0; i < blocks; i++) {
 358     bd = allocBlock();
 359     bd->link = last_bd;
 360     bd->step = g0s0;
 361     bd->gen = g0;
 362     bd->evacuated = 0;
 363     bd->free = bd->start;
 364     last_bd = bd;
 365   }
 366   return last_bd;
 367 }
 368
 369 void
 370 resizeNursery ( nat blocks )
 371 {
 372   bdescr *bd;
 373
 374 #ifdef SMP
 375   barf("resizeNursery: can't resize in SMP mode");
 376 #endif
 377
 378   if (nursery_blocks == blocks) {
 379     ASSERT(g0s0->n_blocks == blocks);
 380     return;
 381   }
 382
 383   else if (nursery_blocks < blocks) {
 384     IF_DEBUG(gc, fprintf(stderr, "Increasing size of nursery to %d blocks\n",
 385                          blocks));
 386     g0s0->blocks = allocNursery(g0s0->blocks, blocks-nursery_blocks);
 387   }
 388
 389   else {
 390     bdescr *next_bd;
 391
 392     IF_DEBUG(gc, fprintf(stderr, "Decreasing size of nursery to %d blocks\n",
 393                          blocks));
 394     for (bd = g0s0->blocks; nursery_blocks > blocks; nursery_blocks--) {
 395       next_bd = bd->link;
 396       freeGroup(bd);
 397       bd = next_bd;
 398     }
 399     g0s0->blocks = bd;
 400   }
 401
 402   g0s0->n_blocks = nursery_blocks = blocks;
 403 }
 404
 405 /* -----------------------------------------------------------------------------
 406    The allocate() interface
 407
 408    allocate(n) always succeeds, and returns a chunk of memory n words
 409    long.  n can be larger than the size of a block if necessary, in
 410    which case a contiguous block group will be allocated.
 411    -------------------------------------------------------------------------- */
 412
 413 StgPtr
 414 allocate(nat n)
 415 {
 416   bdescr *bd;
 417   StgPtr p;
 418
 419   ACQUIRE_LOCK(&sm_mutex);
 420
 421   TICK_ALLOC_HEAP_NOCTR(n);
 422   CCS_ALLOC(CCCS,n);
 423
 424   /* big allocation (>LARGE_OBJECT_THRESHOLD) */
 425   /* ToDo: allocate directly into generation 1 */
 426   if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
 427     nat req_blocks =  (lnat)BLOCK_ROUND_UP(n*sizeof(W_)) / BLOCK_SIZE;
 428     bd = allocGroup(req_blocks);
 429     dbl_link_onto(bd, &g0s0->large_objects);
 430     bd->gen  = g0;
 431     bd->step = g0s0;
 432     bd->evacuated = 0;
 433     bd->free = bd->start;
 434     /* don't add these blocks to alloc_blocks, since we're assuming
 435      * that large objects are likely to remain live for quite a while
 436      * (eg. running threads), so garbage collecting early won't make
 437      * much difference.
 438      */
 439     alloc_blocks += req_blocks;
 440     RELEASE_LOCK(&sm_mutex);
 441     return bd->start;
 442
 443   /* small allocation (<LARGE_OBJECT_THRESHOLD) */
 444   } else if (small_alloc_list == NULL || alloc_Hp + n > alloc_HpLim) {
 445     if (small_alloc_list) {
 446       small_alloc_list->free = alloc_Hp;
 447     }
 448     bd = allocBlock();
 449     bd->link = small_alloc_list;
 450     small_alloc_list = bd;
 451     bd->gen = g0;
 452     bd->step = g0s0;
 453     bd->evacuated = 0;
 454     alloc_Hp = bd->start;
 455     alloc_HpLim = bd->start + BLOCK_SIZE_W;
 456     alloc_blocks++;
 457   }
 458
 459   p = alloc_Hp;
 460   alloc_Hp += n;
 461   RELEASE_LOCK(&sm_mutex);
 462   return p;
 463 }
 464
 465 lnat allocated_bytes(void)
 466 {
 467   return (alloc_blocks * BLOCK_SIZE_W - (alloc_HpLim - alloc_Hp));
 468 }
 469
 470 /* -----------------------------------------------------------------------------
 471    Allocation functions for GMP.
 472
 473    These all use the allocate() interface - we can't have any garbage
 474    collection going on during a gmp operation, so we use allocate()
 475    which always succeeds.  The gmp operations which might need to
 476    allocate will ask the storage manager (via doYouWantToGC()) whether
 477    a garbage collection is required, in case we get into a loop doing
 478    only allocate() style allocation.
 479    -------------------------------------------------------------------------- */
 480
 481 static void *
 482 stgAllocForGMP (size_t size_in_bytes)
 483 {
 484   StgArrWords* arr;
 485   nat data_size_in_words, total_size_in_words;
 486
 487   /* should be a multiple of sizeof(StgWord) (whole no. of limbs) */
 488   ASSERT(size_in_bytes % sizeof(W_) == 0);
 489
 490   data_size_in_words  = size_in_bytes / sizeof(W_);
 491   total_size_in_words = sizeofW(StgArrWords) + data_size_in_words;
 492
 493   /* allocate and fill it in. */
 494   arr = (StgArrWords *)allocate(total_size_in_words);
 495   SET_ARR_HDR(arr, &stg_ARR_WORDS_info, CCCS, data_size_in_words);
 496
 497   /* and return a ptr to the goods inside the array */
 498   return(BYTE_ARR_CTS(arr));
 499 }
 500
 501 static void *
 502 stgReallocForGMP (void *ptr, size_t old_size, size_t new_size)
 503 {
 504     void *new_stuff_ptr = stgAllocForGMP(new_size);
 505     nat i = 0;
 506     char *p = (char *) ptr;
 507     char *q = (char *) new_stuff_ptr;
 508
 509     for (; i < old_size; i++, p++, q++) {
 510         *q = *p;
 511     }
 512
 513     return(new_stuff_ptr);
 514 }
 515
 516 static void
 517 stgDeallocForGMP (void *ptr STG_UNUSED,
 518                   size_t size STG_UNUSED)
 519 {
 520     /* easy for us: the garbage collector does the dealloc'n */
 521 }
 522
 523 /* -----------------------------------------------------------------------------
 524  * Stats and stuff
 525  * -------------------------------------------------------------------------- */
 526
 527 /* -----------------------------------------------------------------------------
 528  * calcAllocated()
 529  *
 530  * Approximate how much we've allocated: number of blocks in the
 531  * nursery + blocks allocated via allocate() - unused nusery blocks.
 532  * This leaves a little slop at the end of each block, and doesn't
 533  * take into account large objects (ToDo).
 534  * -------------------------------------------------------------------------- */
 535
 536 lnat
 537 calcAllocated( void )
 538 {
 539   nat allocated;
 540   bdescr *bd;
 541
 542 #ifdef SMP
 543   Capability *cap;
 544
 545   /* All tasks must be stopped.  Can't assert that all the
 546      capabilities are owned by the scheduler, though: one or more
 547      tasks might have been stopped while they were running (non-main)
 548      threads. */
 549   /*  ASSERT(n_free_capabilities == RtsFlags.ParFlags.nNodes); */
 550
 551   allocated =
 552     n_free_capabilities * RtsFlags.GcFlags.minAllocAreaSize * BLOCK_SIZE_W
 553     + allocated_bytes();
 554
 555   for (cap = free_capabilities; cap != NULL; cap = cap->link) {
 556     for ( bd = cap->rCurrentNursery->link; bd != NULL; bd = bd->link ) {
 557       allocated -= BLOCK_SIZE_W;
 558     }
 559     if (cap->rCurrentNursery->free < cap->rCurrentNursery->start
 560         + BLOCK_SIZE_W) {
 561       allocated -= (cap->rCurrentNursery->start + BLOCK_SIZE_W)
 562         - cap->rCurrentNursery->free;
 563     }
 564   }
 565
 566 #else /* !SMP */
 567   bdescr *current_nursery = MainRegTable.rCurrentNursery;
 568
 569   allocated = (nursery_blocks * BLOCK_SIZE_W) + allocated_bytes();
 570   for ( bd = current_nursery->link; bd != NULL; bd = bd->link ) {
 571     allocated -= BLOCK_SIZE_W;
 572   }
 573   if (current_nursery->free < current_nursery->start + BLOCK_SIZE_W) {
 574     allocated -= (current_nursery->start + BLOCK_SIZE_W)
 575       - current_nursery->free;
 576   }
 577 #endif
 578
 579   total_allocated += allocated;
 580   return allocated;
 581 }
 582
 583 /* Approximate the amount of live data in the heap.  To be called just
 584  * after garbage collection (see GarbageCollect()).
 585  */
 586 extern lnat
 587 calcLive(void)
 588 {
 589   nat g, s;
 590   lnat live = 0;
 591   step *stp;
 592
 593   if (RtsFlags.GcFlags.generations == 1) {
 594     live = (g0s0->to_blocks - 1) * BLOCK_SIZE_W +
 595       ((lnat)g0s0->hp_bd->free - (lnat)g0s0->hp_bd->start) / sizeof(W_);
 596     return live;
 597   }
 598
 599   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 600     for (s = 0; s < generations[g].n_steps; s++) {
 601       /* approximate amount of live data (doesn't take into account slop
 602        * at end of each block).
 603        */
 604       if (g == 0 && s == 0) {
 605           continue;
 606       }
 607       stp = &generations[g].steps[s];
 608       live += (stp->n_blocks - 1) * BLOCK_SIZE_W +
 609         ((lnat)stp->hp_bd->free - (lnat)stp->hp_bd->start) / sizeof(W_);
 610     }
 611   }
 612   return live;
 613 }
 614
 615 /* Approximate the number of blocks that will be needed at the next
 616  * garbage collection.
 617  *
 618  * Assume: all data currently live will remain live.  Steps that will
 619  * be collected next time will therefore need twice as many blocks
 620  * since all the data will be copied.
 621  */
 622 extern lnat
 623 calcNeeded(void)
 624 {
 625   lnat needed = 0;
 626   nat g, s;
 627   step *stp;
 628
 629   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 630     for (s = 0; s < generations[g].n_steps; s++) {
 631       if (g == 0 && s == 0) { continue; }
 632       stp = &generations[g].steps[s];
 633       if (generations[g].steps[0].n_blocks > generations[g].max_blocks) {
 634         needed += 2 * stp->n_blocks;
 635       } else {
 636         needed += stp->n_blocks;
 637       }
 638     }
 639   }
 640   return needed;
 641 }
 642
 643 /* -----------------------------------------------------------------------------
 644    Debugging
 645
 646    memInventory() checks for memory leaks by counting up all the
 647    blocks we know about and comparing that to the number of blocks
 648    allegedly floating around in the system.
 649    -------------------------------------------------------------------------- */
 650
 651 #ifdef DEBUG
 652
 653 extern void
 654 memInventory(void)
 655 {
 656   nat g, s;
 657   step *stp;
 658   bdescr *bd;
 659   lnat total_blocks = 0, free_blocks = 0;
 660
 661   /* count the blocks we current have */
 662
 663   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 664     for (s = 0; s < generations[g].n_steps; s++) {
 665       stp = &generations[g].steps[s];
 666       total_blocks += stp->n_blocks;
 667       if (RtsFlags.GcFlags.generations == 1) {
 668         /* two-space collector has a to-space too :-) */
 669         total_blocks += g0s0->to_blocks;
 670       }
 671       for (bd = stp->large_objects; bd; bd = bd->link) {
 672         total_blocks += bd->blocks;
 673         /* hack for megablock groups: they have an extra block or two in
 674            the second and subsequent megablocks where the block
 675            descriptors would normally go.
 676         */
 677         if (bd->blocks > BLOCKS_PER_MBLOCK) {
 678           total_blocks -= (MBLOCK_SIZE / BLOCK_SIZE - BLOCKS_PER_MBLOCK)
 679                           * (bd->blocks/(MBLOCK_SIZE/BLOCK_SIZE));
 680         }
 681       }
 682     }
 683   }
 684
 685   /* any blocks held by allocate() */
 686   for (bd = small_alloc_list; bd; bd = bd->link) {
 687     total_blocks += bd->blocks;
 688   }
 689   for (bd = large_alloc_list; bd; bd = bd->link) {
 690     total_blocks += bd->blocks;
 691   }
 692
 693   /* count the blocks on the free list */
 694   free_blocks = countFreeList();
 695
 696   ASSERT(total_blocks + free_blocks == mblocks_allocated * BLOCKS_PER_MBLOCK);
 697
 698 #if 0
 699   if (total_blocks + free_blocks != mblocks_allocated *
 700       BLOCKS_PER_MBLOCK) {
 701     fprintf(stderr, "Blocks: %ld live + %ld free  = %ld total (%ld around)\n",
 702             total_blocks, free_blocks, total_blocks + free_blocks,
 703             mblocks_allocated * BLOCKS_PER_MBLOCK);
 704   }
 705 #endif
 706 }
 707
 708 /* Full heap sanity check. */
 709
 710 extern void
 711 checkSanity(nat N)
 712 {
 713   nat g, s;
 714
 715   if (RtsFlags.GcFlags.generations == 1) {
 716     checkHeap(g0s0->to_space, NULL);
 717     checkChain(g0s0->large_objects);
 718   } else {
 719
 720     for (g = 0; g <= N; g++) {
 721       for (s = 0; s < generations[g].n_steps; s++) {
 722         if (g == 0 && s == 0) { continue; }
 723         checkHeap(generations[g].steps[s].blocks, NULL);
 724       }
 725     }
 726     for (g = N+1; g < RtsFlags.GcFlags.generations; g++) {
 727       for (s = 0; s < generations[g].n_steps; s++) {
 728         checkHeap(generations[g].steps[s].blocks,
 729                   generations[g].steps[s].blocks->start);
 730         checkChain(generations[g].steps[s].large_objects);
 731       }
 732     }
 733     checkFreeListSanity();
 734   }
 735 }
 736
 737 #endif