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