ghc/rts/Storage.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: Storage.c,v 1.32 2001/01/16 12:02:04 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
 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, &stg_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   total_allocated += allocated;
 583   return allocated;
 584 }
 585
 586 /* Approximate the amount of live data in the heap.  To be called just
 587  * after garbage collection (see GarbageCollect()).
 588  */
 589 extern lnat
 590 calcLive(void)
 591 {
 592   nat g, s;
 593   lnat live = 0;
 594   step *stp;
 595
 596   if (RtsFlags.GcFlags.generations == 1) {
 597     live = (g0s0->to_blocks - 1) * BLOCK_SIZE_W +
 598       ((lnat)g0s0->hp_bd->free - (lnat)g0s0->hp_bd->start) / sizeof(W_);
 599     return live;
 600   }
 601
 602   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 603     for (s = 0; s < generations[g].n_steps; s++) {
 604       /* approximate amount of live data (doesn't take into account slop
 605        * at end of each block).
 606        */
 607       if (g == 0 && s == 0) {
 608           continue;
 609       }
 610       stp = &generations[g].steps[s];
 611       live += (stp->n_blocks - 1) * BLOCK_SIZE_W +
 612         ((lnat)stp->hp_bd->free - (lnat)stp->hp_bd->start) / sizeof(W_);
 613     }
 614   }
 615   return live;
 616 }
 617
 618 /* Approximate the number of blocks that will be needed at the next
 619  * garbage collection.
 620  *
 621  * Assume: all data currently live will remain live.  Steps that will
 622  * be collected next time will therefore need twice as many blocks
 623  * since all the data will be copied.
 624  */
 625 extern lnat
 626 calcNeeded(void)
 627 {
 628   lnat needed = 0;
 629   nat g, s;
 630   step *stp;
 631
 632   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 633     for (s = 0; s < generations[g].n_steps; s++) {
 634       if (g == 0 && s == 0) { continue; }
 635       stp = &generations[g].steps[s];
 636       if (generations[g].steps[0].n_blocks > generations[g].max_blocks) {
 637         needed += 2 * stp->n_blocks;
 638       } else {
 639         needed += stp->n_blocks;
 640       }
 641     }
 642   }
 643   return needed;
 644 }
 645
 646 /* -----------------------------------------------------------------------------
 647    Debugging
 648
 649    memInventory() checks for memory leaks by counting up all the
 650    blocks we know about and comparing that to the number of blocks
 651    allegedly floating around in the system.
 652    -------------------------------------------------------------------------- */
 653
 654 #ifdef DEBUG
 655
 656 extern void
 657 memInventory(void)
 658 {
 659   nat g, s;
 660   step *stp;
 661   bdescr *bd;
 662   lnat total_blocks = 0, free_blocks = 0;
 663
 664   /* count the blocks we current have */
 665
 666   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 667     for (s = 0; s < generations[g].n_steps; s++) {
 668       stp = &generations[g].steps[s];
 669       total_blocks += stp->n_blocks;
 670       if (RtsFlags.GcFlags.generations == 1) {
 671         /* two-space collector has a to-space too :-) */
 672         total_blocks += g0s0->to_blocks;
 673       }
 674       for (bd = stp->large_objects; bd; bd = bd->link) {
 675         total_blocks += bd->blocks;
 676         /* hack for megablock groups: they have an extra block or two in
 677            the second and subsequent megablocks where the block
 678            descriptors would normally go.
 679         */
 680         if (bd->blocks > BLOCKS_PER_MBLOCK) {
 681           total_blocks -= (MBLOCK_SIZE / BLOCK_SIZE - BLOCKS_PER_MBLOCK)
 682                           * (bd->blocks/(MBLOCK_SIZE/BLOCK_SIZE));
 683         }
 684       }
 685     }
 686   }
 687
 688   /* any blocks held by allocate() */
 689   for (bd = small_alloc_list; bd; bd = bd->link) {
 690     total_blocks += bd->blocks;
 691   }
 692   for (bd = large_alloc_list; bd; bd = bd->link) {
 693     total_blocks += bd->blocks;
 694   }
 695
 696   /* count the blocks on the free list */
 697   free_blocks = countFreeList();
 698
 699   ASSERT(total_blocks + free_blocks == mblocks_allocated * BLOCKS_PER_MBLOCK);
 700
 701 #if 0
 702   if (total_blocks + free_blocks != mblocks_allocated *
 703       BLOCKS_PER_MBLOCK) {
 704     fprintf(stderr, "Blocks: %ld live + %ld free  = %ld total (%ld around)\n",
 705             total_blocks, free_blocks, total_blocks + free_blocks,
 706             mblocks_allocated * BLOCKS_PER_MBLOCK);
 707   }
 708 #endif
 709 }
 710
 711 /* Full heap sanity check. */
 712
 713 extern void
 714 checkSanity(nat N)
 715 {
 716   nat g, s;
 717
 718   if (RtsFlags.GcFlags.generations == 1) {
 719     checkHeap(g0s0->to_space, NULL);
 720     checkChain(g0s0->large_objects);
 721   } else {
 722
 723     for (g = 0; g <= N; g++) {
 724       for (s = 0; s < generations[g].n_steps; s++) {
 725         if (g == 0 && s == 0) { continue; }
 726         checkHeap(generations[g].steps[s].blocks, NULL);
 727       }
 728     }
 729     for (g = N+1; g < RtsFlags.GcFlags.generations; g++) {
 730       for (s = 0; s < generations[g].n_steps; s++) {
 731         checkHeap(generations[g].steps[s].blocks,
 732                   generations[g].steps[s].blocks->start);
 733         checkChain(generations[g].steps[s].large_objects);
 734       }
 735     }
 736     checkFreeListSanity();
 737   }
 738 }
 739
 740 #endif