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