ghc/rts/Storage.c

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