ghc/rts/Storage.c

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