ghc/rts/Storage.c

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