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