ghc/rts/Storage.c

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