ghc/rts/Storage.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: Storage.c,v 1.40 2001/07/23 10:47:16 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     }
 152   }
 153
 154   /* Set up the destination pointers in each younger gen. step */
 155   for (g = 0; g < RtsFlags.GcFlags.generations-1; g++) {
 156     for (s = 0; s < generations[g].n_steps-1; s++) {
 157       generations[g].steps[s].to = &generations[g].steps[s+1];
 158     }
 159     generations[g].steps[s].to = &generations[g+1].steps[0];
 160   }
 161
 162   /* The oldest generation has one step and its destination is the
 163    * same 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, stat_describe_gens());
 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->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_space  = NULL;
 309   MainRegTable.rNursery        = g0s0->blocks;
 310   MainRegTable.rCurrentNursery = g0s0->blocks;
 311   /* hp, hpLim, hp_bd, to_space etc. aren't used in G0S0 */
 312 #endif
 313 }
 314
 315 void
 316 resetNurseries( void )
 317 {
 318   bdescr *bd;
 319 #ifdef SMP
 320   Capability *cap;
 321
 322   /* All tasks must be stopped */
 323   ASSERT(n_free_capabilities == RtsFlags.ParFlags.nNodes);
 324
 325   for (cap = free_capabilities; cap != NULL; cap = cap->link) {
 326     for (bd = cap->rNursery; bd; bd = bd->link) {
 327       bd->free = bd->start;
 328       ASSERT(bd->gen_no == 0);
 329       ASSERT(bd->step == g0s0);
 330       IF_DEBUG(sanity,memset(bd->start, 0xaa, BLOCK_SIZE));
 331     }
 332     cap->rCurrentNursery = cap->rNursery;
 333   }
 334 #else
 335   for (bd = g0s0->blocks; bd; bd = bd->link) {
 336     bd->free = bd->start;
 337     ASSERT(bd->gen_no == 0);
 338     ASSERT(bd->step == g0s0);
 339     IF_DEBUG(sanity,memset(bd->start, 0xaa, BLOCK_SIZE));
 340   }
 341   MainRegTable.rNursery = g0s0->blocks;
 342   MainRegTable.rCurrentNursery = g0s0->blocks;
 343 #endif
 344 }
 345
 346 bdescr *
 347 allocNursery (bdescr *last_bd, nat blocks)
 348 {
 349   bdescr *bd;
 350   nat i;
 351
 352   /* Allocate a nursery */
 353   for (i=0; i < blocks; i++) {
 354     bd = allocBlock();
 355     bd->link = last_bd;
 356     bd->step = g0s0;
 357     bd->gen_no = 0;
 358     bd->evacuated = 0;
 359     bd->free = bd->start;
 360     last_bd = bd;
 361   }
 362   return last_bd;
 363 }
 364
 365 void
 366 resizeNursery ( nat blocks )
 367 {
 368   bdescr *bd;
 369
 370 #ifdef SMP
 371   barf("resizeNursery: can't resize in SMP mode");
 372 #endif
 373
 374   if (nursery_blocks == blocks) {
 375     ASSERT(g0s0->n_blocks == blocks);
 376     return;
 377   }
 378
 379   else if (nursery_blocks < blocks) {
 380     IF_DEBUG(gc, fprintf(stderr, "Increasing size of nursery to %d blocks\n",
 381                          blocks));
 382     g0s0->blocks = allocNursery(g0s0->blocks, blocks-nursery_blocks);
 383   }
 384
 385   else {
 386     bdescr *next_bd;
 387
 388     IF_DEBUG(gc, fprintf(stderr, "Decreasing size of nursery to %d blocks\n",
 389                          blocks));
 390     for (bd = g0s0->blocks; nursery_blocks > blocks; nursery_blocks--) {
 391       next_bd = bd->link;
 392       freeGroup(bd);
 393       bd = next_bd;
 394     }
 395     g0s0->blocks = bd;
 396   }
 397
 398   g0s0->n_blocks = nursery_blocks = blocks;
 399 }
 400
 401 /* -----------------------------------------------------------------------------
 402    The allocate() interface
 403
 404    allocate(n) always succeeds, and returns a chunk of memory n words
 405    long.  n can be larger than the size of a block if necessary, in
 406    which case a contiguous block group will be allocated.
 407    -------------------------------------------------------------------------- */
 408
 409 StgPtr
 410 allocate(nat n)
 411 {
 412   bdescr *bd;
 413   StgPtr p;
 414
 415   ACQUIRE_LOCK(&sm_mutex);
 416
 417   TICK_ALLOC_HEAP_NOCTR(n);
 418   CCS_ALLOC(CCCS,n);
 419
 420   /* big allocation (>LARGE_OBJECT_THRESHOLD) */
 421   /* ToDo: allocate directly into generation 1 */
 422   if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
 423     nat req_blocks =  (lnat)BLOCK_ROUND_UP(n*sizeof(W_)) / BLOCK_SIZE;
 424     bd = allocGroup(req_blocks);
 425     dbl_link_onto(bd, &g0s0->large_objects);
 426     bd->gen_no  = 0;
 427     bd->step = g0s0;
 428     bd->evacuated = 0;
 429     bd->free = bd->start;
 430     /* don't add these blocks to alloc_blocks, since we're assuming
 431      * that large objects are likely to remain live for quite a while
 432      * (eg. running threads), so garbage collecting early won't make
 433      * much difference.
 434      */
 435     alloc_blocks += req_blocks;
 436     RELEASE_LOCK(&sm_mutex);
 437     return bd->start;
 438
 439   /* small allocation (<LARGE_OBJECT_THRESHOLD) */
 440   } else if (small_alloc_list == NULL || alloc_Hp + n > alloc_HpLim) {
 441     if (small_alloc_list) {
 442       small_alloc_list->free = alloc_Hp;
 443     }
 444     bd = allocBlock();
 445     bd->link = small_alloc_list;
 446     small_alloc_list = bd;
 447     bd->gen_no = 0;
 448     bd->step = g0s0;
 449     bd->evacuated = 0;
 450     alloc_Hp = bd->start;
 451     alloc_HpLim = bd->start + BLOCK_SIZE_W;
 452     alloc_blocks++;
 453   }
 454
 455   p = alloc_Hp;
 456   alloc_Hp += n;
 457   RELEASE_LOCK(&sm_mutex);
 458   return p;
 459 }
 460
 461 lnat allocated_bytes(void)
 462 {
 463   return (alloc_blocks * BLOCK_SIZE_W - (alloc_HpLim - alloc_Hp));
 464 }
 465
 466 /* -----------------------------------------------------------------------------
 467    Allocation functions for GMP.
 468
 469    These all use the allocate() interface - we can't have any garbage
 470    collection going on during a gmp operation, so we use allocate()
 471    which always succeeds.  The gmp operations which might need to
 472    allocate will ask the storage manager (via doYouWantToGC()) whether
 473    a garbage collection is required, in case we get into a loop doing
 474    only allocate() style allocation.
 475    -------------------------------------------------------------------------- */
 476
 477 static void *
 478 stgAllocForGMP (size_t size_in_bytes)
 479 {
 480   StgArrWords* arr;
 481   nat data_size_in_words, total_size_in_words;
 482
 483   /* should be a multiple of sizeof(StgWord) (whole no. of limbs) */
 484   ASSERT(size_in_bytes % sizeof(W_) == 0);
 485
 486   data_size_in_words  = size_in_bytes / sizeof(W_);
 487   total_size_in_words = sizeofW(StgArrWords) + data_size_in_words;
 488
 489   /* allocate and fill it in. */
 490   arr = (StgArrWords *)allocate(total_size_in_words);
 491   SET_ARR_HDR(arr, &stg_ARR_WORDS_info, CCCS, data_size_in_words);
 492
 493   /* and return a ptr to the goods inside the array */
 494   return(BYTE_ARR_CTS(arr));
 495 }
 496
 497 static void *
 498 stgReallocForGMP (void *ptr, size_t old_size, size_t new_size)
 499 {
 500     void *new_stuff_ptr = stgAllocForGMP(new_size);
 501     nat i = 0;
 502     char *p = (char *) ptr;
 503     char *q = (char *) new_stuff_ptr;
 504
 505     for (; i < old_size; i++, p++, q++) {
 506         *q = *p;
 507     }
 508
 509     return(new_stuff_ptr);
 510 }
 511
 512 static void
 513 stgDeallocForGMP (void *ptr STG_UNUSED,
 514                   size_t size STG_UNUSED)
 515 {
 516     /* easy for us: the garbage collector does the dealloc'n */
 517 }
 518
 519 /* -----------------------------------------------------------------------------
 520  * Stats and stuff
 521  * -------------------------------------------------------------------------- */
 522
 523 /* -----------------------------------------------------------------------------
 524  * calcAllocated()
 525  *
 526  * Approximate how much we've allocated: number of blocks in the
 527  * nursery + blocks allocated via allocate() - unused nusery blocks.
 528  * This leaves a little slop at the end of each block, and doesn't
 529  * take into account large objects (ToDo).
 530  * -------------------------------------------------------------------------- */
 531
 532 lnat
 533 calcAllocated( void )
 534 {
 535   nat allocated;
 536   bdescr *bd;
 537
 538 #ifdef SMP
 539   Capability *cap;
 540
 541   /* All tasks must be stopped.  Can't assert that all the
 542      capabilities are owned by the scheduler, though: one or more
 543      tasks might have been stopped while they were running (non-main)
 544      threads. */
 545   /*  ASSERT(n_free_capabilities == RtsFlags.ParFlags.nNodes); */
 546
 547   allocated =
 548     n_free_capabilities * RtsFlags.GcFlags.minAllocAreaSize * BLOCK_SIZE_W
 549     + allocated_bytes();
 550
 551   for (cap = free_capabilities; cap != NULL; cap = cap->link) {
 552     for ( bd = cap->rCurrentNursery->link; bd != NULL; bd = bd->link ) {
 553       allocated -= BLOCK_SIZE_W;
 554     }
 555     if (cap->rCurrentNursery->free < cap->rCurrentNursery->start
 556         + BLOCK_SIZE_W) {
 557       allocated -= (cap->rCurrentNursery->start + BLOCK_SIZE_W)
 558         - cap->rCurrentNursery->free;
 559     }
 560   }
 561
 562 #else /* !SMP */
 563   bdescr *current_nursery = MainRegTable.rCurrentNursery;
 564
 565   allocated = (nursery_blocks * BLOCK_SIZE_W) + allocated_bytes();
 566   for ( bd = current_nursery->link; bd != NULL; bd = bd->link ) {
 567     allocated -= BLOCK_SIZE_W;
 568   }
 569   if (current_nursery->free < current_nursery->start + BLOCK_SIZE_W) {
 570     allocated -= (current_nursery->start + BLOCK_SIZE_W)
 571       - current_nursery->free;
 572   }
 573 #endif
 574
 575   total_allocated += allocated;
 576   return allocated;
 577 }
 578
 579 /* Approximate the amount of live data in the heap.  To be called just
 580  * after garbage collection (see GarbageCollect()).
 581  */
 582 extern lnat
 583 calcLive(void)
 584 {
 585   nat g, s;
 586   lnat live = 0;
 587   step *stp;
 588
 589   if (RtsFlags.GcFlags.generations == 1) {
 590     live = (g0s0->to_blocks - 1) * BLOCK_SIZE_W +
 591       ((lnat)g0s0->hp_bd->free - (lnat)g0s0->hp_bd->start) / sizeof(W_);
 592     return live;
 593   }
 594
 595   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 596     for (s = 0; s < generations[g].n_steps; s++) {
 597       /* approximate amount of live data (doesn't take into account slop
 598        * at end of each block).
 599        */
 600       if (g == 0 && s == 0) {
 601           continue;
 602       }
 603       stp = &generations[g].steps[s];
 604       live += (stp->n_blocks - 1) * BLOCK_SIZE_W +
 605         ((lnat)stp->hp_bd->free - (lnat)stp->hp_bd->start) / sizeof(W_);
 606     }
 607   }
 608   return live;
 609 }
 610
 611 /* Approximate the number of blocks that will be needed at the next
 612  * garbage collection.
 613  *
 614  * Assume: all data currently live will remain live.  Steps that will
 615  * be collected next time will therefore need twice as many blocks
 616  * since all the data will be copied.
 617  */
 618 extern lnat
 619 calcNeeded(void)
 620 {
 621   lnat needed = 0;
 622   nat g, s;
 623   step *stp;
 624
 625   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 626     for (s = 0; s < generations[g].n_steps; s++) {
 627       if (g == 0 && s == 0) { continue; }
 628       stp = &generations[g].steps[s];
 629       if (generations[g].steps[0].n_blocks > generations[g].max_blocks) {
 630         needed += 2 * stp->n_blocks;
 631       } else {
 632         needed += stp->n_blocks;
 633       }
 634     }
 635   }
 636   return needed;
 637 }
 638
 639 /* -----------------------------------------------------------------------------
 640    Debugging
 641
 642    memInventory() checks for memory leaks by counting up all the
 643    blocks we know about and comparing that to the number of blocks
 644    allegedly floating around in the system.
 645    -------------------------------------------------------------------------- */
 646
 647 #ifdef DEBUG
 648
 649 extern void
 650 memInventory(void)
 651 {
 652   nat g, s;
 653   step *stp;
 654   bdescr *bd;
 655   lnat total_blocks = 0, free_blocks = 0;
 656
 657   /* count the blocks we current have */
 658
 659   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 660     for (s = 0; s < generations[g].n_steps; s++) {
 661       stp = &generations[g].steps[s];
 662       total_blocks += stp->n_blocks;
 663       if (RtsFlags.GcFlags.generations == 1) {
 664         /* two-space collector has a to-space too :-) */
 665         total_blocks += g0s0->to_blocks;
 666       }
 667       for (bd = stp->large_objects; bd; bd = bd->link) {
 668         total_blocks += bd->blocks;
 669         /* hack for megablock groups: they have an extra block or two in
 670            the second and subsequent megablocks where the block
 671            descriptors would normally go.
 672         */
 673         if (bd->blocks > BLOCKS_PER_MBLOCK) {
 674           total_blocks -= (MBLOCK_SIZE / BLOCK_SIZE - BLOCKS_PER_MBLOCK)
 675                           * (bd->blocks/(MBLOCK_SIZE/BLOCK_SIZE));
 676         }
 677       }
 678     }
 679   }
 680
 681   /* any blocks held by allocate() */
 682   for (bd = small_alloc_list; bd; bd = bd->link) {
 683     total_blocks += bd->blocks;
 684   }
 685   for (bd = large_alloc_list; bd; bd = bd->link) {
 686     total_blocks += bd->blocks;
 687   }
 688
 689   /* count the blocks on the free list */
 690   free_blocks = countFreeList();
 691
 692   ASSERT(total_blocks + free_blocks == mblocks_allocated * BLOCKS_PER_MBLOCK);
 693
 694 #if 0
 695   if (total_blocks + free_blocks != mblocks_allocated *
 696       BLOCKS_PER_MBLOCK) {
 697     fprintf(stderr, "Blocks: %ld live + %ld free  = %ld total (%ld around)\n",
 698             total_blocks, free_blocks, total_blocks + free_blocks,
 699             mblocks_allocated * BLOCKS_PER_MBLOCK);
 700   }
 701 #endif
 702 }
 703
 704 /* Full heap sanity check. */
 705
 706 extern void
 707 checkSanity(nat N)
 708 {
 709   nat g, s;
 710
 711   if (RtsFlags.GcFlags.generations == 1) {
 712     checkHeap(g0s0->to_space, NULL);
 713     checkChain(g0s0->large_objects);
 714   } else {
 715
 716     for (g = 0; g <= N; g++) {
 717       for (s = 0; s < generations[g].n_steps; s++) {
 718         if (g == 0 && s == 0) { continue; }
 719         checkHeap(generations[g].steps[s].blocks, NULL);
 720       }
 721     }
 722     for (g = N+1; g < RtsFlags.GcFlags.generations; g++) {
 723       for (s = 0; s < generations[g].n_steps; s++) {
 724         checkHeap(generations[g].steps[s].blocks,
 725                   generations[g].steps[s].blocks->start);
 726         checkChain(generations[g].steps[s].large_objects);
 727       }
 728     }
 729     checkFreeListSanity();
 730   }
 731 }
 732
 733 #endif