ghc/rts/Storage.c

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