ghc/rts/Storage.c

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