rts/sm/GC.c

   1 /* -----------------------------------------------------------------------------
   2  *
   3  * (c) The GHC Team 1998-2006
   4  *
   5  * Generational garbage collector
   6  *
   7  * Documentation on the architecture of the Garbage Collector can be
   8  * found in the online commentary:
   9  *
  10  *   http://hackage.haskell.org/trac/ghc/wiki/Commentary/Rts/Storage/GC
  11  *
  12  * ---------------------------------------------------------------------------*/
  13
  14 // #include "PosixSource.h"
  15 #include "Rts.h"
  16 #include "RtsFlags.h"
  17 #include "RtsUtils.h"
  18 #include "Apply.h"
  19 #include "OSThreads.h"
  20 #include "LdvProfile.h"
  21 #include "Updates.h"
  22 #include "Stats.h"
  23 #include "Schedule.h"
  24 #include "Sanity.h"
  25 #include "BlockAlloc.h"
  26 #include "MBlock.h"
  27 #include "ProfHeap.h"
  28 #include "SchedAPI.h"
  29 #include "Weak.h"
  30 #include "Prelude.h"
  31 #include "ParTicky.h"           // ToDo: move into Rts.h
  32 #include "RtsSignals.h"
  33 #include "STM.h"
  34 #include "HsFFI.h"
  35 #include "Linker.h"
  36 #if defined(RTS_GTK_FRONTPANEL)
  37 #include "FrontPanel.h"
  38 #endif
  39 #include "Trace.h"
  40 #include "RetainerProfile.h"
  41 #include "RaiseAsync.h"
  42 #include "Sparks.h"
  43 #include "Papi.h"
  44
  45 #include "GC.h"
  46 #include "Compact.h"
  47 #include "Evac.h"
  48 #include "Scav.h"
  49 #include "GCUtils.h"
  50 #include "MarkWeak.h"
  51 #include "Sparks.h"
  52
  53 #include <string.h> // for memset()
  54 #include <unistd.h>
  55
  56 /* -----------------------------------------------------------------------------
  57    Global variables
  58    -------------------------------------------------------------------------- */
  59
  60 /* STATIC OBJECT LIST.
  61  *
  62  * During GC:
  63  * We maintain a linked list of static objects that are still live.
  64  * The requirements for this list are:
  65  *
  66  *  - we need to scan the list while adding to it, in order to
  67  *    scavenge all the static objects (in the same way that
  68  *    breadth-first scavenging works for dynamic objects).
  69  *
  70  *  - we need to be able to tell whether an object is already on
  71  *    the list, to break loops.
  72  *
  73  * Each static object has a "static link field", which we use for
  74  * linking objects on to the list.  We use a stack-type list, consing
  75  * objects on the front as they are added (this means that the
  76  * scavenge phase is depth-first, not breadth-first, but that
  77  * shouldn't matter).
  78  *
  79  * A separate list is kept for objects that have been scavenged
  80  * already - this is so that we can zero all the marks afterwards.
  81  *
  82  * An object is on the list if its static link field is non-zero; this
  83  * means that we have to mark the end of the list with '1', not NULL.
  84  *
  85  * Extra notes for generational GC:
  86  *
  87  * Each generation has a static object list associated with it.  When
  88  * collecting generations up to N, we treat the static object lists
  89  * from generations > N as roots.
  90  *
  91  * We build up a static object list while collecting generations 0..N,
  92  * which is then appended to the static object list of generation N+1.
  93  */
  94
  95 /* N is the oldest generation being collected, where the generations
  96  * are numbered starting at 0.  A major GC (indicated by the major_gc
  97  * flag) is when we're collecting all generations.  We only attempt to
  98  * deal with static objects and GC CAFs when doing a major GC.
  99  */
 100 nat N;
 101 rtsBool major_gc;
 102
 103 /* Data used for allocation area sizing.
 104  */
 105 static lnat g0s0_pcnt_kept = 30; // percentage of g0s0 live at last minor GC
 106
 107 /* Mut-list stats */
 108 #ifdef DEBUG
 109 nat mutlist_MUTVARS,
 110     mutlist_MUTARRS,
 111     mutlist_MVARS,
 112     mutlist_OTHERS;
 113 #endif
 114
 115 /* Thread-local data for each GC thread
 116  */
 117 gc_thread **gc_threads = NULL;
 118 // gc_thread *gct = NULL;  // this thread's gct TODO: make thread-local
 119
 120 // Number of threads running in *this* GC.  Affects how many
 121 // step->todos[] lists we have to look in to find work.
 122 nat n_gc_threads;
 123
 124 // For stats:
 125 long copied;        // *words* copied & scavenged during this GC
 126
 127 #ifdef THREADED_RTS
 128 SpinLock recordMutableGen_sync;
 129 #endif
 130
 131 /* -----------------------------------------------------------------------------
 132    Static function declarations
 133    -------------------------------------------------------------------------- */
 134
 135 static void mark_root               (StgClosure **root);
 136 static void zero_static_object_list (StgClosure* first_static);
 137 static nat  initialise_N            (rtsBool force_major_gc);
 138 static void alloc_gc_threads        (void);
 139 static void init_collected_gen      (nat g, nat threads);
 140 static void init_uncollected_gen    (nat g, nat threads);
 141 static void init_gc_thread          (gc_thread *t);
 142 static void update_task_list        (void);
 143 static void resize_generations      (void);
 144 static void resize_nursery          (void);
 145 static void start_gc_threads        (void);
 146 static void gc_thread_work          (void);
 147 static nat  inc_running             (void);
 148 static nat  dec_running             (void);
 149 static void wakeup_gc_threads       (nat n_threads);
 150 static void shutdown_gc_threads     (nat n_threads);
 151
 152 #if 0 && defined(DEBUG)
 153 static void gcCAFs                  (void);
 154 #endif
 155
 156 /* -----------------------------------------------------------------------------
 157    The mark bitmap & stack.
 158    -------------------------------------------------------------------------- */
 159
 160 #define MARK_STACK_BLOCKS 4
 161
 162 bdescr *mark_stack_bdescr;
 163 StgPtr *mark_stack;
 164 StgPtr *mark_sp;
 165 StgPtr *mark_splim;
 166
 167 // Flag and pointers used for falling back to a linear scan when the
 168 // mark stack overflows.
 169 rtsBool mark_stack_overflowed;
 170 bdescr *oldgen_scan_bd;
 171 StgPtr  oldgen_scan;
 172
 173 /* -----------------------------------------------------------------------------
 174    GarbageCollect: the main entry point to the garbage collector.
 175
 176    Locks held: all capabilities are held throughout GarbageCollect().
 177    -------------------------------------------------------------------------- */
 178
 179 void
 180 GarbageCollect ( rtsBool force_major_gc )
 181 {
 182   bdescr *bd;
 183   step *stp;
 184   lnat live, allocated;
 185   lnat oldgen_saved_blocks = 0;
 186   gc_thread *saved_gct;
 187   nat g, s, t, n;
 188
 189   // necessary if we stole a callee-saves register for gct:
 190   saved_gct = gct;
 191
 192 #ifdef PROFILING
 193   CostCentreStack *prev_CCS;
 194 #endif
 195
 196   ACQUIRE_SM_LOCK;
 197
 198   debugTrace(DEBUG_gc, "starting GC");
 199
 200 #if defined(RTS_USER_SIGNALS)
 201   if (RtsFlags.MiscFlags.install_signal_handlers) {
 202     // block signals
 203     blockUserSignals();
 204   }
 205 #endif
 206
 207   // tell the stats department that we've started a GC
 208   stat_startGC();
 209
 210   // tell the STM to discard any cached closures it's hoping to re-use
 211   stmPreGCHook();
 212
 213 #ifdef DEBUG
 214   mutlist_MUTVARS = 0;
 215   mutlist_MUTARRS = 0;
 216   mutlist_OTHERS = 0;
 217 #endif
 218
 219   // attribute any costs to CCS_GC
 220 #ifdef PROFILING
 221   prev_CCS = CCCS;
 222   CCCS = CCS_GC;
 223 #endif
 224
 225   /* Approximate how much we allocated.
 226    * Todo: only when generating stats?
 227    */
 228   allocated = calcAllocated();
 229
 230   /* Figure out which generation to collect
 231    */
 232   n = initialise_N(force_major_gc);
 233
 234   /* Allocate + initialise the gc_thread structures.
 235    */
 236   alloc_gc_threads();
 237
 238   /* Start threads, so they can be spinning up while we finish initialisation.
 239    */
 240   start_gc_threads();
 241
 242   /* How many threads will be participating in this GC?
 243    * We don't try to parallelise minor GC.
 244    */
 245 #if defined(THREADED_RTS)
 246   if (n < (4*1024*1024 / BLOCK_SIZE)) {
 247       n_gc_threads = 1;
 248   } else {
 249       n_gc_threads = RtsFlags.ParFlags.gcThreads;
 250   }
 251   trace(TRACE_gc|DEBUG_gc, "GC (gen %d): %dKB to collect, using %d thread(s)",
 252         N, n * (BLOCK_SIZE / 1024), n_gc_threads);
 253 #else
 254   n_gc_threads = 1;
 255 #endif
 256
 257 #ifdef RTS_GTK_FRONTPANEL
 258   if (RtsFlags.GcFlags.frontpanel) {
 259       updateFrontPanelBeforeGC(N);
 260   }
 261 #endif
 262
 263 #ifdef DEBUG
 264   // check for memory leaks if DEBUG is on
 265   memInventory(traceClass(DEBUG_gc));
 266 #endif
 267
 268   // check stack sanity *before* GC (ToDo: check all threads)
 269   IF_DEBUG(sanity, checkFreeListSanity());
 270
 271   // Initialise all our gc_thread structures
 272   for (t = 0; t < n_gc_threads; t++) {
 273       init_gc_thread(gc_threads[t]);
 274   }
 275
 276   // Initialise all the generations/steps that we're collecting.
 277   for (g = 0; g <= N; g++) {
 278       init_collected_gen(g,n_gc_threads);
 279   }
 280
 281   // Initialise all the generations/steps that we're *not* collecting.
 282   for (g = N+1; g < RtsFlags.GcFlags.generations; g++) {
 283       init_uncollected_gen(g,n_gc_threads);
 284   }
 285
 286   /* Allocate a mark stack if we're doing a major collection.
 287    */
 288   if (major_gc) {
 289       mark_stack_bdescr = allocGroup(MARK_STACK_BLOCKS);
 290       mark_stack = (StgPtr *)mark_stack_bdescr->start;
 291       mark_sp    = mark_stack;
 292       mark_splim = mark_stack + (MARK_STACK_BLOCKS * BLOCK_SIZE_W);
 293   } else {
 294       mark_stack_bdescr = NULL;
 295   }
 296
 297   // this is the main thread
 298   gct = gc_threads[0];
 299
 300   /* -----------------------------------------------------------------------
 301    * follow all the roots that we know about:
 302    *   - mutable lists from each generation > N
 303    * we want to *scavenge* these roots, not evacuate them: they're not
 304    * going to move in this GC.
 305    * Also do them in reverse generation order, for the usual reason:
 306    * namely to reduce the likelihood of spurious old->new pointers.
 307    */
 308   for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
 309       generations[g].saved_mut_list = generations[g].mut_list;
 310       generations[g].mut_list = allocBlock();
 311       // mut_list always has at least one block.
 312   }
 313
 314   // the main thread is running: this prevents any other threads from
 315   // exiting prematurely, so we can start them now.
 316   // NB. do this after the mutable lists have been saved above, otherwise
 317   // the other GC threads will be writing into the old mutable lists.
 318   inc_running();
 319   wakeup_gc_threads(n_gc_threads);
 320
 321   for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
 322       scavenge_mutable_list(&generations[g]);
 323   }
 324
 325   // follow roots from the CAF list (used by GHCi)
 326   gct->evac_step = 0;
 327   markCAFs(mark_root);
 328
 329   // follow all the roots that the application knows about.
 330   gct->evac_step = 0;
 331   GetRoots(mark_root);
 332
 333 #if defined(RTS_USER_SIGNALS)
 334   // mark the signal handlers (signals should be already blocked)
 335   markSignalHandlers(mark_root);
 336 #endif
 337
 338   // Mark the weak pointer list, and prepare to detect dead weak pointers.
 339   markWeakPtrList();
 340   initWeakForGC();
 341
 342   // Mark the stable pointer table.
 343   markStablePtrTable(mark_root);
 344
 345   /* -------------------------------------------------------------------------
 346    * Repeatedly scavenge all the areas we know about until there's no
 347    * more scavenging to be done.
 348    */
 349   for (;;)
 350   {
 351       gc_thread_work();
 352       // The other threads are now stopped.  We might recurse back to
 353       // here, but from now on this is the only thread.
 354
 355       // if any blackholes are alive, make the threads that wait on
 356       // them alive too.
 357       if (traverseBlackholeQueue()) {
 358           inc_running();
 359           continue;
 360       }
 361
 362       // must be last...  invariant is that everything is fully
 363       // scavenged at this point.
 364       if (traverseWeakPtrList()) { // returns rtsTrue if evaced something
 365           inc_running();
 366           continue;
 367       }
 368
 369       // If we get to here, there's really nothing left to do.
 370       break;
 371   }
 372
 373   shutdown_gc_threads(n_gc_threads);
 374
 375   // Update pointers from the Task list
 376   update_task_list();
 377
 378   // Now see which stable names are still alive.
 379   gcStablePtrTable();
 380
 381 #ifdef PROFILING
 382   // We call processHeapClosureForDead() on every closure destroyed during
 383   // the current garbage collection, so we invoke LdvCensusForDead().
 384   if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_LDV
 385       || RtsFlags.ProfFlags.bioSelector != NULL)
 386     LdvCensusForDead(N);
 387 #endif
 388
 389   // NO MORE EVACUATION AFTER THIS POINT!
 390   // Finally: compaction of the oldest generation.
 391   if (major_gc && oldest_gen->steps[0].is_compacted) {
 392       // save number of blocks for stats
 393       oldgen_saved_blocks = oldest_gen->steps[0].n_old_blocks;
 394       compact();
 395   }
 396
 397   IF_DEBUG(sanity, checkGlobalTSOList(rtsFalse));
 398
 399   // Two-space collector: free the old to-space.
 400   // g0s0->old_blocks is the old nursery
 401   // g0s0->blocks is to-space from the previous GC
 402   if (RtsFlags.GcFlags.generations == 1) {
 403       if (g0s0->blocks != NULL) {
 404           freeChain(g0s0->blocks);
 405           g0s0->blocks = NULL;
 406       }
 407   }
 408
 409   // For each workspace, in each thread:
 410   //    * clear the BF_EVACUATED flag from each copied block
 411   //    * move the copied blocks to the step
 412   {
 413       gc_thread *thr;
 414       step_workspace *ws;
 415       bdescr *prev;
 416
 417       for (t = 0; t < n_gc_threads; t++) {
 418           thr = gc_threads[t];
 419
 420           // not step 0
 421           for (s = 1; s < total_steps; s++) {
 422               ws = &thr->steps[s];
 423               // Not true?
 424               // ASSERT( ws->scan_bd == ws->todo_bd );
 425               ASSERT( ws->scan_bd ? ws->scan == ws->scan_bd->free : 1 );
 426
 427               // Push the final block
 428               if (ws->scan_bd) { push_scan_block(ws->scan_bd, ws); }
 429
 430               ASSERT(countBlocks(ws->scavd_list) == ws->n_scavd_blocks);
 431
 432               prev = ws->scavd_list;
 433               for (bd = ws->scavd_list; bd != NULL; bd = bd->link) {
 434                   bd->flags &= ~BF_EVACUATED;    // now from-space
 435                   prev = bd;
 436               }
 437               prev->link = ws->stp->blocks;
 438               ws->stp->blocks = ws->scavd_list;
 439               ws->stp->n_blocks += ws->n_scavd_blocks;
 440               ASSERT(countBlocks(ws->stp->blocks) == ws->stp->n_blocks);
 441           }
 442       }
 443   }
 444
 445   // Two-space collector: swap the semi-spaces around.
 446   // Currently: g0s0->old_blocks is the old nursery
 447   //            g0s0->blocks is to-space from this GC
 448   // We want these the other way around.
 449   if (RtsFlags.GcFlags.generations == 1) {
 450       bdescr *nursery_blocks = g0s0->old_blocks;
 451       nat n_nursery_blocks = g0s0->n_old_blocks;
 452       g0s0->old_blocks = g0s0->blocks;
 453       g0s0->n_old_blocks = g0s0->n_blocks;
 454       g0s0->blocks = nursery_blocks;
 455       g0s0->n_blocks = n_nursery_blocks;
 456   }
 457
 458   /* run through all the generations/steps and tidy up
 459    */
 460   copied = 0;
 461   {
 462       nat i;
 463       for (i=0; i < n_gc_threads; i++) {
 464           if (n_gc_threads > 1) {
 465               trace(TRACE_gc,"thread %d:", i);
 466               trace(TRACE_gc,"   copied           %ld", gc_threads[i]->copied * sizeof(W_));
 467               trace(TRACE_gc,"   any_work         %ld", gc_threads[i]->any_work);
 468               trace(TRACE_gc,"   no_work          %ld", gc_threads[i]->no_work);
 469               trace(TRACE_gc,"   scav_find_work %ld",   gc_threads[i]->scav_find_work);
 470           }
 471           copied += gc_threads[i]->copied;
 472       }
 473   }
 474
 475   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 476
 477     if (g <= N) {
 478       generations[g].collections++; // for stats
 479     }
 480
 481     // Count the mutable list as bytes "copied" for the purposes of
 482     // stats.  Every mutable list is copied during every GC.
 483     if (g > 0) {
 484         nat mut_list_size = 0;
 485         for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
 486             mut_list_size += bd->free - bd->start;
 487         }
 488         copied +=  mut_list_size;
 489
 490         debugTrace(DEBUG_gc,
 491                    "mut_list_size: %lu (%d vars, %d arrays, %d MVARs, %d others)",
 492                    (unsigned long)(mut_list_size * sizeof(W_)),
 493                    mutlist_MUTVARS, mutlist_MUTARRS, mutlist_MVARS, mutlist_OTHERS);
 494     }
 495
 496     for (s = 0; s < generations[g].n_steps; s++) {
 497       bdescr *next;
 498       stp = &generations[g].steps[s];
 499
 500       // for generations we collected...
 501       if (g <= N) {
 502
 503         /* free old memory and shift to-space into from-space for all
 504          * the collected steps (except the allocation area).  These
 505          * freed blocks will probaby be quickly recycled.
 506          */
 507         if (!(g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1)) {
 508             if (stp->is_compacted)
 509             {
 510                 // for a compacted step, just shift the new to-space
 511                 // onto the front of the now-compacted existing blocks.
 512                 for (bd = stp->blocks; bd != NULL; bd = bd->link) {
 513                     bd->flags &= ~BF_EVACUATED;  // now from-space
 514                 }
 515                 // tack the new blocks on the end of the existing blocks
 516                 if (stp->old_blocks != NULL) {
 517                     for (bd = stp->old_blocks; bd != NULL; bd = next) {
 518                         // NB. this step might not be compacted next
 519                         // time, so reset the BF_COMPACTED flags.
 520                         // They are set before GC if we're going to
 521                         // compact.  (search for BF_COMPACTED above).
 522                         bd->flags &= ~BF_COMPACTED;
 523                         next = bd->link;
 524                         if (next == NULL) {
 525                             bd->link = stp->blocks;
 526                         }
 527                     }
 528                     stp->blocks = stp->old_blocks;
 529                 }
 530                 // add the new blocks to the block tally
 531                 stp->n_blocks += stp->n_old_blocks;
 532                 ASSERT(countBlocks(stp->blocks) == stp->n_blocks);
 533             }
 534             else // not copacted
 535             {
 536                 freeChain(stp->old_blocks);
 537             }
 538             stp->old_blocks = NULL;
 539             stp->n_old_blocks = 0;
 540         }
 541
 542         /* LARGE OBJECTS.  The current live large objects are chained on
 543          * scavenged_large, having been moved during garbage
 544          * collection from large_objects.  Any objects left on
 545          * large_objects list are therefore dead, so we free them here.
 546          */
 547         for (bd = stp->large_objects; bd != NULL; bd = next) {
 548           next = bd->link;
 549           freeGroup(bd);
 550           bd = next;
 551         }
 552
 553         // update the count of blocks used by large objects
 554         for (bd = stp->scavenged_large_objects; bd != NULL; bd = bd->link) {
 555           bd->flags &= ~BF_EVACUATED;
 556         }
 557         stp->large_objects  = stp->scavenged_large_objects;
 558         stp->n_large_blocks = stp->n_scavenged_large_blocks;
 559
 560       }
 561       else // for older generations...
 562       {
 563         /* For older generations, we need to append the
 564          * scavenged_large_object list (i.e. large objects that have been
 565          * promoted during this GC) to the large_object list for that step.
 566          */
 567         for (bd = stp->scavenged_large_objects; bd; bd = next) {
 568           next = bd->link;
 569           bd->flags &= ~BF_EVACUATED;
 570           dbl_link_onto(bd, &stp->large_objects);
 571         }
 572
 573         // add the new blocks we promoted during this GC
 574         stp->n_large_blocks += stp->n_scavenged_large_blocks;
 575       }
 576     }
 577   }
 578
 579   // update the max size of older generations after a major GC
 580   resize_generations();
 581
 582   // Guess the amount of live data for stats.
 583   live = calcLiveBlocks() * BLOCK_SIZE_W;
 584   debugTrace(DEBUG_gc, "Slop: %ldKB",
 585              (live - calcLiveWords()) / (1024/sizeof(W_)));
 586
 587   // Free the small objects allocated via allocate(), since this will
 588   // all have been copied into G0S1 now.
 589   if (RtsFlags.GcFlags.generations > 1) {
 590       if (g0s0->blocks != NULL) {
 591           freeChain(g0s0->blocks);
 592           g0s0->blocks = NULL;
 593       }
 594       g0s0->n_blocks = 0;
 595   }
 596   alloc_blocks = 0;
 597   alloc_blocks_lim = RtsFlags.GcFlags.minAllocAreaSize;
 598
 599   // Start a new pinned_object_block
 600   pinned_object_block = NULL;
 601
 602   // Free the mark stack.
 603   if (mark_stack_bdescr != NULL) {
 604       freeGroup(mark_stack_bdescr);
 605   }
 606
 607   // Free any bitmaps.
 608   for (g = 0; g <= N; g++) {
 609       for (s = 0; s < generations[g].n_steps; s++) {
 610           stp = &generations[g].steps[s];
 611           if (stp->bitmap != NULL) {
 612               freeGroup(stp->bitmap);
 613               stp->bitmap = NULL;
 614           }
 615       }
 616   }
 617
 618   resize_nursery();
 619
 620  // mark the garbage collected CAFs as dead
 621 #if 0 && defined(DEBUG) // doesn't work at the moment
 622   if (major_gc) { gcCAFs(); }
 623 #endif
 624
 625 #ifdef PROFILING
 626   // resetStaticObjectForRetainerProfiling() must be called before
 627   // zeroing below.
 628   if (n_gc_threads > 1) {
 629       barf("profiling is currently broken with multi-threaded GC");
 630       // ToDo: fix the gct->scavenged_static_objects below
 631   }
 632   resetStaticObjectForRetainerProfiling(gct->scavenged_static_objects);
 633 #endif
 634
 635   // zero the scavenged static object list
 636   if (major_gc) {
 637       nat i;
 638       for (i = 0; i < n_gc_threads; i++) {
 639           zero_static_object_list(gc_threads[i]->scavenged_static_objects);
 640       }
 641   }
 642
 643   // Reset the nursery
 644   resetNurseries();
 645
 646   // start any pending finalizers
 647   RELEASE_SM_LOCK;
 648   scheduleFinalizers(last_free_capability, old_weak_ptr_list);
 649   ACQUIRE_SM_LOCK;
 650
 651   // send exceptions to any threads which were about to die
 652   RELEASE_SM_LOCK;
 653   resurrectThreads(resurrected_threads);
 654   ACQUIRE_SM_LOCK;
 655
 656   // Update the stable pointer hash table.
 657   updateStablePtrTable(major_gc);
 658
 659   // check sanity after GC
 660   IF_DEBUG(sanity, checkSanity());
 661
 662   // extra GC trace info
 663   if (traceClass(TRACE_gc|DEBUG_gc)) statDescribeGens();
 664
 665 #ifdef DEBUG
 666   // symbol-table based profiling
 667   /*  heapCensus(to_blocks); */ /* ToDo */
 668 #endif
 669
 670   // restore enclosing cost centre
 671 #ifdef PROFILING
 672   CCCS = prev_CCS;
 673 #endif
 674
 675 #ifdef DEBUG
 676   // check for memory leaks if DEBUG is on
 677   memInventory(traceClass(DEBUG_gc));
 678 #endif
 679
 680 #ifdef RTS_GTK_FRONTPANEL
 681   if (RtsFlags.GcFlags.frontpanel) {
 682       updateFrontPanelAfterGC( N, live );
 683   }
 684 #endif
 685
 686   // ok, GC over: tell the stats department what happened.
 687   stat_endGC(allocated, live, copied, N);
 688
 689 #if defined(RTS_USER_SIGNALS)
 690   if (RtsFlags.MiscFlags.install_signal_handlers) {
 691     // unblock signals again
 692     unblockUserSignals();
 693   }
 694 #endif
 695
 696   RELEASE_SM_LOCK;
 697
 698   gct = saved_gct;
 699 }
 700
 701 /* -----------------------------------------------------------------------------
 702  * Mark all nodes pointed to by sparks in the spark queues (for GC) Does an
 703  * implicit slide i.e. after marking all sparks are at the beginning of the
 704  * spark pool and the spark pool only contains sparkable closures
 705  * -------------------------------------------------------------------------- */
 706
 707 #ifdef THREADED_RTS
 708 static void
 709 markSparkQueue (evac_fn evac, Capability *cap)
 710 {
 711     StgClosure **sparkp, **to_sparkp;
 712     nat n, pruned_sparks; // stats only
 713     StgSparkPool *pool;
 714
 715     PAR_TICKY_MARK_SPARK_QUEUE_START();
 716
 717     n = 0;
 718     pruned_sparks = 0;
 719
 720     pool = &(cap->r.rSparks);
 721
 722     ASSERT_SPARK_POOL_INVARIANTS(pool);
 723
 724 #if defined(PARALLEL_HASKELL)
 725     // stats only
 726     n = 0;
 727     pruned_sparks = 0;
 728 #endif
 729
 730     sparkp = pool->hd;
 731     to_sparkp = pool->hd;
 732     while (sparkp != pool->tl) {
 733         ASSERT(*sparkp!=NULL);
 734         ASSERT(LOOKS_LIKE_CLOSURE_PTR(((StgClosure *)*sparkp)));
 735         // ToDo?: statistics gathering here (also for GUM!)
 736         if (closure_SHOULD_SPARK(*sparkp)) {
 737             evac(sparkp);
 738             *to_sparkp++ = *sparkp;
 739             if (to_sparkp == pool->lim) {
 740                 to_sparkp = pool->base;
 741             }
 742             n++;
 743         } else {
 744             pruned_sparks++;
 745         }
 746         sparkp++;
 747         if (sparkp == pool->lim) {
 748             sparkp = pool->base;
 749         }
 750     }
 751     pool->tl = to_sparkp;
 752
 753     PAR_TICKY_MARK_SPARK_QUEUE_END(n);
 754
 755 #if defined(PARALLEL_HASKELL)
 756     debugTrace(DEBUG_sched,
 757                "marked %d sparks and pruned %d sparks on [%x]",
 758                n, pruned_sparks, mytid);
 759 #else
 760     debugTrace(DEBUG_sched,
 761                "marked %d sparks and pruned %d sparks",
 762                n, pruned_sparks);
 763 #endif
 764
 765     debugTrace(DEBUG_sched,
 766                "new spark queue len=%d; (hd=%p; tl=%p)\n",
 767                sparkPoolSize(pool), pool->hd, pool->tl);
 768 }
 769 #endif
 770
 771 /* ---------------------------------------------------------------------------
 772    Where are the roots that we know about?
 773
 774         - all the threads on the runnable queue
 775         - all the threads on the blocked queue
 776         - all the threads on the sleeping queue
 777         - all the thread currently executing a _ccall_GC
 778         - all the "main threads"
 779
 780    ------------------------------------------------------------------------ */
 781
 782 void
 783 GetRoots( evac_fn evac )
 784 {
 785     nat i;
 786     Capability *cap;
 787     Task *task;
 788
 789     // Each GC thread is responsible for following roots from the
 790     // Capability of the same number.  There will usually be the same
 791     // or fewer Capabilities as GC threads, but just in case there
 792     // are more, we mark every Capability whose number is the GC
 793     // thread's index plus a multiple of the number of GC threads.
 794     for (i = gct->thread_index; i < n_capabilities; i += n_gc_threads) {
 795         cap = &capabilities[i];
 796         evac((StgClosure **)(void *)&cap->run_queue_hd);
 797         evac((StgClosure **)(void *)&cap->run_queue_tl);
 798 #if defined(THREADED_RTS)
 799         evac((StgClosure **)(void *)&cap->wakeup_queue_hd);
 800         evac((StgClosure **)(void *)&cap->wakeup_queue_tl);
 801 #endif
 802         for (task = cap->suspended_ccalling_tasks; task != NULL;
 803              task=task->next) {
 804             debugTrace(DEBUG_sched,
 805                        "evac'ing suspended TSO %lu", (unsigned long)task->suspended_tso->id);
 806             evac((StgClosure **)(void *)&task->suspended_tso);
 807         }
 808
 809 #if defined(THREADED_RTS)
 810         markSparkQueue(evac,cap);
 811 #endif
 812     }
 813
 814 #if !defined(THREADED_RTS)
 815     evac((StgClosure **)(void *)&blocked_queue_hd);
 816     evac((StgClosure **)(void *)&blocked_queue_tl);
 817     evac((StgClosure **)(void *)&sleeping_queue);
 818 #endif
 819 }
 820
 821 /* -----------------------------------------------------------------------------
 822    isAlive determines whether the given closure is still alive (after
 823    a garbage collection) or not.  It returns the new address of the
 824    closure if it is alive, or NULL otherwise.
 825
 826    NOTE: Use it before compaction only!
 827          It untags and (if needed) retags pointers to closures.
 828    -------------------------------------------------------------------------- */
 829
 830
 831 StgClosure *
 832 isAlive(StgClosure *p)
 833 {
 834   const StgInfoTable *info;
 835   bdescr *bd;
 836   StgWord tag;
 837   StgClosure *q;
 838
 839   while (1) {
 840     /* The tag and the pointer are split, to be merged later when needed. */
 841     tag = GET_CLOSURE_TAG(p);
 842     q = UNTAG_CLOSURE(p);
 843
 844     ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
 845     info = get_itbl(q);
 846
 847     // ignore static closures
 848     //
 849     // ToDo: for static closures, check the static link field.
 850     // Problem here is that we sometimes don't set the link field, eg.
 851     // for static closures with an empty SRT or CONSTR_STATIC_NOCAFs.
 852     //
 853     if (!HEAP_ALLOCED(q)) {
 854         return p;
 855     }
 856
 857     // ignore closures in generations that we're not collecting.
 858     bd = Bdescr((P_)q);
 859     if (bd->gen_no > N) {
 860         return p;
 861     }
 862
 863     // if it's a pointer into to-space, then we're done
 864     if (bd->flags & BF_EVACUATED) {
 865         return p;
 866     }
 867
 868     // large objects use the evacuated flag
 869     if (bd->flags & BF_LARGE) {
 870         return NULL;
 871     }
 872
 873     // check the mark bit for compacted steps
 874     if ((bd->flags & BF_COMPACTED) && is_marked((P_)q,bd)) {
 875         return p;
 876     }
 877
 878     switch (info->type) {
 879
 880     case IND:
 881     case IND_STATIC:
 882     case IND_PERM:
 883     case IND_OLDGEN:            // rely on compatible layout with StgInd
 884     case IND_OLDGEN_PERM:
 885       // follow indirections
 886       p = ((StgInd *)q)->indirectee;
 887       continue;
 888
 889     case EVACUATED:
 890       // alive!
 891       return ((StgEvacuated *)q)->evacuee;
 892
 893     case TSO:
 894       if (((StgTSO *)q)->what_next == ThreadRelocated) {
 895         p = (StgClosure *)((StgTSO *)q)->link;
 896         continue;
 897       }
 898       return NULL;
 899
 900     default:
 901       // dead.
 902       return NULL;
 903     }
 904   }
 905 }
 906
 907 /* -----------------------------------------------------------------------------
 908    Figure out which generation to collect, initialise N and major_gc.
 909
 910    Also returns the total number of blocks in generations that will be
 911    collected.
 912    -------------------------------------------------------------------------- */
 913
 914 static nat
 915 initialise_N (rtsBool force_major_gc)
 916 {
 917     int g;
 918     nat s, blocks, blocks_total;
 919
 920     blocks = 0;
 921     blocks_total = 0;
 922
 923     if (force_major_gc) {
 924         N = RtsFlags.GcFlags.generations - 1;
 925     } else {
 926         N = 0;
 927     }
 928
 929     for (g = RtsFlags.GcFlags.generations - 1; g >= 0; g--) {
 930         blocks = 0;
 931         for (s = 0; s < generations[g].n_steps; s++) {
 932             blocks += generations[g].steps[s].n_blocks;
 933             blocks += generations[g].steps[s].n_large_blocks;
 934         }
 935         if (blocks >= generations[g].max_blocks) {
 936             N = stg_max(N,g);
 937         }
 938         if ((nat)g <= N) {
 939             blocks_total += blocks;
 940         }
 941     }
 942
 943     blocks_total += countNurseryBlocks();
 944
 945     major_gc = (N == RtsFlags.GcFlags.generations-1);
 946     return blocks_total;
 947 }
 948
 949 /* -----------------------------------------------------------------------------
 950    Initialise the gc_thread structures.
 951    -------------------------------------------------------------------------- */
 952
 953 static gc_thread *
 954 alloc_gc_thread (int n)
 955 {
 956     nat s;
 957     step_workspace *ws;
 958     gc_thread *t;
 959
 960     t = stgMallocBytes(sizeof(gc_thread) + total_steps * sizeof(step_workspace),
 961                        "alloc_gc_thread");
 962
 963 #ifdef THREADED_RTS
 964     t->id = 0;
 965     initCondition(&t->wake_cond);
 966     initMutex(&t->wake_mutex);
 967     t->wakeup = rtsFalse;
 968     t->exit   = rtsFalse;
 969 #endif
 970
 971     t->thread_index = n;
 972     t->free_blocks = NULL;
 973     t->gc_count = 0;
 974
 975     init_gc_thread(t);
 976
 977 #ifdef USE_PAPI
 978     t->papi_events = -1;
 979 #endif
 980
 981     for (s = 0; s < total_steps; s++)
 982     {
 983         ws = &t->steps[s];
 984         ws->stp = &all_steps[s];
 985         ASSERT(s == ws->stp->abs_no);
 986         ws->gct = t;
 987
 988         ws->scan_bd = NULL;
 989         ws->scan = NULL;
 990
 991         ws->todo_bd = NULL;
 992         ws->buffer_todo_bd = NULL;
 993
 994         ws->scavd_list = NULL;
 995         ws->n_scavd_blocks = 0;
 996     }
 997
 998     return t;
 999 }
