ghc/rts/Storage.c

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