rts/sm/GC.c

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