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