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