ghc/rts/Storage.c

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