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