ghc/rts/Storage.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: Storage.c,v 1.24 2000/04/14 15:18:07 sewardj 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     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 fprintf(stderr, "--- checkSanity %d\n", N );
 716   if (0&&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