1000
1001
1002 static void
1003 alloc_gc_threads (void)
1004 {
1005     if (gc_threads == NULL) {
1006 #if defined(THREADED_RTS)
1007         nat i;
1008         gc_threads = stgMallocBytes (RtsFlags.ParFlags.gcThreads *
1009                                      sizeof(gc_thread*),
1010                                      "alloc_gc_threads");
1011
1012         for (i = 0; i < RtsFlags.ParFlags.gcThreads; i++) {
1013             gc_threads[i] = alloc_gc_thread(i);
1014         }
1015 #else
1016         gc_threads = stgMallocBytes (sizeof(gc_thread*),
1017                                      "alloc_gc_threads");
1018
1019         gc_threads[0] = alloc_gc_thread(0);
1020 #endif
1021     }
1022 }
1023
1024 /* ----------------------------------------------------------------------------
1025    Start GC threads
1026    ------------------------------------------------------------------------- */
1027
1028 static nat gc_running_threads;
1029
1030 #if defined(THREADED_RTS)
1031 static Mutex gc_running_mutex;
1032 #endif
1033
1034 static nat
1035 inc_running (void)
1036 {
1037     nat n_running;
1038     ACQUIRE_LOCK(&gc_running_mutex);
1039     n_running = ++gc_running_threads;
1040     RELEASE_LOCK(&gc_running_mutex);
1041     ASSERT(n_running <= n_gc_threads);
1042     return n_running;
1043 }
1044
1045 static nat
1046 dec_running (void)
1047 {
1048     nat n_running;
1049     ACQUIRE_LOCK(&gc_running_mutex);
1050     ASSERT(n_gc_threads != 0);
1051     n_running = --gc_running_threads;
1052     RELEASE_LOCK(&gc_running_mutex);
1053     return n_running;
1054 }
1055
1056 //
1057 // gc_thread_work(): Scavenge until there's no work left to do and all
1058 // the running threads are idle.
1059 //
1060 static void
1061 gc_thread_work (void)
1062 {
1063     nat r;
1064
1065     debugTrace(DEBUG_gc, "GC thread %d working", gct->thread_index);
1066
1067     // gc_running_threads has already been incremented for us; either
1068     // this is the main thread and we incremented it inside
1069     // GarbageCollect(), or this is a worker thread and the main
1070     // thread bumped gc_running_threads before waking us up.
1071
1072     // Every thread evacuates some roots.
1073     gct->evac_step = 0;
1074     GetRoots(mark_root);
1075
1076 loop:
1077     scavenge_loop();
1078     // scavenge_loop() only exits when there's no work to do
1079     r = dec_running();
1080
1081     debugTrace(DEBUG_gc, "GC thread %d idle (%d still running)",
1082                gct->thread_index, r);
1083
1084     while (gc_running_threads != 0) {
1085         usleep(1);
1086         if (any_work()) {
1087             inc_running();
1088             goto loop;
1089         }
1090         // any_work() does not remove the work from the queue, it
1091         // just checks for the presence of work.  If we find any,
1092         // then we increment gc_running_threads and go back to
1093         // scavenge_loop() to perform any pending work.
1094     }
1095
1096     // All threads are now stopped
1097     debugTrace(DEBUG_gc, "GC thread %d finished.", gct->thread_index);
1098 }
1099
1100
1101 #if defined(THREADED_RTS)
1102 static void
1103 gc_thread_mainloop (void)
1104 {
1105     while (!gct->exit) {
1106
1107         // Wait until we're told to wake up
1108         ACQUIRE_LOCK(&gct->wake_mutex);
1109         gct->wakeup = rtsFalse;
1110         while (!gct->wakeup) {
1111             debugTrace(DEBUG_gc, "GC thread %d standing by...",
1112                        gct->thread_index);
1113             waitCondition(&gct->wake_cond, &gct->wake_mutex);
1114         }
1115         RELEASE_LOCK(&gct->wake_mutex);
1116         if (gct->exit) break;
1117
1118 #ifdef USE_PAPI
1119         // start performance counters in this thread...
1120         if (gct->papi_events == -1) {
1121             papi_init_eventset(&gct->papi_events);
1122         }
1123         papi_thread_start_gc1_count(gct->papi_events);
1124 #endif
1125
1126         gc_thread_work();
1127
1128 #ifdef USE_PAPI
1129         // count events in this thread towards the GC totals
1130         papi_thread_stop_gc1_count(gct->papi_events);
1131 #endif
1132     }
1133 }
1134 #endif
1135
1136 #if defined(THREADED_RTS)
1137 static void
1138 gc_thread_entry (gc_thread *my_gct)
1139 {
1140     gct = my_gct;
1141     debugTrace(DEBUG_gc, "GC thread %d starting...", gct->thread_index);
1142     gct->id = osThreadId();
1143     gc_thread_mainloop();
1144 }
1145 #endif
1146
1147 static void
1148 start_gc_threads (void)
1149 {
1150 #if defined(THREADED_RTS)
1151     nat i;
1152     OSThreadId id;
1153     static rtsBool done = rtsFalse;
1154
1155     gc_running_threads = 0;
1156     initMutex(&gc_running_mutex);
1157
1158     if (!done) {
1159         // Start from 1: the main thread is 0
1160         for (i = 1; i < RtsFlags.ParFlags.gcThreads; i++) {
1161             createOSThread(&id, (OSThreadProc*)&gc_thread_entry,
1162                            gc_threads[i]);
1163         }
1164         done = rtsTrue;
1165     }
1166 #endif
1167 }
1168
1169 static void
1170 wakeup_gc_threads (nat n_threads USED_IF_THREADS)
1171 {
1172 #if defined(THREADED_RTS)
1173     nat i;
1174     for (i=1; i < n_threads; i++) {
1175         inc_running();
1176         ACQUIRE_LOCK(&gc_threads[i]->wake_mutex);
1177         gc_threads[i]->wakeup = rtsTrue;
1178         signalCondition(&gc_threads[i]->wake_cond);
1179         RELEASE_LOCK(&gc_threads[i]->wake_mutex);
1180     }
1181 #endif
1182 }
1183
1184 // After GC is complete, we must wait for all GC threads to enter the
1185 // standby state, otherwise they may still be executing inside
1186 // any_work(), and may even remain awake until the next GC starts.
1187 static void
1188 shutdown_gc_threads (nat n_threads USED_IF_THREADS)
1189 {
1190 #if defined(THREADED_RTS)
1191     nat i;
1192     rtsBool wakeup;
1193     for (i=1; i < n_threads; i++) {
1194         do {
1195             ACQUIRE_LOCK(&gc_threads[i]->wake_mutex);
1196             wakeup = gc_threads[i]->wakeup;
1197             // wakeup is false while the thread is waiting
1198             RELEASE_LOCK(&gc_threads[i]->wake_mutex);
1199         } while (wakeup);
1200     }
1201 #endif
1202 }
1203
1204 /* ----------------------------------------------------------------------------
1205    Initialise a generation that is to be collected
1206    ------------------------------------------------------------------------- */
1207
1208 static void
1209 init_collected_gen (nat g, nat n_threads)
1210 {
1211     nat s, t, i;
1212     step_workspace *ws;
1213     step *stp;
1214     bdescr *bd;
1215
1216     // Throw away the current mutable list.  Invariant: the mutable
1217     // list always has at least one block; this means we can avoid a
1218     // check for NULL in recordMutable().
1219     if (g != 0) {
1220         freeChain(generations[g].mut_list);
1221         generations[g].mut_list = allocBlock();
1222         for (i = 0; i < n_capabilities; i++) {
1223             freeChain(capabilities[i].mut_lists[g]);
1224             capabilities[i].mut_lists[g] = allocBlock();
1225         }
1226     }
1227
1228     for (s = 0; s < generations[g].n_steps; s++) {
1229
1230         // generation 0, step 0 doesn't need to-space
1231         if (g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1) {
1232             continue;
1233         }
1234
1235         stp = &generations[g].steps[s];
1236         ASSERT(stp->gen_no == g);
1237
1238         // deprecate the existing blocks
1239         stp->old_blocks   = stp->blocks;
1240         stp->n_old_blocks = stp->n_blocks;
1241         stp->blocks       = NULL;
1242         stp->n_blocks     = 0;
1243
1244         // we don't have any to-be-scavenged blocks yet
1245         stp->todos = NULL;
1246         stp->todos_last = NULL;
1247         stp->n_todos = 0;
1248
1249         // initialise the large object queues.
1250         stp->scavenged_large_objects = NULL;
1251         stp->n_scavenged_large_blocks = 0;
1252
1253         // mark the large objects as not evacuated yet
1254         for (bd = stp->large_objects; bd; bd = bd->link) {
1255             bd->flags &= ~BF_EVACUATED;
1256         }
1257
1258         // for a compacted step, we need to allocate the bitmap
1259         if (stp->is_compacted) {
1260             nat bitmap_size; // in bytes
1261             bdescr *bitmap_bdescr;
1262             StgWord *bitmap;
1263
1264             bitmap_size = stp->n_old_blocks * BLOCK_SIZE / (sizeof(W_)*BITS_PER_BYTE);
1265
1266             if (bitmap_size > 0) {
1267                 bitmap_bdescr = allocGroup((lnat)BLOCK_ROUND_UP(bitmap_size)
1268                                            / BLOCK_SIZE);
1269                 stp->bitmap = bitmap_bdescr;
1270                 bitmap = bitmap_bdescr->start;
1271
1272                 debugTrace(DEBUG_gc, "bitmap_size: %d, bitmap: %p",
1273                            bitmap_size, bitmap);
1274
1275                 // don't forget to fill it with zeros!
1276                 memset(bitmap, 0, bitmap_size);
1277
1278                 // For each block in this step, point to its bitmap from the
1279                 // block descriptor.
1280                 for (bd=stp->old_blocks; bd != NULL; bd = bd->link) {
1281                     bd->u.bitmap = bitmap;
1282                     bitmap += BLOCK_SIZE_W / (sizeof(W_)*BITS_PER_BYTE);
1283
1284                     // Also at this point we set the BF_COMPACTED flag
1285                     // for this block.  The invariant is that
1286                     // BF_COMPACTED is always unset, except during GC
1287                     // when it is set on those blocks which will be
1288                     // compacted.
1289                     bd->flags |= BF_COMPACTED;
1290                 }
1291             }
1292         }
1293     }
1294
1295     // For each GC thread, for each step, allocate a "todo" block to
1296     // store evacuated objects to be scavenged, and a block to store
1297     // evacuated objects that do not need to be scavenged.
1298     for (t = 0; t < n_threads; t++) {
1299         for (s = 0; s < generations[g].n_steps; s++) {
1300
1301             // we don't copy objects into g0s0, unless -G0
1302             if (g==0 && s==0 && RtsFlags.GcFlags.generations > 1) continue;
1303
1304             ws = &gc_threads[t]->steps[g * RtsFlags.GcFlags.steps + s];
1305
1306             ws->scan_bd = NULL;
1307             ws->scan = NULL;
1308
1309             ws->todo_large_objects = NULL;
1310
1311             // allocate the first to-space block; extra blocks will be
1312             // chained on as necessary.
1313             ws->todo_bd = NULL;
1314             ws->buffer_todo_bd = NULL;
1315             gc_alloc_todo_block(ws);
1316
1317             ws->scavd_list = NULL;
1318             ws->n_scavd_blocks = 0;
1319         }
1320     }
1321 }
1322
1323
1324 /* ----------------------------------------------------------------------------
1325    Initialise a generation that is *not* to be collected
1326    ------------------------------------------------------------------------- */
1327
1328 static void
1329 init_uncollected_gen (nat g, nat threads)
1330 {
1331     nat s, t, i;
1332     step_workspace *ws;
1333     step *stp;
1334     bdescr *bd;
1335
1336     for (s = 0; s < generations[g].n_steps; s++) {
1337         stp = &generations[g].steps[s];
1338         stp->scavenged_large_objects = NULL;
1339         stp->n_scavenged_large_blocks = 0;
1340     }
1341
1342     for (t = 0; t < threads; t++) {
1343         for (s = 0; s < generations[g].n_steps; s++) {
1344
1345             ws = &gc_threads[t]->steps[g * RtsFlags.GcFlags.steps + s];
1346             stp = ws->stp;
1347
1348             ws->buffer_todo_bd = NULL;
1349             ws->todo_large_objects = NULL;
1350
1351             ws->scavd_list = NULL;
1352             ws->n_scavd_blocks = 0;
1353
1354             // If the block at the head of the list in this generation
1355             // is less than 3/4 full, then use it as a todo block.
1356             if (stp->blocks && isPartiallyFull(stp->blocks))
1357             {
1358                 ws->todo_bd = stp->blocks;
1359                 ws->todo_free = ws->todo_bd->free;
1360                 ws->todo_lim = ws->todo_bd->start + BLOCK_SIZE_W;
1361                 stp->blocks = stp->blocks->link;
1362                 stp->n_blocks -= 1;
1363                 ws->todo_bd->link = NULL;
1364
1365                 // this block is also the scan block; we must scan
1366                 // from the current end point.
1367                 ws->scan_bd = ws->todo_bd;
1368                 ws->scan = ws->scan_bd->free;
1369
1370                 // subtract the contents of this block from the stats,
1371                 // because we'll count the whole block later.
1372                 copied -= ws->scan_bd->free - ws->scan_bd->start;
1373             }
1374             else
1375             {
1376                 ws->scan_bd = NULL;
1377                 ws->scan = NULL;
1378                 ws->todo_bd = NULL;
1379                 gc_alloc_todo_block(ws);
1380             }
1381         }
1382     }
1383
1384     // Move the private mutable lists from each capability onto the
1385     // main mutable list for the generation.
1386     for (i = 0; i < n_capabilities; i++) {
1387         for (bd = capabilities[i].mut_lists[g];
1388              bd->link != NULL; bd = bd->link) {
1389             /* nothing */
1390         }
1391         bd->link = generations[g].mut_list;
1392         generations[g].mut_list = capabilities[i].mut_lists[g];
1393         capabilities[i].mut_lists[g] = allocBlock();
1394     }
1395 }
1396
1397 /* -----------------------------------------------------------------------------
1398    Initialise a gc_thread before GC
1399    -------------------------------------------------------------------------- */
1400
1401 static void
1402 init_gc_thread (gc_thread *t)
1403 {
1404     t->static_objects = END_OF_STATIC_LIST;
1405     t->scavenged_static_objects = END_OF_STATIC_LIST;
1406     t->evac_step = 0;
1407     t->failed_to_evac = rtsFalse;
1408     t->eager_promotion = rtsTrue;
1409     t->thunk_selector_depth = 0;
1410     t->copied = 0;
1411     t->any_work = 0;
1412     t->no_work = 0;
1413     t->scav_find_work = 0;
1414
1415 }
1416
1417 /* -----------------------------------------------------------------------------
1418    Function we pass to GetRoots to evacuate roots.
1419    -------------------------------------------------------------------------- */
1420
1421 static void
1422 mark_root(StgClosure **root)
1423 {
1424   evacuate(root);
1425 }
1426
1427 /* -----------------------------------------------------------------------------
1428    Initialising the static object & mutable lists
1429    -------------------------------------------------------------------------- */
1430
1431 static void
1432 zero_static_object_list(StgClosure* first_static)
1433 {
1434   StgClosure* p;
1435   StgClosure* link;
1436   const StgInfoTable *info;
1437
1438   for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
1439     info = get_itbl(p);
1440     link = *STATIC_LINK(info, p);
1441     *STATIC_LINK(info,p) = NULL;
1442   }
1443 }
1444
1445 /* -----------------------------------------------------------------------------
1446    Reverting CAFs
1447    -------------------------------------------------------------------------- */
1448
1449 void
1450 revertCAFs( void )
1451 {
1452     StgIndStatic *c;
1453
1454     for (c = (StgIndStatic *)revertible_caf_list; c != NULL;
1455          c = (StgIndStatic *)c->static_link)
1456     {
1457         SET_INFO(c, c->saved_info);
1458         c->saved_info = NULL;
1459         // could, but not necessary: c->static_link = NULL;
1460     }
1461     revertible_caf_list = NULL;
1462 }
1463
1464 void
1465 markCAFs( evac_fn evac )
1466 {
1467     StgIndStatic *c;
1468
1469     for (c = (StgIndStatic *)caf_list; c != NULL;
1470          c = (StgIndStatic *)c->static_link)
1471     {
1472         evac(&c->indirectee);
1473     }
1474     for (c = (StgIndStatic *)revertible_caf_list; c != NULL;
1475          c = (StgIndStatic *)c->static_link)
1476     {
1477         evac(&c->indirectee);
1478     }
1479 }
1480
1481 /* ----------------------------------------------------------------------------
1482    Update the pointers from the task list
1483
1484    These are treated as weak pointers because we want to allow a main
1485    thread to get a BlockedOnDeadMVar exception in the same way as any
1486    other thread.  Note that the threads should all have been retained
1487    by GC by virtue of being on the all_threads list, we're just
1488    updating pointers here.
1489    ------------------------------------------------------------------------- */
1490
1491 static void
1492 update_task_list (void)
1493 {
1494     Task *task;
1495     StgTSO *tso;
1496     for (task = all_tasks; task != NULL; task = task->all_link) {
1497         if (!task->stopped && task->tso) {
1498             ASSERT(task->tso->bound == task);
1499             tso = (StgTSO *) isAlive((StgClosure *)task->tso);
1500             if (tso == NULL) {
1501                 barf("task %p: main thread %d has been GC'd",
1502 #ifdef THREADED_RTS
1503                      (void *)task->id,
1504 #else
1505                      (void *)task,
1506 #endif
1507                      task->tso->id);
1508             }
1509             task->tso = tso;
1510         }
1511     }
1512 }
1513
1514 /* ----------------------------------------------------------------------------
1515    Reset the sizes of the older generations when we do a major
1516    collection.
1517
1518    CURRENT STRATEGY: make all generations except zero the same size.
1519    We have to stay within the maximum heap size, and leave a certain
1520    percentage of the maximum heap size available to allocate into.
1521    ------------------------------------------------------------------------- */
1522
1523 static void
1524 resize_generations (void)
1525 {
1526     nat g;
1527
1528     if (major_gc && RtsFlags.GcFlags.generations > 1) {
1529         nat live, size, min_alloc;
1530         nat max  = RtsFlags.GcFlags.maxHeapSize;
1531         nat gens = RtsFlags.GcFlags.generations;
1532
1533         // live in the oldest generations
1534         live = oldest_gen->steps[0].n_blocks +
1535             oldest_gen->steps[0].n_large_blocks;
1536
1537         // default max size for all generations except zero
1538         size = stg_max(live * RtsFlags.GcFlags.oldGenFactor,
1539                        RtsFlags.GcFlags.minOldGenSize);
1540
1541         // minimum size for generation zero
1542         min_alloc = stg_max((RtsFlags.GcFlags.pcFreeHeap * max) / 200,
1543                             RtsFlags.GcFlags.minAllocAreaSize);
1544
1545         // Auto-enable compaction when the residency reaches a
1546         // certain percentage of the maximum heap size (default: 30%).
1547         if (RtsFlags.GcFlags.generations > 1 &&
1548             (RtsFlags.GcFlags.compact ||
1549              (max > 0 &&
1550               oldest_gen->steps[0].n_blocks >
1551               (RtsFlags.GcFlags.compactThreshold * max) / 100))) {
1552             oldest_gen->steps[0].is_compacted = 1;
1553 //        debugBelch("compaction: on\n", live);
1554         } else {
1555             oldest_gen->steps[0].is_compacted = 0;
1556 //        debugBelch("compaction: off\n", live);
1557         }
1558
1559         // if we're going to go over the maximum heap size, reduce the
1560         // size of the generations accordingly.  The calculation is
1561         // different if compaction is turned on, because we don't need
1562         // to double the space required to collect the old generation.
1563         if (max != 0) {
1564
1565             // this test is necessary to ensure that the calculations
1566             // below don't have any negative results - we're working
1567             // with unsigned values here.
1568             if (max < min_alloc) {
1569                 heapOverflow();
1570             }
1571
1572             if (oldest_gen->steps[0].is_compacted) {
1573                 if ( (size + (size - 1) * (gens - 2) * 2) + min_alloc > max ) {
1574                     size = (max - min_alloc) / ((gens - 1) * 2 - 1);
1575                 }
1576             } else {
1577                 if ( (size * (gens - 1) * 2) + min_alloc > max ) {
1578                     size = (max - min_alloc) / ((gens - 1) * 2);
1579                 }
1580             }
1581
1582             if (size < live) {
1583                 heapOverflow();
1584             }
1585         }
1586
1587 #if 0
1588         debugBelch("live: %d, min_alloc: %d, size : %d, max = %d\n", live,
1589                    min_alloc, size, max);
1590 #endif
1591
1592         for (g = 0; g < gens; g++) {
1593             generations[g].max_blocks = size;
1594         }
1595     }
1596 }
1597
1598 /* -----------------------------------------------------------------------------
1599    Calculate the new size of the nursery, and resize it.
1600    -------------------------------------------------------------------------- */
1601
1602 static void
1603 resize_nursery (void)
1604 {
1605     if (RtsFlags.GcFlags.generations == 1)
1606     {   // Two-space collector:
1607         nat blocks;
1608
1609         /* set up a new nursery.  Allocate a nursery size based on a
1610          * function of the amount of live data (by default a factor of 2)
1611          * Use the blocks from the old nursery if possible, freeing up any
1612          * left over blocks.
1613          *
1614          * If we get near the maximum heap size, then adjust our nursery
1615          * size accordingly.  If the nursery is the same size as the live
1616          * data (L), then we need 3L bytes.  We can reduce the size of the
1617          * nursery to bring the required memory down near 2L bytes.
1618          *
1619          * A normal 2-space collector would need 4L bytes to give the same
1620          * performance we get from 3L bytes, reducing to the same
1621          * performance at 2L bytes.
1622          */
1623         blocks = g0s0->n_old_blocks;
1624
1625         if ( RtsFlags.GcFlags.maxHeapSize != 0 &&
1626              blocks * RtsFlags.GcFlags.oldGenFactor * 2 >
1627              RtsFlags.GcFlags.maxHeapSize )
1628         {
1629             long adjusted_blocks;  // signed on purpose
1630             int pc_free;
1631
1632             adjusted_blocks = (RtsFlags.GcFlags.maxHeapSize - 2 * blocks);
1633
1634             debugTrace(DEBUG_gc, "near maximum heap size of 0x%x blocks, blocks = %d, adjusted to %ld",
1635                        RtsFlags.GcFlags.maxHeapSize, blocks, adjusted_blocks);
1636
1637             pc_free = adjusted_blocks * 100 / RtsFlags.GcFlags.maxHeapSize;
1638             if (pc_free < RtsFlags.GcFlags.pcFreeHeap) /* might even * be < 0 */
1639             {
1640                 heapOverflow();
1641             }
1642             blocks = adjusted_blocks;
1643         }
1644         else
1645         {
1646             blocks *= RtsFlags.GcFlags.oldGenFactor;
1647             if (blocks < RtsFlags.GcFlags.minAllocAreaSize)
1648             {
1649                 blocks = RtsFlags.GcFlags.minAllocAreaSize;
1650             }
1651         }
1652         resizeNurseries(blocks);
1653     }
1654     else  // Generational collector
1655     {
1656         /*
1657          * If the user has given us a suggested heap size, adjust our
1658          * allocation area to make best use of the memory available.
1659          */
1660         if (RtsFlags.GcFlags.heapSizeSuggestion)
1661         {
1662             long blocks;
1663             nat needed = calcNeeded();  // approx blocks needed at next GC
1664
1665             /* Guess how much will be live in generation 0 step 0 next time.
1666              * A good approximation is obtained by finding the
1667              * percentage of g0s0 that was live at the last minor GC.
1668              *
1669              * We have an accurate figure for the amount of copied data in
1670              * 'copied', but we must convert this to a number of blocks, with
1671              * a small adjustment for estimated slop at the end of a block
1672              * (- 10 words).
1673              */
1674             if (N == 0)
1675             {
1676                 g0s0_pcnt_kept = ((copied / (BLOCK_SIZE_W - 10)) * 100)
1677                     / countNurseryBlocks();
1678             }
1679
1680             /* Estimate a size for the allocation area based on the
1681              * information available.  We might end up going slightly under
1682              * or over the suggested heap size, but we should be pretty
1683              * close on average.
1684              *
1685              * Formula:            suggested - needed
1686              *                ----------------------------
1687              *                    1 + g0s0_pcnt_kept/100
1688              *
1689              * where 'needed' is the amount of memory needed at the next
1690              * collection for collecting all steps except g0s0.
1691              */
1692             blocks =
1693                 (((long)RtsFlags.GcFlags.heapSizeSuggestion - (long)needed) * 100) /
1694                 (100 + (long)g0s0_pcnt_kept);
1695
1696             if (blocks < (long)RtsFlags.GcFlags.minAllocAreaSize) {
1697                 blocks = RtsFlags.GcFlags.minAllocAreaSize;
1698             }
1699
1700             resizeNurseries((nat)blocks);
1701         }
1702         else
1703         {
1704             // we might have added extra large blocks to the nursery, so
1705             // resize back to minAllocAreaSize again.
1706             resizeNurseriesFixed(RtsFlags.GcFlags.minAllocAreaSize);
1707         }
1708     }
1709 }
1710
1711 /* -----------------------------------------------------------------------------
1712    Sanity code for CAF garbage collection.
1713
1714    With DEBUG turned on, we manage a CAF list in addition to the SRT
1715    mechanism.  After GC, we run down the CAF list and blackhole any
1716    CAFs which have been garbage collected.  This means we get an error
1717    whenever the program tries to enter a garbage collected CAF.
1718
1719    Any garbage collected CAFs are taken off the CAF list at the same
1720    time.
1721    -------------------------------------------------------------------------- */
1722
1723 #if 0 && defined(DEBUG)
1724
1725 static void
1726 gcCAFs(void)
1727 {
1728   StgClosure*  p;
1729   StgClosure** pp;
1730   const StgInfoTable *info;
1731   nat i;
1732
1733   i = 0;
1734   p = caf_list;
1735   pp = &caf_list;
1736
1737   while (p != NULL) {
1738
1739     info = get_itbl(p);
1740
1741     ASSERT(info->type == IND_STATIC);
1742
1743     if (STATIC_LINK(info,p) == NULL) {
1744         debugTrace(DEBUG_gccafs, "CAF gc'd at 0x%04lx", (long)p);
1745         // black hole it
1746         SET_INFO(p,&stg_BLACKHOLE_info);
1747         p = STATIC_LINK2(info,p);
1748         *pp = p;
1749     }
1750     else {
1751       pp = &STATIC_LINK2(info,p);
1752       p = *pp;
1753       i++;
1754     }
1755
1756   }
1757
1758   debugTrace(DEBUG_gccafs, "%d CAFs live", i);
1759 }
1760 #endif