ghc/rts/Storage.c

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