ghc/rts/Storage.c

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