ghc/rts/Storage.c

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