ghc/rts/Storage.c

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