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