rts/sm/Storage.c

   1 /* -----------------------------------------------------------------------------
   2  *
   3  * (c) The GHC Team, 1998-2008
   4  *
   5  * Storage manager front end
   6  *
   7  * Documentation on the architecture of the Storage Manager can be
   8  * found in the online commentary:
   9  *
  10  *   http://hackage.haskell.org/trac/ghc/wiki/Commentary/Rts/Storage
  11  *
  12  * ---------------------------------------------------------------------------*/
  13
  14 #include "PosixSource.h"
  15 #include "Rts.h"
  16 #include "RtsUtils.h"
  17 #include "RtsFlags.h"
  18 #include "Stats.h"
  19 #include "Hooks.h"
  20 #include "BlockAlloc.h"
  21 #include "MBlock.h"
  22 #include "Weak.h"
  23 #include "Sanity.h"
  24 #include "Arena.h"
  25 #include "OSThreads.h"
  26 #include "Capability.h"
  27 #include "Storage.h"
  28 #include "Schedule.h"
  29 #include "RetainerProfile.h"    // for counting memory blocks (memInventory)
  30 #include "OSMem.h"
  31 #include "Trace.h"
  32 #include "GC.h"
  33 #include "Evac.h"
  34
  35 #include <stdlib.h>
  36 #include <string.h>
  37
  38 /*
  39  * All these globals require sm_mutex to access in THREADED_RTS mode.
  40  */
  41 StgClosure    *caf_list         = NULL;
  42 StgClosure    *revertible_caf_list = NULL;
  43 rtsBool       keepCAFs;
  44
  45 bdescr *pinned_object_block;    /* allocate pinned objects into this block */
  46 nat alloc_blocks;               /* number of allocate()d blocks since GC */
  47 nat alloc_blocks_lim;           /* approximate limit on alloc_blocks */
  48
  49 generation *generations = NULL; /* all the generations */
  50 generation *g0          = NULL; /* generation 0, for convenience */
  51 generation *oldest_gen  = NULL; /* oldest generation, for convenience */
  52 step *g0s0              = NULL; /* generation 0, step 0, for convenience */
  53
  54 nat total_steps         = 0;
  55 step *all_steps         = NULL; /* single array of steps */
  56
  57 ullong total_allocated = 0;     /* total memory allocated during run */
  58
  59 nat n_nurseries         = 0;    /* == RtsFlags.ParFlags.nNodes, convenience */
  60 step *nurseries         = NULL; /* array of nurseries, >1 only if THREADED_RTS */
  61
  62 #ifdef THREADED_RTS
  63 /*
  64  * Storage manager mutex:  protects all the above state from
  65  * simultaneous access by two STG threads.
  66  */
  67 Mutex sm_mutex;
  68 /*
  69  * This mutex is used by atomicModifyMutVar# only
  70  */
  71 Mutex atomic_modify_mutvar_mutex;
  72 #endif
  73
  74
  75 /*
  76  * Forward references
  77  */
  78 static void *stgAllocForGMP   (size_t size_in_bytes);
  79 static void *stgReallocForGMP (void *ptr, size_t old_size, size_t new_size);
  80 static void  stgDeallocForGMP (void *ptr, size_t size);
  81
  82 static void
  83 initStep (step *stp, int g, int s)
  84 {
  85     stp->no = s;
  86     stp->abs_no = RtsFlags.GcFlags.steps * g + s;
  87     stp->blocks = NULL;
  88     stp->n_blocks = 0;
  89     stp->n_words = 0;
  90     stp->old_blocks = NULL;
  91     stp->n_old_blocks = 0;
  92     stp->gen = &generations[g];
  93     stp->gen_no = g;
  94     stp->large_objects = NULL;
  95     stp->n_large_blocks = 0;
  96     stp->scavenged_large_objects = NULL;
  97     stp->n_scavenged_large_blocks = 0;
  98     stp->is_compacted = 0;
  99     stp->bitmap = NULL;
 100 #ifdef THREADED_RTS
 101     initSpinLock(&stp->sync_todo);
 102     initSpinLock(&stp->sync_large_objects);
 103 #endif
 104     stp->threads = END_TSO_QUEUE;
 105     stp->old_threads = END_TSO_QUEUE;
 106 }
 107
 108 void
 109 initStorage( void )
 110 {
 111   nat g, s;
 112   generation *gen;
 113
 114   if (generations != NULL) {
 115       // multi-init protection
 116       return;
 117   }
 118
 119   initMBlocks();
 120
 121   /* Sanity check to make sure the LOOKS_LIKE_ macros appear to be
 122    * doing something reasonable.
 123    */
 124   /* We use the NOT_NULL variant or gcc warns that the test is always true */
 125   ASSERT(LOOKS_LIKE_INFO_PTR_NOT_NULL(&stg_BLACKHOLE_info));
 126   ASSERT(LOOKS_LIKE_CLOSURE_PTR(&stg_dummy_ret_closure));
 127   ASSERT(!HEAP_ALLOCED(&stg_dummy_ret_closure));
 128
 129   if (RtsFlags.GcFlags.maxHeapSize != 0 &&
 130       RtsFlags.GcFlags.heapSizeSuggestion >
 131       RtsFlags.GcFlags.maxHeapSize) {
 132     RtsFlags.GcFlags.maxHeapSize = RtsFlags.GcFlags.heapSizeSuggestion;
 133   }
 134
 135   if (RtsFlags.GcFlags.maxHeapSize != 0 &&
 136       RtsFlags.GcFlags.minAllocAreaSize >
 137       RtsFlags.GcFlags.maxHeapSize) {
 138       errorBelch("maximum heap size (-M) is smaller than minimum alloc area size (-A)");
 139       RtsFlags.GcFlags.minAllocAreaSize = RtsFlags.GcFlags.maxHeapSize;
 140   }
 141
 142   initBlockAllocator();
 143
 144 #if defined(THREADED_RTS)
 145   initMutex(&sm_mutex);
 146   initMutex(&atomic_modify_mutvar_mutex);
 147 #endif
 148
 149   ACQUIRE_SM_LOCK;
 150
 151   /* allocate generation info array */
 152   generations = (generation *)stgMallocBytes(RtsFlags.GcFlags.generations
 153                                              * sizeof(struct generation_),
 154                                              "initStorage: gens");
 155
 156   /* allocate all the steps into an array.  It is important that we do
 157      it this way, because we need the invariant that two step pointers
 158      can be directly compared to see which is the oldest.
 159      Remember that the last generation has only one step. */
 160   total_steps = 1 + (RtsFlags.GcFlags.generations - 1) * RtsFlags.GcFlags.steps;
 161   all_steps   = stgMallocBytes(total_steps * sizeof(struct step_),
 162                                "initStorage: steps");
 163
 164   /* Initialise all generations */
 165   for(g = 0; g < RtsFlags.GcFlags.generations; g++) {
 166     gen = &generations[g];
 167     gen->no = g;
 168     gen->mut_list = allocBlock();
 169     gen->collections = 0;
 170     gen->par_collections = 0;
 171     gen->failed_promotions = 0;
 172     gen->max_blocks = 0;
 173   }
 174
 175   /* A couple of convenience pointers */
 176   g0 = &generations[0];
 177   oldest_gen = &generations[RtsFlags.GcFlags.generations-1];
 178
 179   /* Allocate step structures in each generation */
 180   if (RtsFlags.GcFlags.generations > 1) {
 181     /* Only for multiple-generations */
 182
 183     /* Oldest generation: one step */
 184     oldest_gen->n_steps = 1;
 185     oldest_gen->steps   = all_steps + (RtsFlags.GcFlags.generations - 1)
 186                                       * RtsFlags.GcFlags.steps;
 187
 188     /* set up all except the oldest generation with 2 steps */
 189     for(g = 0; g < RtsFlags.GcFlags.generations-1; g++) {
 190       generations[g].n_steps = RtsFlags.GcFlags.steps;
 191       generations[g].steps   = all_steps + g * RtsFlags.GcFlags.steps;
 192     }
 193
 194   } else {
 195     /* single generation, i.e. a two-space collector */
 196     g0->n_steps = 1;
 197     g0->steps   = all_steps;
 198   }
 199
 200 #ifdef THREADED_RTS
 201   n_nurseries = n_capabilities;
 202 #else
 203   n_nurseries = 1;
 204 #endif
 205   nurseries = stgMallocBytes (n_nurseries * sizeof(struct step_),
 206                               "initStorage: nurseries");
 207
 208   /* Initialise all steps */
 209   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 210     for (s = 0; s < generations[g].n_steps; s++) {
 211         initStep(&generations[g].steps[s], g, s);
 212     }
 213   }
 214
 215   for (s = 0; s < n_nurseries; s++) {
 216       initStep(&nurseries[s], 0, s);
 217   }
 218
 219   /* Set up the destination pointers in each younger gen. step */
 220   for (g = 0; g < RtsFlags.GcFlags.generations-1; g++) {
 221     for (s = 0; s < generations[g].n_steps-1; s++) {
 222       generations[g].steps[s].to = &generations[g].steps[s+1];
 223     }
 224     generations[g].steps[s].to = &generations[g+1].steps[0];
 225   }
 226   oldest_gen->steps[0].to = &oldest_gen->steps[0];
 227
 228   for (s = 0; s < n_nurseries; s++) {
 229       nurseries[s].to = generations[0].steps[0].to;
 230   }
 231
 232   /* The oldest generation has one step. */
 233   if (RtsFlags.GcFlags.compact) {
 234       if (RtsFlags.GcFlags.generations == 1) {
 235           errorBelch("WARNING: compaction is incompatible with -G1; disabled");
 236       } else {
 237           oldest_gen->steps[0].is_compacted = 1;
 238       }
 239   }
 240
 241   generations[0].max_blocks = 0;
 242   g0s0 = &generations[0].steps[0];
 243
 244   /* The allocation area.  Policy: keep the allocation area
 245    * small to begin with, even if we have a large suggested heap
 246    * size.  Reason: we're going to do a major collection first, and we
 247    * don't want it to be a big one.  This vague idea is borne out by
 248    * rigorous experimental evidence.
 249    */
 250   allocNurseries();
 251
 252   weak_ptr_list = NULL;
 253   caf_list = NULL;
 254   revertible_caf_list = NULL;
 255
 256   /* initialise the allocate() interface */
 257   alloc_blocks = 0;
 258   alloc_blocks_lim = RtsFlags.GcFlags.minAllocAreaSize;
 259
 260   /* Tell GNU multi-precision pkg about our custom alloc functions */
 261   mp_set_memory_functions(stgAllocForGMP, stgReallocForGMP, stgDeallocForGMP);
 262
 263 #ifdef THREADED_RTS
 264   initSpinLock(&gc_alloc_block_sync);
 265   initSpinLock(&recordMutableGen_sync);
 266   whitehole_spin = 0;
 267 #endif
 268
 269   IF_DEBUG(gc, statDescribeGens());
 270
 271   RELEASE_SM_LOCK;
 272 }
 273
 274 void
 275 exitStorage (void)
 276 {
 277     stat_exit(calcAllocated());
 278 }
 279
 280 void
 281 freeStorage (void)
 282 {
 283     stgFree(g0s0); // frees all the steps
 284     stgFree(generations);
 285     freeAllMBlocks();
 286 #if defined(THREADED_RTS)
 287     closeMutex(&sm_mutex);
 288     closeMutex(&atomic_modify_mutvar_mutex);
 289 #endif
 290     stgFree(nurseries);
 291 }
 292
 293 /* -----------------------------------------------------------------------------
 294    CAF management.
 295
 296    The entry code for every CAF does the following:
 297
 298       - builds a CAF_BLACKHOLE in the heap
 299       - pushes an update frame pointing to the CAF_BLACKHOLE
 300       - invokes UPD_CAF(), which:
 301           - calls newCaf, below
 302           - updates the CAF with a static indirection to the CAF_BLACKHOLE
 303
 304    Why do we build a BLACKHOLE in the heap rather than just updating
 305    the thunk directly?  It's so that we only need one kind of update
 306    frame - otherwise we'd need a static version of the update frame too.
 307
 308    newCaf() does the following:
 309
 310       - it puts the CAF on the oldest generation's mut-once list.
 311         This is so that we can treat the CAF as a root when collecting
 312         younger generations.
 313
 314    For GHCI, we have additional requirements when dealing with CAFs:
 315
 316       - we must *retain* all dynamically-loaded CAFs ever entered,
 317         just in case we need them again.
 318       - we must be able to *revert* CAFs that have been evaluated, to
 319         their pre-evaluated form.
 320
 321       To do this, we use an additional CAF list.  When newCaf() is
 322       called on a dynamically-loaded CAF, we add it to the CAF list
 323       instead of the old-generation mutable list, and save away its
 324       old info pointer (in caf->saved_info) for later reversion.
 325
 326       To revert all the CAFs, we traverse the CAF list and reset the
 327       info pointer to caf->saved_info, then throw away the CAF list.
 328       (see GC.c:revertCAFs()).
 329
 330       -- SDM 29/1/01
 331
 332    -------------------------------------------------------------------------- */
 333
 334 void
 335 newCAF(StgClosure* caf)
 336 {
 337   ACQUIRE_SM_LOCK;
 338
 339   if(keepCAFs)
 340   {
 341     // HACK:
 342     // If we are in GHCi _and_ we are using dynamic libraries,
 343     // then we can't redirect newCAF calls to newDynCAF (see below),
 344     // so we make newCAF behave almost like newDynCAF.
 345     // The dynamic libraries might be used by both the interpreted
 346     // program and GHCi itself, so they must not be reverted.
 347     // This also means that in GHCi with dynamic libraries, CAFs are not
 348     // garbage collected. If this turns out to be a problem, we could
 349     // do another hack here and do an address range test on caf to figure
 350     // out whether it is from a dynamic library.
 351     ((StgIndStatic *)caf)->saved_info  = (StgInfoTable *)caf->header.info;
 352     ((StgIndStatic *)caf)->static_link = caf_list;
 353     caf_list = caf;
 354   }
 355   else
 356   {
 357     /* Put this CAF on the mutable list for the old generation.
 358     * This is a HACK - the IND_STATIC closure doesn't really have
 359     * a mut_link field, but we pretend it has - in fact we re-use
 360     * the STATIC_LINK field for the time being, because when we
 361     * come to do a major GC we won't need the mut_link field
 362     * any more and can use it as a STATIC_LINK.
 363     */
 364     ((StgIndStatic *)caf)->saved_info = NULL;
 365     recordMutableGen(caf, oldest_gen);
 366   }
 367
 368   RELEASE_SM_LOCK;
 369 }
 370
 371 // An alternate version of newCaf which is used for dynamically loaded
 372 // object code in GHCi.  In this case we want to retain *all* CAFs in
 373 // the object code, because they might be demanded at any time from an
 374 // expression evaluated on the command line.
 375 // Also, GHCi might want to revert CAFs, so we add these to the
 376 // revertible_caf_list.
 377 //
 378 // The linker hackily arranges that references to newCaf from dynamic
 379 // code end up pointing to newDynCAF.
 380 void
 381 newDynCAF(StgClosure *caf)
 382 {
 383     ACQUIRE_SM_LOCK;
 384
 385     ((StgIndStatic *)caf)->saved_info  = (StgInfoTable *)caf->header.info;
 386     ((StgIndStatic *)caf)->static_link = revertible_caf_list;
 387     revertible_caf_list = caf;
 388
 389     RELEASE_SM_LOCK;
 390 }
 391
 392 /* -----------------------------------------------------------------------------
 393    Nursery management.
 394    -------------------------------------------------------------------------- */
 395
 396 static bdescr *
 397 allocNursery (step *stp, bdescr *tail, nat blocks)
 398 {
 399     bdescr *bd;
 400     nat i;
 401
 402     // Allocate a nursery: we allocate fresh blocks one at a time and
 403     // cons them on to the front of the list, not forgetting to update
 404     // the back pointer on the tail of the list to point to the new block.
 405     for (i=0; i < blocks; i++) {
 406         // @LDV profiling
 407         /*
 408           processNursery() in LdvProfile.c assumes that every block group in
 409           the nursery contains only a single block. So, if a block group is
 410           given multiple blocks, change processNursery() accordingly.
 411         */
 412         bd = allocBlock();
 413         bd->link = tail;
 414         // double-link the nursery: we might need to insert blocks
 415         if (tail != NULL) {
 416             tail->u.back = bd;
 417         }
 418         bd->step = stp;
 419         bd->gen_no = 0;
 420         bd->flags = 0;
 421         bd->free = bd->start;
 422         tail = bd;
 423     }
 424     tail->u.back = NULL;
 425     return tail;
 426 }
 427
 428 static void
 429 assignNurseriesToCapabilities (void)
 430 {
 431 #ifdef THREADED_RTS
 432     nat i;
 433
 434     for (i = 0; i < n_nurseries; i++) {
 435         capabilities[i].r.rNursery        = &nurseries[i];
 436         capabilities[i].r.rCurrentNursery = nurseries[i].blocks;
 437         capabilities[i].r.rCurrentAlloc   = NULL;
 438     }
 439 #else /* THREADED_RTS */
 440     MainCapability.r.rNursery        = &nurseries[0];
 441     MainCapability.r.rCurrentNursery = nurseries[0].blocks;
 442     MainCapability.r.rCurrentAlloc   = NULL;
 443 #endif
 444 }
 445
 446 void
 447 allocNurseries( void )
 448 {
 449     nat i;
 450
 451     for (i = 0; i < n_nurseries; i++) {
 452         nurseries[i].blocks =
 453             allocNursery(&nurseries[i], NULL,
 454                          RtsFlags.GcFlags.minAllocAreaSize);
 455         nurseries[i].n_blocks    = RtsFlags.GcFlags.minAllocAreaSize;
 456         nurseries[i].old_blocks   = NULL;
 457         nurseries[i].n_old_blocks = 0;
 458     }
 459     assignNurseriesToCapabilities();
 460 }
 461
 462 void
 463 resetNurseries( void )
 464 {
 465     nat i;
 466     bdescr *bd;
 467     step *stp;
 468
 469     for (i = 0; i < n_nurseries; i++) {
 470         stp = &nurseries[i];
 471         for (bd = stp->blocks; bd; bd = bd->link) {
 472             bd->free = bd->start;
 473             ASSERT(bd->gen_no == 0);
 474             ASSERT(bd->step == stp);
 475             IF_DEBUG(sanity,memset(bd->start, 0xaa, BLOCK_SIZE));
 476         }
 477     }
 478     assignNurseriesToCapabilities();
 479 }
 480
 481 lnat
 482 countNurseryBlocks (void)
 483 {
 484     nat i;
 485     lnat blocks = 0;
 486
 487     for (i = 0; i < n_nurseries; i++) {
 488         blocks += nurseries[i].n_blocks;
 489     }
 490     return blocks;
 491 }
 492
 493 static void
 494 resizeNursery ( step *stp, nat blocks )
 495 {
 496   bdescr *bd;
 497   nat nursery_blocks;
 498
 499   nursery_blocks = stp->n_blocks;
 500   if (nursery_blocks == blocks) return;
 501
 502   if (nursery_blocks < blocks) {
 503       debugTrace(DEBUG_gc, "increasing size of nursery to %d blocks",
 504                  blocks);
 505     stp->blocks = allocNursery(stp, stp->blocks, blocks-nursery_blocks);
 506   }
 507   else {
 508     bdescr *next_bd;
 509
 510     debugTrace(DEBUG_gc, "decreasing size of nursery to %d blocks",
 511                blocks);
 512
 513     bd = stp->blocks;
 514     while (nursery_blocks > blocks) {
 515         next_bd = bd->link;
 516         next_bd->u.back = NULL;
 517         nursery_blocks -= bd->blocks; // might be a large block
 518         freeGroup(bd);
 519         bd = next_bd;
 520     }
 521     stp->blocks = bd;
 522     // might have gone just under, by freeing a large block, so make
 523     // up the difference.
 524     if (nursery_blocks < blocks) {
 525         stp->blocks = allocNursery(stp, stp->blocks, blocks-nursery_blocks);
 526     }
 527   }
 528
 529   stp->n_blocks = blocks;
 530   ASSERT(countBlocks(stp->blocks) == stp->n_blocks);
 531 }
 532
 533 //
 534 // Resize each of the nurseries to the specified size.
 535 //
 536 void
 537 resizeNurseriesFixed (nat blocks)
 538 {
 539     nat i;
 540     for (i = 0; i < n_nurseries; i++) {
 541         resizeNursery(&nurseries[i], blocks);
 542     }
 543 }
 544
 545 //
 546 // Resize the nurseries to the total specified size.
 547 //
 548 void
 549 resizeNurseries (nat blocks)
 550 {
 551     // If there are multiple nurseries, then we just divide the number
 552     // of available blocks between them.
 553     resizeNurseriesFixed(blocks / n_nurseries);
 554 }
 555
 556
 557 /* -----------------------------------------------------------------------------
 558    move_TSO is called to update the TSO structure after it has been
 559    moved from one place to another.
 560    -------------------------------------------------------------------------- */
 561
 562 void
 563 move_TSO (StgTSO *src, StgTSO *dest)
 564 {
 565     ptrdiff_t diff;
 566
 567     // relocate the stack pointer...
 568     diff = (StgPtr)dest - (StgPtr)src; // In *words*
 569     dest->sp = (StgPtr)dest->sp + diff;
 570 }
 571
 572 /* -----------------------------------------------------------------------------
 573    The allocate() interface
 574
 575    allocateInGen() function allocates memory directly into a specific
 576    generation.  It always succeeds, and returns a chunk of memory n
 577    words long.  n can be larger than the size of a block if necessary,
 578    in which case a contiguous block group will be allocated.
 579
 580    allocate(n) is equivalent to allocateInGen(g0).
 581    -------------------------------------------------------------------------- */
 582
 583 StgPtr
 584 allocateInGen (generation *g, nat n)
 585 {
 586     step *stp;
 587     bdescr *bd;
 588     StgPtr ret;
 589
 590     ACQUIRE_SM_LOCK;
 591
 592     TICK_ALLOC_HEAP_NOCTR(n);
 593     CCS_ALLOC(CCCS,n);
 594
 595     stp = &g->steps[0];
 596
 597     if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_))
 598     {
 599         nat req_blocks =  (lnat)BLOCK_ROUND_UP(n*sizeof(W_)) / BLOCK_SIZE;
 600
 601         // Attempting to allocate an object larger than maxHeapSize
 602         // should definitely be disallowed.  (bug #1791)
 603         if (RtsFlags.GcFlags.maxHeapSize > 0 &&
 604             req_blocks >= RtsFlags.GcFlags.maxHeapSize) {
 605             heapOverflow();
 606         }
 607
 608         bd = allocGroup(req_blocks);
 609         dbl_link_onto(bd, &stp->large_objects);
 610         stp->n_large_blocks += bd->blocks; // might be larger than req_blocks
 611         bd->gen_no  = g->no;
 612         bd->step = stp;
 613         bd->flags = BF_LARGE;
 614         bd->free = bd->start + n;
 615         ret = bd->start;
 616     }
 617     else
 618     {
 619         // small allocation (<LARGE_OBJECT_THRESHOLD) */
 620         bd = stp->blocks;
 621         if (bd == NULL || bd->free + n > bd->start + BLOCK_SIZE_W) {
 622             bd = allocBlock();
 623             bd->gen_no = g->no;
 624             bd->step = stp;
 625             bd->flags = 0;
 626             bd->link = stp->blocks;
 627             stp->blocks = bd;
 628             stp->n_blocks++;
 629             alloc_blocks++;
 630         }
 631         ret = bd->free;
 632         bd->free += n;
 633     }
 634
 635     RELEASE_SM_LOCK;
 636
 637     return ret;
 638 }
 639
 640 StgPtr
 641 allocate (nat n)
 642 {
 643     return allocateInGen(g0,n);
 644 }
 645
 646 lnat
 647 allocatedBytes( void )
 648 {
 649     lnat allocated;
 650
 651     allocated = alloc_blocks * BLOCK_SIZE_W;
 652     if (pinned_object_block != NULL) {
 653         allocated -= (pinned_object_block->start + BLOCK_SIZE_W) -
 654             pinned_object_block->free;
 655     }
 656
 657     return allocated;
 658 }
 659
 660 // split N blocks off the start of the given bdescr, returning the
 661 // remainder as a new block group.  We treat the remainder as if it
 662 // had been freshly allocated in generation 0.
 663 bdescr *
 664 splitLargeBlock (bdescr *bd, nat blocks)
 665 {
 666     bdescr *new_bd;
 667
 668     // subtract the original number of blocks from the counter first
 669     bd->step->n_large_blocks -= bd->blocks;
 670
 671     new_bd = splitBlockGroup (bd, blocks);
 672
 673     dbl_link_onto(new_bd, &g0s0->large_objects);
 674     g0s0->n_large_blocks += new_bd->blocks;
 675     new_bd->gen_no  = g0s0->no;
 676     new_bd->step    = g0s0;
 677     new_bd->flags   = BF_LARGE;
 678     new_bd->free    = bd->free;
 679
 680     // add the new number of blocks to the counter.  Due to the gaps
 681     // for block descriptor, new_bd->blocks + bd->blocks might not be
 682     // equal to the original bd->blocks, which is why we do it this way.
 683     bd->step->n_large_blocks += bd->blocks;
 684
 685     return new_bd;
 686 }
 687
 688 /* -----------------------------------------------------------------------------
 689    allocateLocal()
 690
 691    This allocates memory in the current thread - it is intended for
 692    use primarily from STG-land where we have a Capability.  It is
 693    better than allocate() because it doesn't require taking the
 694    sm_mutex lock in the common case.
 695
 696    Memory is allocated directly from the nursery if possible (but not
 697    from the current nursery block, so as not to interfere with
 698    Hp/HpLim).
 699    -------------------------------------------------------------------------- */
 700
 701 StgPtr
 702 allocateLocal (Capability *cap, nat n)
 703 {
 704     bdescr *bd;
 705     StgPtr p;
 706
 707     if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
 708         return allocateInGen(g0,n);
 709     }
 710
 711     /* small allocation (<LARGE_OBJECT_THRESHOLD) */
 712
 713     TICK_ALLOC_HEAP_NOCTR(n);
 714     CCS_ALLOC(CCCS,n);
 715
 716     bd = cap->r.rCurrentAlloc;
 717     if (bd == NULL || bd->free + n > bd->start + BLOCK_SIZE_W) {
 718
 719         // The CurrentAlloc block is full, we need to find another
 720         // one.  First, we try taking the next block from the
 721         // nursery:
 722         bd = cap->r.rCurrentNursery->link;
 723
 724         if (bd == NULL || bd->free + n > bd->start + BLOCK_SIZE_W) {
 725             // The nursery is empty, or the next block is already
 726             // full: allocate a fresh block (we can't fail here).
 727             ACQUIRE_SM_LOCK;
 728             bd = allocBlock();
 729             cap->r.rNursery->n_blocks++;
 730             RELEASE_SM_LOCK;
 731             bd->gen_no = 0;
 732             bd->step = cap->r.rNursery;
 733             bd->flags = 0;
 734             // NO: alloc_blocks++;
 735             // calcAllocated() uses the size of the nursery, and we've
 736             // already bumpted nursery->n_blocks above.
 737         } else {
 738             // we have a block in the nursery: take it and put
 739             // it at the *front* of the nursery list, and use it
 740             // to allocate() from.
 741             cap->r.rCurrentNursery->link = bd->link;
 742             if (bd->link != NULL) {
 743                 bd->link->u.back = cap->r.rCurrentNursery;
 744             }
 745         }
 746         dbl_link_onto(bd, &cap->r.rNursery->blocks);
 747         cap->r.rCurrentAlloc = bd;
 748         IF_DEBUG(sanity, checkNurserySanity(cap->r.rNursery));
 749     }
 750     p = bd->free;
 751     bd->free += n;
 752     return p;
 753 }
 754
 755 /* ---------------------------------------------------------------------------
 756    Allocate a fixed/pinned object.
 757
 758    We allocate small pinned objects into a single block, allocating a
 759    new block when the current one overflows.  The block is chained
 760    onto the large_object_list of generation 0 step 0.
 761
 762    NOTE: The GC can't in general handle pinned objects.  This
 763    interface is only safe to use for ByteArrays, which have no
 764    pointers and don't require scavenging.  It works because the
 765    block's descriptor has the BF_LARGE flag set, so the block is
 766    treated as a large object and chained onto various lists, rather
 767    than the individual objects being copied.  However, when it comes
 768    to scavenge the block, the GC will only scavenge the first object.
 769    The reason is that the GC can't linearly scan a block of pinned
 770    objects at the moment (doing so would require using the
 771    mostly-copying techniques).  But since we're restricting ourselves
 772    to pinned ByteArrays, not scavenging is ok.
 773
 774    This function is called by newPinnedByteArray# which immediately
 775    fills the allocated memory with a MutableByteArray#.
 776    ------------------------------------------------------------------------- */
 777
 778 StgPtr
 779 allocatePinned( nat n )
 780 {
 781     StgPtr p;
 782     bdescr *bd = pinned_object_block;
 783
 784     // If the request is for a large object, then allocate()
 785     // will give us a pinned object anyway.
 786     if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
 787         return allocate(n);
 788     }
 789
 790     ACQUIRE_SM_LOCK;
 791
 792     TICK_ALLOC_HEAP_NOCTR(n);
 793     CCS_ALLOC(CCCS,n);
 794
 795     // we always return 8-byte aligned memory.  bd->free must be
 796     // 8-byte aligned to begin with, so we just round up n to
 797     // the nearest multiple of 8 bytes.
 798     if (sizeof(StgWord) == 4) {
 799         n = (n+1) & ~1;
 800     }
 801
 802     // If we don't have a block of pinned objects yet, or the current
 803     // one isn't large enough to hold the new object, allocate a new one.
 804     if (bd == NULL || (bd->free + n) > (bd->start + BLOCK_SIZE_W)) {
 805         pinned_object_block = bd = allocBlock();
 806         dbl_link_onto(bd, &g0s0->large_objects);
 807         g0s0->n_large_blocks++;
 808         bd->gen_no = 0;
 809         bd->step   = g0s0;
 810         bd->flags  = BF_PINNED | BF_LARGE;
 811         bd->free   = bd->start;
 812         alloc_blocks++;
 813     }
 814
 815     p = bd->free;
 816     bd->free += n;
 817     RELEASE_SM_LOCK;
 818     return p;
 819 }
 820
 821 /* -----------------------------------------------------------------------------
 822    Write Barriers
 823    -------------------------------------------------------------------------- */
 824
 825 /*
 826    This is the write barrier for MUT_VARs, a.k.a. IORefs.  A
 827    MUT_VAR_CLEAN object is not on the mutable list; a MUT_VAR_DIRTY
 828    is.  When written to, a MUT_VAR_CLEAN turns into a MUT_VAR_DIRTY
 829    and is put on the mutable list.
 830 */
 831 void
 832 dirty_MUT_VAR(StgRegTable *reg, StgClosure *p)
 833 {
 834     Capability *cap = regTableToCapability(reg);
 835     bdescr *bd;
 836     if (p->header.info == &stg_MUT_VAR_CLEAN_info) {
 837         p->header.info = &stg_MUT_VAR_DIRTY_info;
 838         bd = Bdescr((StgPtr)p);
 839         if (bd->gen_no > 0) recordMutableCap(p,cap,bd->gen_no);
 840     }
 841 }
 842
 843 // Setting a TSO's link field with a write barrier.
 844 // It is *not* necessary to call this function when
 845 //    * setting the link field to END_TSO_QUEUE
 846 //    * putting a TSO on the blackhole_queue
 847 //    * setting the link field of the currently running TSO, as it
 848 //      will already be dirty.
 849 void
 850 setTSOLink (Capability *cap, StgTSO *tso, StgTSO *target)
 851 {
 852     bdescr *bd;
 853     if ((tso->flags & (TSO_DIRTY|TSO_LINK_DIRTY)) == 0) {
 854         tso->flags |= TSO_LINK_DIRTY;
 855         bd = Bdescr((StgPtr)tso);
 856         if (bd->gen_no > 0) recordMutableCap((StgClosure*)tso,cap,bd->gen_no);
 857     }
 858     tso->_link = target;
 859 }
 860
 861 void
 862 dirty_TSO (Capability *cap, StgTSO *tso)
 863 {
 864     bdescr *bd;
 865     if ((tso->flags & (TSO_DIRTY|TSO_LINK_DIRTY)) == 0) {
 866         bd = Bdescr((StgPtr)tso);
 867         if (bd->gen_no > 0) recordMutableCap((StgClosure*)tso,cap,bd->gen_no);
 868     }
 869     tso->flags |= TSO_DIRTY;
 870 }
 871
 872 /*
 873    This is the write barrier for MVARs.  An MVAR_CLEAN objects is not
 874    on the mutable list; a MVAR_DIRTY is.  When written to, a
 875    MVAR_CLEAN turns into a MVAR_DIRTY and is put on the mutable list.
 876    The check for MVAR_CLEAN is inlined at the call site for speed,
 877    this really does make a difference on concurrency-heavy benchmarks
 878    such as Chaneneos and cheap-concurrency.
 879 */
 880 void
 881 dirty_MVAR(StgRegTable *reg, StgClosure *p)
 882 {
 883     Capability *cap = regTableToCapability(reg);
 884     bdescr *bd;
 885     bd = Bdescr((StgPtr)p);
 886     if (bd->gen_no > 0) recordMutableCap(p,cap,bd->gen_no);
 887 }
 888
 889 /* -----------------------------------------------------------------------------
 890    Allocation functions for GMP.
 891
 892    These all use the allocate() interface - we can't have any garbage
 893    collection going on during a gmp operation, so we use allocate()
 894    which always succeeds.  The gmp operations which might need to
 895    allocate will ask the storage manager (via doYouWantToGC()) whether
 896    a garbage collection is required, in case we get into a loop doing
 897    only allocate() style allocation.
 898    -------------------------------------------------------------------------- */
 899
 900 static void *
 901 stgAllocForGMP (size_t size_in_bytes)
 902 {
 903   StgArrWords* arr;
 904   nat data_size_in_words, total_size_in_words;
 905
 906   /* round up to a whole number of words */
 907   data_size_in_words  = (size_in_bytes + sizeof(W_) + 1) / sizeof(W_);
 908   total_size_in_words = sizeofW(StgArrWords) + data_size_in_words;
 909
 910   /* allocate and fill it in. */
 911 #if defined(THREADED_RTS)
 912   arr = (StgArrWords *)allocateLocal(myTask()->cap, total_size_in_words);
 913 #else
 914   arr = (StgArrWords *)allocateLocal(&MainCapability, total_size_in_words);
 915 #endif
 916   SET_ARR_HDR(arr, &stg_ARR_WORDS_info, CCCS, data_size_in_words);
 917
 918   /* and return a ptr to the goods inside the array */
 919   return arr->payload;
 920 }
 921
 922 static void *
 923 stgReallocForGMP (void *ptr, size_t old_size, size_t new_size)
 924 {
 925     void *new_stuff_ptr = stgAllocForGMP(new_size);
 926     nat i = 0;
 927     char *p = (char *) ptr;
 928     char *q = (char *) new_stuff_ptr;
 929
 930     for (; i < old_size; i++, p++, q++) {
 931         *q = *p;
 932     }
 933
 934     return(new_stuff_ptr);
 935 }
 936
 937 static void
 938 stgDeallocForGMP (void *ptr STG_UNUSED,
 939                   size_t size STG_UNUSED)
 940 {
 941     /* easy for us: the garbage collector does the dealloc'n */
 942 }
 943
 944 /* -----------------------------------------------------------------------------
 945  * Stats and stuff
 946  * -------------------------------------------------------------------------- */
 947
 948 /* -----------------------------------------------------------------------------
 949  * calcAllocated()
 950  *
 951  * Approximate how much we've allocated: number of blocks in the
 952  * nursery + blocks allocated via allocate() - unused nusery blocks.
 953  * This leaves a little slop at the end of each block, and doesn't
 954  * take into account large objects (ToDo).
 955  * -------------------------------------------------------------------------- */
 956
 957 lnat
 958 calcAllocated( void )
 959 {
 960   nat allocated;
 961   bdescr *bd;
 962
 963   allocated = allocatedBytes();
 964   allocated += countNurseryBlocks() * BLOCK_SIZE_W;
 965
 966   {
 967 #ifdef THREADED_RTS
 968   nat i;
 969   for (i = 0; i < n_nurseries; i++) {
 970       Capability *cap;
 971       for ( bd = capabilities[i].r.rCurrentNursery->link;
 972             bd != NULL; bd = bd->link ) {
 973           allocated -= BLOCK_SIZE_W;
 974       }
 975       cap = &capabilities[i];
 976       if (cap->r.rCurrentNursery->free <
 977           cap->r.rCurrentNursery->start + BLOCK_SIZE_W) {
 978           allocated -= (cap->r.rCurrentNursery->start + BLOCK_SIZE_W)
 979               - cap->r.rCurrentNursery->free;
 980       }
 981   }
 982 #else
 983   bdescr *current_nursery = MainCapability.r.rCurrentNursery;
 984
 985   for ( bd = current_nursery->link; bd != NULL; bd = bd->link ) {
 986       allocated -= BLOCK_SIZE_W;
 987   }
 988   if (current_nursery->free < current_nursery->start + BLOCK_SIZE_W) {
 989       allocated -= (current_nursery->start + BLOCK_SIZE_W)
 990           - current_nursery->free;
 991   }
 992 #endif
 993   }
 994
 995   total_allocated += allocated;
 996   return allocated;
 997 }
 998
 999 /* Approximate the amount of live data in the heap.  To be called just
1000  * after garbage collection (see GarbageCollect()).
1001  */
1002 lnat
1003 calcLiveBlocks(void)
1004 {
1005   nat g, s;
1006   lnat live = 0;
1007   step *stp;
1008
1009   if (RtsFlags.GcFlags.generations == 1) {
1010       return g0s0->n_large_blocks + g0s0->n_blocks;
1011   }
1012
1013   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1014     for (s = 0; s < generations[g].n_steps; s++) {
1015       /* approximate amount of live data (doesn't take into account slop
1016        * at end of each block).
1017        */
1018       if (g == 0 && s == 0) {
1019           continue;
1020       }
1021       stp = &generations[g].steps[s];
1022       live += stp->n_large_blocks + stp->n_blocks;
1023     }
1024   }
1025   return live;
1026 }
1027
1028 lnat
1029 countOccupied(bdescr *bd)
1030 {
1031     lnat words;
1032
1033     words = 0;
1034     for (; bd != NULL; bd = bd->link) {
1035         words += bd->free - bd->start;
1036     }
1037     return words;
1038 }
1039
1040 // Return an accurate count of the live data in the heap, excluding
1041 // generation 0.
1042 lnat
1043 calcLiveWords(void)
1044 {
1045     nat g, s;
1046     lnat live;
1047     step *stp;
1048
1049     if (RtsFlags.GcFlags.generations == 1) {
1050         return g0s0->n_words + countOccupied(g0s0->large_objects);
1051     }
1052
1053     live = 0;
1054     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1055         for (s = 0; s < generations[g].n_steps; s++) {
1056             if (g == 0 && s == 0) continue;
1057             stp = &generations[g].steps[s];
1058             live += stp->n_words + countOccupied(stp->large_objects);
1059         }
1060     }
1061     return live;
1062 }
1063
1064 /* Approximate the number of blocks that will be needed at the next
1065  * garbage collection.
1066  *
1067  * Assume: all data currently live will remain live.  Steps that will
1068  * be collected next time will therefore need twice as many blocks
1069  * since all the data will be copied.
1070  */
1071 extern lnat
1072 calcNeeded(void)
1073 {
1074     lnat needed = 0;
1075     nat g, s;
1076     step *stp;
1077
1078     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1079         for (s = 0; s < generations[g].n_steps; s++) {
1080             if (g == 0 && s == 0) { continue; }
1081             stp = &generations[g].steps[s];
1082             if (g == 0 || // always collect gen 0
1083                 (generations[g].steps[0].n_blocks +
1084                  generations[g].steps[0].n_large_blocks
1085                  > generations[g].max_blocks
1086                  && stp->is_compacted == 0)) {
1087                 needed += 2 * stp->n_blocks + stp->n_large_blocks;
1088             } else {
1089                 needed += stp->n_blocks + stp->n_large_blocks;
1090             }
1091         }
1092     }
1093     return needed;
1094 }
1095
1096 /* ----------------------------------------------------------------------------
1097    Executable memory
1098
1099    Executable memory must be managed separately from non-executable
1100    memory.  Most OSs these days require you to jump through hoops to
1101    dynamically allocate executable memory, due to various security
1102    measures.
1103
1104    Here we provide a small memory allocator for executable memory.
1105    Memory is managed with a page granularity; we allocate linearly
1106    in the page, and when the page is emptied (all objects on the page
1107    are free) we free the page again, not forgetting to make it
1108    non-executable.
1109
1110    TODO: The inability to handle objects bigger than BLOCK_SIZE_W means that
1111          the linker cannot use allocateExec for loading object code files
1112          on Windows. Once allocateExec can handle larger objects, the linker
1113          should be modified to use allocateExec instead of VirtualAlloc.
1114    ------------------------------------------------------------------------- */
1115
1116 static bdescr *exec_block;
1117
1118 void *allocateExec (nat bytes)
1119 {
1120     void *ret;
1121     nat n;
1122
1123     ACQUIRE_SM_LOCK;
1124
1125     // round up to words.
1126     n  = (bytes + sizeof(W_) + 1) / sizeof(W_);
1127
1128     if (n+1 > BLOCK_SIZE_W) {
1129         barf("allocateExec: can't handle large objects");
1130     }
1131
1132     if (exec_block == NULL ||
1133         exec_block->free + n + 1 > exec_block->start + BLOCK_SIZE_W) {
1134         bdescr *bd;
1135         lnat pagesize = getPageSize();
1136         bd = allocGroup(stg_max(1, pagesize / BLOCK_SIZE));
1137         debugTrace(DEBUG_gc, "allocate exec block %p", bd->start);
1138         bd->gen_no = 0;
1139         bd->flags = BF_EXEC;
1140         bd->link = exec_block;
1141         if (exec_block != NULL) {
1142             exec_block->u.back = bd;
1143         }
1144         bd->u.back = NULL;
1145         setExecutable(bd->start, bd->blocks * BLOCK_SIZE, rtsTrue);
1146         exec_block = bd;
1147     }
1148     *(exec_block->free) = n;  // store the size of this chunk
1149     exec_block->gen_no += n;  // gen_no stores the number of words allocated
1150     ret = exec_block->free + 1;
1151     exec_block->free += n + 1;
1152
1153     RELEASE_SM_LOCK
1154     return ret;
1155 }
1156
1157 void freeExec (void *addr)
1158 {
1159     StgPtr p = (StgPtr)addr - 1;
1160     bdescr *bd = Bdescr((StgPtr)p);
1161
1162     if ((bd->flags & BF_EXEC) == 0) {
1163         barf("freeExec: not executable");
1164     }
1165
1166     if (*(StgPtr)p == 0) {
1167         barf("freeExec: already free?");
1168     }
1169
1170     ACQUIRE_SM_LOCK;
1171
1172     bd->gen_no -= *(StgPtr)p;
1173     *(StgPtr)p = 0;
1174
1175     if (bd->gen_no == 0) {
1176         // Free the block if it is empty, but not if it is the block at
1177         // the head of the queue.
1178         if (bd != exec_block) {
1179             debugTrace(DEBUG_gc, "free exec block %p", bd->start);
1180             dbl_link_remove(bd, &exec_block);
1181             setExecutable(bd->start, bd->blocks * BLOCK_SIZE, rtsFalse);
1182             freeGroup(bd);
1183         } else {
1184             bd->free = bd->start;
1185         }
1186     }
1187
1188     RELEASE_SM_LOCK
1189 }
1190
1191 /* -----------------------------------------------------------------------------
1192    Debugging
1193
1194    memInventory() checks for memory leaks by counting up all the
1195    blocks we know about and comparing that to the number of blocks
1196    allegedly floating around in the system.
1197    -------------------------------------------------------------------------- */
1198
1199 #ifdef DEBUG
1200
1201 // Useful for finding partially full blocks in gdb
1202 void findSlop(bdescr *bd);
1203 void findSlop(bdescr *bd)
1204 {
1205     lnat slop;
1206
1207     for (; bd != NULL; bd = bd->link) {
1208         slop = (bd->blocks * BLOCK_SIZE_W) - (bd->free - bd->start);
1209         if (slop > (1024/sizeof(W_))) {
1210             debugBelch("block at %p (bdescr %p) has %ldKB slop\n",
1211                        bd->start, bd, slop / (1024/sizeof(W_)));
1212         }
1213     }
1214 }
1215
1216 nat
1217 countBlocks(bdescr *bd)
1218 {
1219     nat n;
1220     for (n=0; bd != NULL; bd=bd->link) {
1221         n += bd->blocks;
1222     }
1223     return n;
1224 }
1225
1226 // (*1) Just like countBlocks, except that we adjust the count for a
1227 // megablock group so that it doesn't include the extra few blocks
1228 // that would be taken up by block descriptors in the second and
1229 // subsequent megablock.  This is so we can tally the count with the
1230 // number of blocks allocated in the system, for memInventory().
1231 static nat
1232 countAllocdBlocks(bdescr *bd)
1233 {
1234     nat n;
1235     for (n=0; bd != NULL; bd=bd->link) {
1236         n += bd->blocks;
1237         // hack for megablock groups: see (*1) above
1238         if (bd->blocks > BLOCKS_PER_MBLOCK) {
1239             n -= (MBLOCK_SIZE / BLOCK_SIZE - BLOCKS_PER_MBLOCK)
1240                 * (bd->blocks/(MBLOCK_SIZE/BLOCK_SIZE));
1241         }
1242     }
1243     return n;
1244 }
1245
1246 static lnat
1247 stepBlocks (step *stp)
1248 {
1249     ASSERT(countBlocks(stp->blocks) == stp->n_blocks);
1250     ASSERT(countBlocks(stp->large_objects) == stp->n_large_blocks);
1251     return stp->n_blocks + stp->n_old_blocks +
1252             countAllocdBlocks(stp->large_objects);
1253 }
1254
1255 void
1256 memInventory (rtsBool show)
1257 {
1258   nat g, s, i;
1259   step *stp;
1260   lnat gen_blocks[RtsFlags.GcFlags.generations];
1261   lnat nursery_blocks, retainer_blocks,
1262        arena_blocks, exec_blocks;
1263   lnat live_blocks = 0, free_blocks = 0;
1264   rtsBool leak;
1265
1266   // count the blocks we current have
1267
1268   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1269       gen_blocks[g] = 0;
1270       for (i = 0; i < n_capabilities; i++) {
1271           gen_blocks[g] += countBlocks(capabilities[i].mut_lists[g]);
1272       }
1273       gen_blocks[g] += countAllocdBlocks(generations[g].mut_list);
1274       for (s = 0; s < generations[g].n_steps; s++) {
1275           stp = &generations[g].steps[s];
1276           gen_blocks[g] += stepBlocks(stp);
1277       }
1278   }
1279
1280   nursery_blocks = 0;
1281   for (i = 0; i < n_nurseries; i++) {
1282       nursery_blocks += stepBlocks(&nurseries[i]);
1283   }
1284
1285   retainer_blocks = 0;
1286 #ifdef PROFILING
1287   if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_RETAINER) {
1288       retainer_blocks = retainerStackBlocks();
1289   }
1290 #endif
1291
1292   // count the blocks allocated by the arena allocator
1293   arena_blocks = arenaBlocks();
1294
1295   // count the blocks containing executable memory
1296   exec_blocks = countAllocdBlocks(exec_block);
1297
1298   /* count the blocks on the free list */
1299   free_blocks = countFreeList();
1300
1301   live_blocks = 0;
1302   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1303       live_blocks += gen_blocks[g];
1304   }
1305   live_blocks += nursery_blocks +
1306                + retainer_blocks + arena_blocks + exec_blocks;
1307
1308 #define MB(n) (((n) * BLOCK_SIZE_W) / ((1024*1024)/sizeof(W_)))
1309
1310   leak = live_blocks + free_blocks != mblocks_allocated * BLOCKS_PER_MBLOCK;
1311   if (show || leak)
1312   {
1313       if (leak) {
1314           debugBelch("Memory leak detected:\n");
1315       } else {
1316           debugBelch("Memory inventory:\n");
1317       }
1318       for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1319           debugBelch("  gen %d blocks : %5lu blocks (%lu MB)\n", g,
1320                      gen_blocks[g], MB(gen_blocks[g]));
1321       }
1322       debugBelch("  nursery      : %5lu blocks (%lu MB)\n",
1323                  nursery_blocks, MB(nursery_blocks));
1324       debugBelch("  retainer     : %5lu blocks (%lu MB)\n",
1325                  retainer_blocks, MB(retainer_blocks));
1326       debugBelch("  arena blocks : %5lu blocks (%lu MB)\n",
1327                  arena_blocks, MB(arena_blocks));
1328       debugBelch("  exec         : %5lu blocks (%lu MB)\n",
1329                  exec_blocks, MB(exec_blocks));
1330       debugBelch("  free         : %5lu blocks (%lu MB)\n",
1331                  free_blocks, MB(free_blocks));
1332       debugBelch("  total        : %5lu blocks (%lu MB)\n",
1333                  live_blocks + free_blocks, MB(live_blocks+free_blocks));
1334       if (leak) {
1335           debugBelch("\n  in system    : %5lu blocks (%lu MB)\n",
1336                      mblocks_allocated * BLOCKS_PER_MBLOCK, mblocks_allocated);
1337       }
1338   }
1339 }
1340
1341
1342 /* Full heap sanity check. */
1343 void
1344 checkSanity( void )
1345 {
1346     nat g, s;
1347
1348     if (RtsFlags.GcFlags.generations == 1) {
1349         checkHeap(g0s0->blocks);
1350         checkChain(g0s0->large_objects);
1351     } else {
1352
1353         for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1354             for (s = 0; s < generations[g].n_steps; s++) {
1355                 if (g == 0 && s == 0) { continue; }
1356                 ASSERT(countBlocks(generations[g].steps[s].blocks)
1357                        == generations[g].steps[s].n_blocks);
1358                 ASSERT(countBlocks(generations[g].steps[s].large_objects)
1359                        == generations[g].steps[s].n_large_blocks);
1360                 checkHeap(generations[g].steps[s].blocks);
1361                 checkChain(generations[g].steps[s].large_objects);
1362                 if (g > 0) {
1363                     checkMutableList(generations[g].mut_list, g);
1364                 }
1365             }
1366         }
1367
1368         for (s = 0; s < n_nurseries; s++) {
1369             ASSERT(countBlocks(nurseries[s].blocks)
1370                    == nurseries[s].n_blocks);
1371             ASSERT(countBlocks(nurseries[s].large_objects)
1372                    == nurseries[s].n_large_blocks);
1373         }
1374
1375         checkFreeListSanity();
1376     }
1377 }
1378
1379 /* Nursery sanity check */
1380 void
1381 checkNurserySanity( step *stp )
1382 {
1383     bdescr *bd, *prev;
1384     nat blocks = 0;
1385
1386     prev = NULL;
1387     for (bd = stp->blocks; bd != NULL; bd = bd->link) {
1388         ASSERT(bd->u.back == prev);
1389         prev = bd;
1390         blocks += bd->blocks;
1391     }
1392     ASSERT(blocks == stp->n_blocks);
1393 }
1394
1395 // handy function for use in gdb, because Bdescr() is inlined.
1396 extern bdescr *_bdescr( StgPtr p );
1397
1398 bdescr *
1399 _bdescr( StgPtr p )
1400 {
1401     return Bdescr(p);
1402 }
1403
1404 #endif