ghc/rts/Storage.c

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