ghc/rts/Storage.c

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