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