rts/sm/GC.c

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