ghc/rts/Storage.c

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