rts/sm/GC.c

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