rts/sm/GC.c

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