rts/sm/GC.c

   1 /* -----------------------------------------------------------------------------
   2  *
   3  * (c) The GHC Team 1998-2006
   4  *
   5  * Generational garbage collector
   6  *
   7  * Documentation on the architecture of the Garbage Collector can be
   8  * found in the online commentary:
   9  *
  10  *   http://hackage.haskell.org/trac/ghc/wiki/Commentary/Rts/Storage/GC
  11  *
  12  * ---------------------------------------------------------------------------*/
  13
  14 #include "PosixSource.h"
  15 #include "Rts.h"
  16 #include "RtsFlags.h"
  17 #include "RtsUtils.h"
  18 #include "Apply.h"
  19 #include "OSThreads.h"
  20 #include "LdvProfile.h"
  21 #include "Updates.h"
  22 #include "Stats.h"
  23 #include "Schedule.h"
  24 #include "Sanity.h"
  25 #include "BlockAlloc.h"
  26 #include "MBlock.h"
  27 #include "ProfHeap.h"
  28 #include "SchedAPI.h"
  29 #include "Weak.h"
  30 #include "Prelude.h"
  31 #include "ParTicky.h"           // ToDo: move into Rts.h
  32 #include "RtsSignals.h"
  33 #include "STM.h"
  34 #include "HsFFI.h"
  35 #include "Linker.h"
  36 #if defined(RTS_GTK_FRONTPANEL)
  37 #include "FrontPanel.h"
  38 #endif
  39 #include "Trace.h"
  40 #include "RetainerProfile.h"
  41 #include "RaiseAsync.h"
  42
  43 #include "GC.h"
  44 #include "Compact.h"
  45 #include "Evac.h"
  46 #include "Scav.h"
  47 #include "GCUtils.h"
  48 #include "MarkWeak.h"
  49
  50 #include <string.h> // for memset()
  51
  52 /* STATIC OBJECT LIST.
  53  *
  54  * During GC:
  55  * We maintain a linked list of static objects that are still live.
  56  * The requirements for this list are:
  57  *
  58  *  - we need to scan the list while adding to it, in order to
  59  *    scavenge all the static objects (in the same way that
  60  *    breadth-first scavenging works for dynamic objects).
  61  *
  62  *  - we need to be able to tell whether an object is already on
  63  *    the list, to break loops.
  64  *
  65  * Each static object has a "static link field", which we use for
  66  * linking objects on to the list.  We use a stack-type list, consing
  67  * objects on the front as they are added (this means that the
  68  * scavenge phase is depth-first, not breadth-first, but that
  69  * shouldn't matter).
  70  *
  71  * A separate list is kept for objects that have been scavenged
  72  * already - this is so that we can zero all the marks afterwards.
  73  *
  74  * An object is on the list if its static link field is non-zero; this
  75  * means that we have to mark the end of the list with '1', not NULL.
  76  *
  77  * Extra notes for generational GC:
  78  *
  79  * Each generation has a static object list associated with it.  When
  80  * collecting generations up to N, we treat the static object lists
  81  * from generations > N as roots.
  82  *
  83  * We build up a static object list while collecting generations 0..N,
  84  * which is then appended to the static object list of generation N+1.
  85  */
  86 StgClosure* static_objects;      // live static objects
  87 StgClosure* scavenged_static_objects;   // static objects scavenged so far
  88
  89 /* N is the oldest generation being collected, where the generations
  90  * are numbered starting at 0.  A major GC (indicated by the major_gc
  91  * flag) is when we're collecting all generations.  We only attempt to
  92  * deal with static objects and GC CAFs when doing a major GC.
  93  */
  94 nat N;
  95 rtsBool major_gc;
  96
  97 /* Youngest generation that objects should be evacuated to in
  98  * evacuate().  (Logically an argument to evacuate, but it's static
  99  * a lot of the time so we optimise it into a global variable).
 100  */
 101 nat evac_gen;
 102
 103 /* Whether to do eager promotion or not.
 104  */
 105 rtsBool eager_promotion;
 106
 107 /* Flag indicating failure to evacuate an object to the desired
 108  * generation.
 109  */
 110 rtsBool failed_to_evac;
 111
 112 /* Saved nursery (used for 2-space collector only)
 113  */
 114 static bdescr *saved_nursery;
 115 static nat saved_n_blocks;
 116
 117 /* Data used for allocation area sizing.
 118  */
 119 lnat new_blocks;                 // blocks allocated during this GC
 120 lnat new_scavd_blocks;   // ditto, but depth-first blocks
 121 static lnat g0s0_pcnt_kept = 30; // percentage of g0s0 live at last minor GC
 122
 123 /* Mut-list stats */
 124 #ifdef DEBUG
 125 nat mutlist_MUTVARS,
 126     mutlist_MUTARRS,
 127     mutlist_MVARS,
 128     mutlist_OTHERS;
 129 #endif
 130
 131 /* -----------------------------------------------------------------------------
 132    Static function declarations
 133    -------------------------------------------------------------------------- */
 134
 135 static void         mark_root               ( StgClosure **root );
 136
 137 static void         zero_static_object_list ( StgClosure* first_static );
 138
 139 #if 0 && defined(DEBUG)
 140 static void         gcCAFs                  ( void );
 141 #endif
 142
 143 /* -----------------------------------------------------------------------------
 144    inline functions etc. for dealing with the mark bitmap & stack.
 145    -------------------------------------------------------------------------- */
 146
 147 #define MARK_STACK_BLOCKS 4
 148
 149 bdescr *mark_stack_bdescr;
 150 StgPtr *mark_stack;
 151 StgPtr *mark_sp;
 152 StgPtr *mark_splim;
 153
 154 // Flag and pointers used for falling back to a linear scan when the
 155 // mark stack overflows.
 156 rtsBool mark_stack_overflowed;
 157 bdescr *oldgen_scan_bd;
 158 StgPtr  oldgen_scan;
 159
 160 /* -----------------------------------------------------------------------------
 161    GarbageCollect
 162
 163    Rough outline of the algorithm: for garbage collecting generation N
 164    (and all younger generations):
 165
 166      - follow all pointers in the root set.  the root set includes all
 167        mutable objects in all generations (mutable_list).
 168
 169      - for each pointer, evacuate the object it points to into either
 170
 171        + to-space of the step given by step->to, which is the next
 172          highest step in this generation or the first step in the next
 173          generation if this is the last step.
 174
 175        + to-space of generations[evac_gen]->steps[0], if evac_gen != 0.
 176          When we evacuate an object we attempt to evacuate
 177          everything it points to into the same generation - this is
 178          achieved by setting evac_gen to the desired generation.  If
 179          we can't do this, then an entry in the mut list has to
 180          be made for the cross-generation pointer.
 181
 182        + if the object is already in a generation > N, then leave
 183          it alone.
 184
 185      - repeatedly scavenge to-space from each step in each generation
 186        being collected until no more objects can be evacuated.
 187
 188      - free from-space in each step, and set from-space = to-space.
 189
 190    Locks held: all capabilities are held throughout GarbageCollect().
 191
 192    -------------------------------------------------------------------------- */
 193
 194 void
 195 GarbageCollect ( rtsBool force_major_gc )
 196 {
 197   bdescr *bd;
 198   step *stp;
 199   lnat live, allocated, copied = 0, scavd_copied = 0;
 200   lnat oldgen_saved_blocks = 0;
 201   nat g, s, i;
 202
 203 #ifdef PROFILING
 204   CostCentreStack *prev_CCS;
 205 #endif
 206
 207   ACQUIRE_SM_LOCK;
 208
 209   debugTrace(DEBUG_gc, "starting GC");
 210
 211 #if defined(RTS_USER_SIGNALS)
 212   if (RtsFlags.MiscFlags.install_signal_handlers) {
 213     // block signals
 214     blockUserSignals();
 215   }
 216 #endif
 217
 218   // tell the STM to discard any cached closures its hoping to re-use
 219   stmPreGCHook();
 220
 221   // tell the stats department that we've started a GC
 222   stat_startGC();
 223
 224 #ifdef DEBUG
 225   // check for memory leaks if DEBUG is on
 226   memInventory();
 227 #endif
 228
 229 #ifdef DEBUG
 230   mutlist_MUTVARS = 0;
 231   mutlist_MUTARRS = 0;
 232   mutlist_OTHERS = 0;
 233 #endif
 234
 235   // attribute any costs to CCS_GC
 236 #ifdef PROFILING
 237   prev_CCS = CCCS;
 238   CCCS = CCS_GC;
 239 #endif
 240
 241   /* Approximate how much we allocated.
 242    * Todo: only when generating stats?
 243    */
 244   allocated = calcAllocated();
 245
 246   /* Figure out which generation to collect
 247    */
 248   if (force_major_gc) {
 249     N = RtsFlags.GcFlags.generations - 1;
 250     major_gc = rtsTrue;
 251   } else {
 252     N = 0;
 253     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 254       if (generations[g].steps[0].n_blocks +
 255           generations[g].steps[0].n_large_blocks
 256           >= generations[g].max_blocks) {
 257         N = g;
 258       }
 259     }
 260     major_gc = (N == RtsFlags.GcFlags.generations-1);
 261   }
 262
 263 #ifdef RTS_GTK_FRONTPANEL
 264   if (RtsFlags.GcFlags.frontpanel) {
 265       updateFrontPanelBeforeGC(N);
 266   }
 267 #endif
 268
 269   // check stack sanity *before* GC (ToDo: check all threads)
 270   IF_DEBUG(sanity, checkFreeListSanity());
 271
 272   /* Initialise the static object lists
 273    */
 274   static_objects = END_OF_STATIC_LIST;
 275   scavenged_static_objects = END_OF_STATIC_LIST;
 276
 277   /* Save the nursery if we're doing a two-space collection.
 278    * g0s0->blocks will be used for to-space, so we need to get the
 279    * nursery out of the way.
 280    */
 281   if (RtsFlags.GcFlags.generations == 1) {
 282       saved_nursery = g0s0->blocks;
 283       saved_n_blocks = g0s0->n_blocks;
 284       g0s0->blocks = NULL;
 285       g0s0->n_blocks = 0;
 286   }
 287
 288   /* Keep a count of how many new blocks we allocated during this GC
 289    * (used for resizing the allocation area, later).
 290    */
 291   new_blocks = 0;
 292   new_scavd_blocks = 0;
 293
 294   // Initialise to-space in all the generations/steps that we're
 295   // collecting.
 296   //
 297   for (g = 0; g <= N; g++) {
 298
 299     // throw away the mutable list.  Invariant: the mutable list
 300     // always has at least one block; this means we can avoid a check for
 301     // NULL in recordMutable().
 302     if (g != 0) {
 303         freeChain(generations[g].mut_list);
 304         generations[g].mut_list = allocBlock();
 305         for (i = 0; i < n_capabilities; i++) {
 306             freeChain(capabilities[i].mut_lists[g]);
 307             capabilities[i].mut_lists[g] = allocBlock();
 308         }
 309     }
 310
 311     for (s = 0; s < generations[g].n_steps; s++) {
 312
 313       // generation 0, step 0 doesn't need to-space
 314       if (g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1) {
 315         continue;
 316       }
 317
 318       stp = &generations[g].steps[s];
 319       ASSERT(stp->gen_no == g);
 320
 321       // start a new to-space for this step.
 322       stp->old_blocks   = stp->blocks;
 323       stp->n_old_blocks = stp->n_blocks;
 324
 325       // allocate the first to-space block; extra blocks will be
 326       // chained on as necessary.
 327       stp->hp_bd     = NULL;
 328       bd = gc_alloc_block(stp);
 329       stp->blocks      = bd;
 330       stp->n_blocks    = 1;
 331       stp->scan        = bd->start;
 332       stp->scan_bd     = bd;
 333
 334       // allocate a block for "already scavenged" objects.  This goes
 335       // on the front of the stp->blocks list, so it won't be
 336       // traversed by the scavenging sweep.
 337       gc_alloc_scavd_block(stp);
 338
 339       // initialise the large object queues.
 340       stp->new_large_objects = NULL;
 341       stp->scavenged_large_objects = NULL;
 342       stp->n_scavenged_large_blocks = 0;
 343
 344       // mark the large objects as not evacuated yet
 345       for (bd = stp->large_objects; bd; bd = bd->link) {
 346         bd->flags &= ~BF_EVACUATED;
 347       }
 348
 349       // for a compacted step, we need to allocate the bitmap
 350       if (stp->is_compacted) {
 351           nat bitmap_size; // in bytes
 352           bdescr *bitmap_bdescr;
 353           StgWord *bitmap;
 354
 355           bitmap_size = stp->n_old_blocks * BLOCK_SIZE / (sizeof(W_)*BITS_PER_BYTE);
 356
 357           if (bitmap_size > 0) {
 358               bitmap_bdescr = allocGroup((lnat)BLOCK_ROUND_UP(bitmap_size)
 359                                          / BLOCK_SIZE);
 360               stp->bitmap = bitmap_bdescr;
 361               bitmap = bitmap_bdescr->start;
 362
 363               debugTrace(DEBUG_gc, "bitmap_size: %d, bitmap: %p",
 364                          bitmap_size, bitmap);
 365
 366               // don't forget to fill it with zeros!
 367               memset(bitmap, 0, bitmap_size);
 368
 369               // For each block in this step, point to its bitmap from the
 370               // block descriptor.
 371               for (bd=stp->old_blocks; bd != NULL; bd = bd->link) {
 372                   bd->u.bitmap = bitmap;
 373                   bitmap += BLOCK_SIZE_W / (sizeof(W_)*BITS_PER_BYTE);
 374
 375                   // Also at this point we set the BF_COMPACTED flag
 376                   // for this block.  The invariant is that
 377                   // BF_COMPACTED is always unset, except during GC
 378                   // when it is set on those blocks which will be
 379                   // compacted.
 380                   bd->flags |= BF_COMPACTED;
 381               }
 382           }
 383       }
 384     }
 385   }
 386
 387   /* make sure the older generations have at least one block to
 388    * allocate into (this makes things easier for copy(), see below).
 389    */
 390   for (g = N+1; g < RtsFlags.GcFlags.generations; g++) {
 391     for (s = 0; s < generations[g].n_steps; s++) {
 392       stp = &generations[g].steps[s];
 393       if (stp->hp_bd == NULL) {
 394           ASSERT(stp->blocks == NULL);
 395           bd = gc_alloc_block(stp);
 396           stp->blocks = bd;
 397           stp->n_blocks = 1;
 398       }
 399       if (stp->scavd_hp == NULL) {
 400           gc_alloc_scavd_block(stp);
 401           stp->n_blocks++;
 402       }
 403       /* Set the scan pointer for older generations: remember we
 404        * still have to scavenge objects that have been promoted. */
 405       stp->scan = stp->hp;
 406       stp->scan_bd = stp->hp_bd;
 407       stp->new_large_objects = NULL;
 408       stp->scavenged_large_objects = NULL;
 409       stp->n_scavenged_large_blocks = 0;
 410     }
 411
 412     /* Move the private mutable lists from each capability onto the
 413      * main mutable list for the generation.
 414      */
 415     for (i = 0; i < n_capabilities; i++) {
 416         for (bd = capabilities[i].mut_lists[g];
 417              bd->link != NULL; bd = bd->link) {
 418             /* nothing */
 419         }
 420         bd->link = generations[g].mut_list;
 421         generations[g].mut_list = capabilities[i].mut_lists[g];
 422         capabilities[i].mut_lists[g] = allocBlock();
 423     }
 424   }
 425
 426   /* Allocate a mark stack if we're doing a major collection.
 427    */
 428   if (major_gc) {
 429       mark_stack_bdescr = allocGroup(MARK_STACK_BLOCKS);
 430       mark_stack = (StgPtr *)mark_stack_bdescr->start;
 431       mark_sp    = mark_stack;
 432       mark_splim = mark_stack + (MARK_STACK_BLOCKS * BLOCK_SIZE_W);
 433   } else {
 434       mark_stack_bdescr = NULL;
 435   }
 436
 437   eager_promotion = rtsTrue; // for now
 438
 439   /* -----------------------------------------------------------------------
 440    * follow all the roots that we know about:
 441    *   - mutable lists from each generation > N
 442    * we want to *scavenge* these roots, not evacuate them: they're not
 443    * going to move in this GC.
 444    * Also: do them in reverse generation order.  This is because we
 445    * often want to promote objects that are pointed to by older
 446    * generations early, so we don't have to repeatedly copy them.
 447    * Doing the generations in reverse order ensures that we don't end
 448    * up in the situation where we want to evac an object to gen 3 and
 449    * it has already been evaced to gen 2.
 450    */
 451   {
 452     int st;
 453     for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
 454       generations[g].saved_mut_list = generations[g].mut_list;
 455       generations[g].mut_list = allocBlock();
 456         // mut_list always has at least one block.
 457     }
 458
 459     for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
 460       scavenge_mutable_list(&generations[g]);
 461       evac_gen = g;
 462       for (st = generations[g].n_steps-1; st >= 0; st--) {
 463         scavenge(&generations[g].steps[st]);
 464       }
 465     }
 466   }
 467
 468   /* follow roots from the CAF list (used by GHCi)
 469    */
 470   evac_gen = 0;
 471   markCAFs(mark_root);
 472
 473   /* follow all the roots that the application knows about.
 474    */
 475   evac_gen = 0;
 476   GetRoots(mark_root);
 477
 478   /* Mark the weak pointer list, and prepare to detect dead weak
 479    * pointers.
 480    */
 481   markWeakPtrList();
 482   initWeakForGC();
 483
 484   /* Mark the stable pointer table.
 485    */
 486   markStablePtrTable(mark_root);
 487
 488   /* -------------------------------------------------------------------------
 489    * Repeatedly scavenge all the areas we know about until there's no
 490    * more scavenging to be done.
 491    */
 492   {
 493     rtsBool flag;
 494   loop:
 495     flag = rtsFalse;
 496
 497     // scavenge static objects
 498     if (major_gc && static_objects != END_OF_STATIC_LIST) {
 499         IF_DEBUG(sanity, checkStaticObjects(static_objects));
 500         scavenge_static();
 501     }
 502
 503     /* When scavenging the older generations:  Objects may have been
 504      * evacuated from generations <= N into older generations, and we
 505      * need to scavenge these objects.  We're going to try to ensure that
 506      * any evacuations that occur move the objects into at least the
 507      * same generation as the object being scavenged, otherwise we
 508      * have to create new entries on the mutable list for the older
 509      * generation.
 510      */
 511
 512     // scavenge each step in generations 0..maxgen
 513     {
 514       long gen;
 515       int st;
 516
 517     loop2:
 518       // scavenge objects in compacted generation
 519       if (mark_stack_overflowed || oldgen_scan_bd != NULL ||
 520           (mark_stack_bdescr != NULL && !mark_stack_empty())) {
 521           scavenge_mark_stack();
 522           flag = rtsTrue;
 523       }
 524
 525       for (gen = RtsFlags.GcFlags.generations; --gen >= 0; ) {
 526         for (st = generations[gen].n_steps; --st >= 0; ) {
 527           if (gen == 0 && st == 0 && RtsFlags.GcFlags.generations > 1) {
 528             continue;
 529           }
 530           stp = &generations[gen].steps[st];
 531           evac_gen = gen;
 532           if (stp->hp_bd != stp->scan_bd || stp->scan < stp->hp) {
 533             scavenge(stp);
 534             flag = rtsTrue;
 535             goto loop2;
 536           }
 537           if (stp->new_large_objects != NULL) {
 538             scavenge_large(stp);
 539             flag = rtsTrue;
 540             goto loop2;
 541           }
 542         }
 543       }
 544     }
 545
 546     // if any blackholes are alive, make the threads that wait on
 547     // them alive too.
 548     if (traverseBlackholeQueue())
 549         flag = rtsTrue;
 550
 551     if (flag) { goto loop; }
 552
 553     // must be last...  invariant is that everything is fully
 554     // scavenged at this point.
 555     if (traverseWeakPtrList()) { // returns rtsTrue if evaced something
 556       goto loop;
 557     }
 558   }
 559
 560   /* Update the pointers from the task list - these are
 561    * treated as weak pointers because we want to allow a main thread
 562    * to get a BlockedOnDeadMVar exception in the same way as any other
 563    * thread.  Note that the threads should all have been retained by
 564    * GC by virtue of being on the all_threads list, we're just
 565    * updating pointers here.
 566    */
 567   {
 568       Task *task;
 569       StgTSO *tso;
 570       for (task = all_tasks; task != NULL; task = task->all_link) {
 571           if (!task->stopped && task->tso) {
 572               ASSERT(task->tso->bound == task);
 573               tso = (StgTSO *) isAlive((StgClosure *)task->tso);
 574               if (tso == NULL) {
 575                   barf("task %p: main thread %d has been GC'd",
 576 #ifdef THREADED_RTS
 577                        (void *)task->id,
 578 #else
 579                        (void *)task,
 580 #endif
 581                        task->tso->id);
 582               }
 583               task->tso = tso;
 584           }
 585       }
 586   }
 587
 588   // Now see which stable names are still alive.
 589   gcStablePtrTable();
 590
 591   // Tidy the end of the to-space chains
 592   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 593       for (s = 0; s < generations[g].n_steps; s++) {
 594           stp = &generations[g].steps[s];
 595           if (!(g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1)) {
 596               ASSERT(Bdescr(stp->hp) == stp->hp_bd);
 597               stp->hp_bd->free = stp->hp;
 598               Bdescr(stp->scavd_hp)->free = stp->scavd_hp;
 599           }
 600       }
 601   }
 602
 603 #ifdef PROFILING
 604   // We call processHeapClosureForDead() on every closure destroyed during
 605   // the current garbage collection, so we invoke LdvCensusForDead().
 606   if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_LDV
 607       || RtsFlags.ProfFlags.bioSelector != NULL)
 608     LdvCensusForDead(N);
 609 #endif
 610
 611   // NO MORE EVACUATION AFTER THIS POINT!
 612   // Finally: compaction of the oldest generation.
 613   if (major_gc && oldest_gen->steps[0].is_compacted) {
 614       // save number of blocks for stats
 615       oldgen_saved_blocks = oldest_gen->steps[0].n_old_blocks;
 616       compact();
 617   }
 618
 619   IF_DEBUG(sanity, checkGlobalTSOList(rtsFalse));
 620
 621   /* run through all the generations/steps and tidy up
 622    */
 623   copied = new_blocks * BLOCK_SIZE_W;
 624   scavd_copied =  new_scavd_blocks * BLOCK_SIZE_W;
 625   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 626
 627     if (g <= N) {
 628       generations[g].collections++; // for stats
 629     }
 630
 631     // Count the mutable list as bytes "copied" for the purposes of
 632     // stats.  Every mutable list is copied during every GC.
 633     if (g > 0) {
 634         nat mut_list_size = 0;
 635         for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
 636             mut_list_size += bd->free - bd->start;
 637         }
 638         copied +=  mut_list_size;
 639
 640         debugTrace(DEBUG_gc,
 641                    "mut_list_size: %lu (%d vars, %d arrays, %d MVARs, %d others)",
 642                    (unsigned long)(mut_list_size * sizeof(W_)),
 643                    mutlist_MUTVARS, mutlist_MUTARRS, mutlist_MVARS, mutlist_OTHERS);
 644     }
 645
 646     for (s = 0; s < generations[g].n_steps; s++) {
 647       bdescr *next;
 648       stp = &generations[g].steps[s];
 649
 650       if (!(g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1)) {
 651         // stats information: how much we copied
 652         if (g <= N) {
 653           copied -= stp->hp_bd->start + BLOCK_SIZE_W -
 654             stp->hp_bd->free;
 655           scavd_copied -= stp->scavd_hpLim - stp->scavd_hp;
 656         }
 657       }
 658
 659       // for generations we collected...
 660       if (g <= N) {
 661
 662         /* free old memory and shift to-space into from-space for all
 663          * the collected steps (except the allocation area).  These
 664          * freed blocks will probaby be quickly recycled.
 665          */
 666         if (!(g == 0 && s == 0)) {
 667             if (stp->is_compacted) {
 668                 // for a compacted step, just shift the new to-space
 669                 // onto the front of the now-compacted existing blocks.
 670                 for (bd = stp->blocks; bd != NULL; bd = bd->link) {
 671                     bd->flags &= ~BF_EVACUATED;  // now from-space
 672                 }
 673                 // tack the new blocks on the end of the existing blocks
 674                 if (stp->old_blocks != NULL) {
 675                     for (bd = stp->old_blocks; bd != NULL; bd = next) {
 676                         // NB. this step might not be compacted next
 677                         // time, so reset the BF_COMPACTED flags.
 678                         // They are set before GC if we're going to
 679                         // compact.  (search for BF_COMPACTED above).
 680                         bd->flags &= ~BF_COMPACTED;
 681                         next = bd->link;
 682                         if (next == NULL) {
 683                             bd->link = stp->blocks;
 684                         }
 685                     }
 686                     stp->blocks = stp->old_blocks;
 687                 }
 688                 // add the new blocks to the block tally
 689                 stp->n_blocks += stp->n_old_blocks;
 690                 ASSERT(countBlocks(stp->blocks) == stp->n_blocks);
 691             } else {
 692                 freeChain(stp->old_blocks);
 693                 for (bd = stp->blocks; bd != NULL; bd = bd->link) {
 694                     bd->flags &= ~BF_EVACUATED;  // now from-space
 695                 }
 696             }
 697             stp->old_blocks = NULL;
 698             stp->n_old_blocks = 0;
 699         }
 700
 701         /* LARGE OBJECTS.  The current live large objects are chained on
 702          * scavenged_large, having been moved during garbage
 703          * collection from large_objects.  Any objects left on
 704          * large_objects list are therefore dead, so we free them here.
 705          */
 706         for (bd = stp->large_objects; bd != NULL; bd = next) {
 707           next = bd->link;
 708           freeGroup(bd);
 709           bd = next;
 710         }
 711
 712         // update the count of blocks used by large objects
 713         for (bd = stp->scavenged_large_objects; bd != NULL; bd = bd->link) {
 714           bd->flags &= ~BF_EVACUATED;
 715         }
 716         stp->large_objects  = stp->scavenged_large_objects;
 717         stp->n_large_blocks = stp->n_scavenged_large_blocks;
 718
 719       } else {
 720         // for older generations...
 721
 722         /* For older generations, we need to append the
 723          * scavenged_large_object list (i.e. large objects that have been
 724          * promoted during this GC) to the large_object list for that step.
 725          */
 726         for (bd = stp->scavenged_large_objects; bd; bd = next) {
 727           next = bd->link;
 728           bd->flags &= ~BF_EVACUATED;
 729           dbl_link_onto(bd, &stp->large_objects);
 730         }
 731
 732         // add the new blocks we promoted during this GC
 733         stp->n_large_blocks += stp->n_scavenged_large_blocks;
 734       }
 735     }
 736   }
 737
 738   /* Reset the sizes of the older generations when we do a major
 739    * collection.
 740    *
 741    * CURRENT STRATEGY: make all generations except zero the same size.
 742    * We have to stay within the maximum heap size, and leave a certain
 743    * percentage of the maximum heap size available to allocate into.
 744    */
 745   if (major_gc && RtsFlags.GcFlags.generations > 1) {
 746       nat live, size, min_alloc;
 747       nat max  = RtsFlags.GcFlags.maxHeapSize;
 748       nat gens = RtsFlags.GcFlags.generations;
 749
 750       // live in the oldest generations
 751       live = oldest_gen->steps[0].n_blocks +
 752              oldest_gen->steps[0].n_large_blocks;
 753
 754       // default max size for all generations except zero
 755       size = stg_max(live * RtsFlags.GcFlags.oldGenFactor,
 756                      RtsFlags.GcFlags.minOldGenSize);
 757
 758       // minimum size for generation zero
 759       min_alloc = stg_max((RtsFlags.GcFlags.pcFreeHeap * max) / 200,
 760                           RtsFlags.GcFlags.minAllocAreaSize);
 761
 762       // Auto-enable compaction when the residency reaches a
 763       // certain percentage of the maximum heap size (default: 30%).
 764       if (RtsFlags.GcFlags.generations > 1 &&
 765           (RtsFlags.GcFlags.compact ||
 766            (max > 0 &&
 767             oldest_gen->steps[0].n_blocks >
 768             (RtsFlags.GcFlags.compactThreshold * max) / 100))) {
 769           oldest_gen->steps[0].is_compacted = 1;
 770 //        debugBelch("compaction: on\n", live);
 771       } else {
 772           oldest_gen->steps[0].is_compacted = 0;
 773 //        debugBelch("compaction: off\n", live);
 774       }
 775
 776       // if we're going to go over the maximum heap size, reduce the
 777       // size of the generations accordingly.  The calculation is
 778       // different if compaction is turned on, because we don't need
 779       // to double the space required to collect the old generation.
 780       if (max != 0) {
 781
 782           // this test is necessary to ensure that the calculations
 783           // below don't have any negative results - we're working
 784           // with unsigned values here.
 785           if (max < min_alloc) {
 786               heapOverflow();
 787           }
 788
 789           if (oldest_gen->steps[0].is_compacted) {
 790               if ( (size + (size - 1) * (gens - 2) * 2) + min_alloc > max ) {
 791                   size = (max - min_alloc) / ((gens - 1) * 2 - 1);
 792               }
 793           } else {
 794               if ( (size * (gens - 1) * 2) + min_alloc > max ) {
 795                   size = (max - min_alloc) / ((gens - 1) * 2);
 796               }
 797           }
 798
 799           if (size < live) {
 800               heapOverflow();
 801           }
 802       }
 803
 804 #if 0
 805       debugBelch("live: %d, min_alloc: %d, size : %d, max = %d\n", live,
 806               min_alloc, size, max);
 807 #endif
 808
 809       for (g = 0; g < gens; g++) {
 810           generations[g].max_blocks = size;
 811       }
 812   }
 813
 814   // Guess the amount of live data for stats.
 815   live = calcLive();
 816
 817   /* Free the small objects allocated via allocate(), since this will
 818    * all have been copied into G0S1 now.
 819    */
 820   if (small_alloc_list != NULL) {
 821     freeChain(small_alloc_list);
 822   }
 823   small_alloc_list = NULL;
 824   alloc_blocks = 0;
 825   alloc_Hp = NULL;
 826   alloc_HpLim = NULL;
 827   alloc_blocks_lim = RtsFlags.GcFlags.minAllocAreaSize;
 828
 829   // Start a new pinned_object_block
 830   pinned_object_block = NULL;
 831
 832   /* Free the mark stack.
 833    */
 834   if (mark_stack_bdescr != NULL) {
 835       freeGroup(mark_stack_bdescr);
 836   }
 837
 838   /* Free any bitmaps.
 839    */
 840   for (g = 0; g <= N; g++) {
 841       for (s = 0; s < generations[g].n_steps; s++) {
 842           stp = &generations[g].steps[s];
 843           if (stp->bitmap != NULL) {
 844               freeGroup(stp->bitmap);
 845               stp->bitmap = NULL;
 846           }
 847       }
 848   }
 849
 850   /* Two-space collector:
 851    * Free the old to-space, and estimate the amount of live data.
 852    */
 853   if (RtsFlags.GcFlags.generations == 1) {
 854     nat blocks;
 855
 856     if (g0s0->old_blocks != NULL) {
 857       freeChain(g0s0->old_blocks);
 858     }
 859     for (bd = g0s0->blocks; bd != NULL; bd = bd->link) {
 860       bd->flags = 0;    // now from-space
 861     }
 862     g0s0->old_blocks = g0s0->blocks;
 863     g0s0->n_old_blocks = g0s0->n_blocks;
 864     g0s0->blocks = saved_nursery;
 865     g0s0->n_blocks = saved_n_blocks;
 866
 867     /* For a two-space collector, we need to resize the nursery. */
 868
 869     /* set up a new nursery.  Allocate a nursery size based on a
 870      * function of the amount of live data (by default a factor of 2)
 871      * Use the blocks from the old nursery if possible, freeing up any
 872      * left over blocks.
 873      *
 874      * If we get near the maximum heap size, then adjust our nursery
 875      * size accordingly.  If the nursery is the same size as the live
 876      * data (L), then we need 3L bytes.  We can reduce the size of the
 877      * nursery to bring the required memory down near 2L bytes.
 878      *
 879      * A normal 2-space collector would need 4L bytes to give the same
 880      * performance we get from 3L bytes, reducing to the same
 881      * performance at 2L bytes.
 882      */
 883     blocks = g0s0->n_old_blocks;
 884
 885     if ( RtsFlags.GcFlags.maxHeapSize != 0 &&
 886          blocks * RtsFlags.GcFlags.oldGenFactor * 2 >
 887            RtsFlags.GcFlags.maxHeapSize ) {
 888       long adjusted_blocks;  // signed on purpose
 889       int pc_free;
 890
 891       adjusted_blocks = (RtsFlags.GcFlags.maxHeapSize - 2 * blocks);
 892
 893       debugTrace(DEBUG_gc, "near maximum heap size of 0x%x blocks, blocks = %d, adjusted to %ld",
 894                  RtsFlags.GcFlags.maxHeapSize, blocks, adjusted_blocks);
 895
 896       pc_free = adjusted_blocks * 100 / RtsFlags.GcFlags.maxHeapSize;
 897       if (pc_free < RtsFlags.GcFlags.pcFreeHeap) /* might even be < 0 */ {
 898         heapOverflow();
 899       }
 900       blocks = adjusted_blocks;
 901
 902     } else {
 903       blocks *= RtsFlags.GcFlags.oldGenFactor;
 904       if (blocks < RtsFlags.GcFlags.minAllocAreaSize) {
 905         blocks = RtsFlags.GcFlags.minAllocAreaSize;
 906       }
 907     }
 908     resizeNurseries(blocks);
 909
 910   } else {
 911     /* Generational collector:
 912      * If the user has given us a suggested heap size, adjust our
 913      * allocation area to make best use of the memory available.
 914      */
 915
 916     if (RtsFlags.GcFlags.heapSizeSuggestion) {
 917       long blocks;
 918       nat needed = calcNeeded();        // approx blocks needed at next GC
 919
 920       /* Guess how much will be live in generation 0 step 0 next time.
 921        * A good approximation is obtained by finding the
 922        * percentage of g0s0 that was live at the last minor GC.
 923        */
 924       if (N == 0) {
 925         g0s0_pcnt_kept = (new_blocks * 100) / countNurseryBlocks();
 926       }
 927
 928       /* Estimate a size for the allocation area based on the
 929        * information available.  We might end up going slightly under
 930        * or over the suggested heap size, but we should be pretty
 931        * close on average.
 932        *
 933        * Formula:            suggested - needed
 934        *                ----------------------------
 935        *                    1 + g0s0_pcnt_kept/100
 936        *
 937        * where 'needed' is the amount of memory needed at the next
 938        * collection for collecting all steps except g0s0.
 939        */
 940       blocks =
 941         (((long)RtsFlags.GcFlags.heapSizeSuggestion - (long)needed) * 100) /
 942         (100 + (long)g0s0_pcnt_kept);
 943
 944       if (blocks < (long)RtsFlags.GcFlags.minAllocAreaSize) {
 945         blocks = RtsFlags.GcFlags.minAllocAreaSize;
 946       }
 947
 948       resizeNurseries((nat)blocks);
 949
 950     } else {
 951       // we might have added extra large blocks to the nursery, so
 952       // resize back to minAllocAreaSize again.
 953       resizeNurseriesFixed(RtsFlags.GcFlags.minAllocAreaSize);
 954     }
 955   }
 956
 957  // mark the garbage collected CAFs as dead
 958 #if 0 && defined(DEBUG) // doesn't work at the moment
 959   if (major_gc) { gcCAFs(); }
 960 #endif
 961
 962 #ifdef PROFILING
 963   // resetStaticObjectForRetainerProfiling() must be called before
 964   // zeroing below.
 965   resetStaticObjectForRetainerProfiling();
 966 #endif
 967
 968   // zero the scavenged static object list
 969   if (major_gc) {
 970     zero_static_object_list(scavenged_static_objects);
 971   }
 972
 973   // Reset the nursery
 974   resetNurseries();
 975
 976   // start any pending finalizers
 977   RELEASE_SM_LOCK;
 978   scheduleFinalizers(last_free_capability, old_weak_ptr_list);
 979   ACQUIRE_SM_LOCK;
 980
 981   // send exceptions to any threads which were about to die
 982   RELEASE_SM_LOCK;
 983   resurrectThreads(resurrected_threads);
 984   ACQUIRE_SM_LOCK;
 985
 986   // Update the stable pointer hash table.
 987   updateStablePtrTable(major_gc);
 988
 989   // check sanity after GC
 990   IF_DEBUG(sanity, checkSanity());
 991
 992   // extra GC trace info
 993   IF_DEBUG(gc, statDescribeGens());
 994
 995 #ifdef DEBUG
 996   // symbol-table based profiling
 997   /*  heapCensus(to_blocks); */ /* ToDo */
 998 #endif
 999
1000   // restore enclosing cost centre
1001 #ifdef PROFILING
1002   CCCS = prev_CCS;
1003 #endif
1004
1005 #ifdef DEBUG
1006   // check for memory leaks if DEBUG is on
1007   memInventory();
1008 #endif
1009
1010 #ifdef RTS_GTK_FRONTPANEL
1011   if (RtsFlags.GcFlags.frontpanel) {
1012       updateFrontPanelAfterGC( N, live );
1013   }
1014 #endif
1015
1016   // ok, GC over: tell the stats department what happened.
1017   stat_endGC(allocated, live, copied, scavd_copied, N);
1018
1019 #if defined(RTS_USER_SIGNALS)
1020   if (RtsFlags.MiscFlags.install_signal_handlers) {
1021     // unblock signals again
1022     unblockUserSignals();
1023   }
1024 #endif
1025
1026   RELEASE_SM_LOCK;
1027 }
1028
1029 /* -----------------------------------------------------------------------------
1030    isAlive determines whether the given closure is still alive (after
1031    a garbage collection) or not.  It returns the new address of the
1032    closure if it is alive, or NULL otherwise.
1033
1034    NOTE: Use it before compaction only!
1035          It untags and (if needed) retags pointers to closures.
1036    -------------------------------------------------------------------------- */
1037
1038
1039 StgClosure *
1040 isAlive(StgClosure *p)
1041 {
1042   const StgInfoTable *info;
1043   bdescr *bd;
1044   StgWord tag;
1045
1046   while (1) {
1047     /* The tag and the pointer are split, to be merged later when needed. */
1048     tag = GET_CLOSURE_TAG(p);
1049     p = UNTAG_CLOSURE(p);
1050
1051     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
1052     info = get_itbl(p);
1053
1054     // ignore static closures
1055     //
1056     // ToDo: for static closures, check the static link field.
1057     // Problem here is that we sometimes don't set the link field, eg.
1058     // for static closures with an empty SRT or CONSTR_STATIC_NOCAFs.
1059     //
1060     if (!HEAP_ALLOCED(p)) {
1061         return TAG_CLOSURE(tag,p);
1062     }
1063
1064     // ignore closures in generations that we're not collecting.
1065     bd = Bdescr((P_)p);
1066     if (bd->gen_no > N) {
1067         return TAG_CLOSURE(tag,p);
1068     }
1069
1070     // if it's a pointer into to-space, then we're done
1071     if (bd->flags & BF_EVACUATED) {
1072         return TAG_CLOSURE(tag,p);
1073     }
1074
1075     // large objects use the evacuated flag
1076     if (bd->flags & BF_LARGE) {
1077         return NULL;
1078     }
1079
1080     // check the mark bit for compacted steps
1081     if ((bd->flags & BF_COMPACTED) && is_marked((P_)p,bd)) {
1082         return TAG_CLOSURE(tag,p);
1083     }
1084
1085     switch (info->type) {
1086
1087     case IND:
1088     case IND_STATIC:
1089     case IND_PERM:
1090     case IND_OLDGEN:            // rely on compatible layout with StgInd
1091     case IND_OLDGEN_PERM:
1092       // follow indirections
1093       p = ((StgInd *)p)->indirectee;
1094       continue;
1095
1096     case EVACUATED:
1097       // alive!
1098       return ((StgEvacuated *)p)->evacuee;
1099
1100     case TSO:
1101       if (((StgTSO *)p)->what_next == ThreadRelocated) {
1102         p = (StgClosure *)((StgTSO *)p)->link;
1103         continue;
1104       }
1105       return NULL;
1106
1107     default:
1108       // dead.
1109       return NULL;
1110     }
1111   }
1112 }
1113
1114 static void
1115 mark_root(StgClosure **root)
1116 {
1117   *root = evacuate(*root);
1118 }
1119
1120 /* -----------------------------------------------------------------------------
1121    Initialising the static object & mutable lists
1122    -------------------------------------------------------------------------- */
1123
1124 static void
1125 zero_static_object_list(StgClosure* first_static)
1126 {
1127   StgClosure* p;
1128   StgClosure* link;
1129   const StgInfoTable *info;
1130
1131   for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
1132     info = get_itbl(p);
1133     link = *STATIC_LINK(info, p);
1134     *STATIC_LINK(info,p) = NULL;
1135   }
1136 }
1137
1138 /* -----------------------------------------------------------------------------
1139    Reverting CAFs
1140    -------------------------------------------------------------------------- */
1141
1142 void
1143 revertCAFs( void )
1144 {
1145     StgIndStatic *c;
1146
1147     for (c = (StgIndStatic *)revertible_caf_list; c != NULL;
1148          c = (StgIndStatic *)c->static_link)
1149     {
1150         SET_INFO(c, c->saved_info);
1151         c->saved_info = NULL;
1152         // could, but not necessary: c->static_link = NULL;
1153     }
1154     revertible_caf_list = NULL;
1155 }
1156
1157 void
1158 markCAFs( evac_fn evac )
1159 {
1160     StgIndStatic *c;
1161
1162     for (c = (StgIndStatic *)caf_list; c != NULL;
1163          c = (StgIndStatic *)c->static_link)
1164     {
1165         evac(&c->indirectee);
1166     }
1167     for (c = (StgIndStatic *)revertible_caf_list; c != NULL;
1168          c = (StgIndStatic *)c->static_link)
1169     {
1170         evac(&c->indirectee);
1171     }
1172 }
1173
1174 /* -----------------------------------------------------------------------------
1175    Sanity code for CAF garbage collection.
1176
1177    With DEBUG turned on, we manage a CAF list in addition to the SRT
1178    mechanism.  After GC, we run down the CAF list and blackhole any
1179    CAFs which have been garbage collected.  This means we get an error
1180    whenever the program tries to enter a garbage collected CAF.
1181
1182    Any garbage collected CAFs are taken off the CAF list at the same
1183    time.
1184    -------------------------------------------------------------------------- */
1185
1186 #if 0 && defined(DEBUG)
1187
1188 static void
1189 gcCAFs(void)
1190 {
1191   StgClosure*  p;
1192   StgClosure** pp;
1193   const StgInfoTable *info;
1194   nat i;
1195
1196   i = 0;
1197   p = caf_list;
1198   pp = &caf_list;
1199
1200   while (p != NULL) {
1201
1202     info = get_itbl(p);
1203
1204     ASSERT(info->type == IND_STATIC);
1205
1206     if (STATIC_LINK(info,p) == NULL) {
1207         debugTrace(DEBUG_gccafs, "CAF gc'd at 0x%04lx", (long)p);
1208         // black hole it
1209         SET_INFO(p,&stg_BLACKHOLE_info);
1210         p = STATIC_LINK2(info,p);
1211         *pp = p;
1212     }
1213     else {
1214       pp = &STATIC_LINK2(info,p);
1215       p = *pp;
1216       i++;
1217     }
1218
1219   }
1220
1221   debugTrace(DEBUG_gccafs, "%d CAFs live", i);
1222 }
1223 #endif
1224
1225 /* -----------------------------------------------------------------------------
1226  * Debugging
1227  * -------------------------------------------------------------------------- */
1228
1229 #if DEBUG
1230 void
1231 printMutableList(generation *gen)
1232 {
1233     bdescr *bd;
1234     StgPtr p;
1235
1236     debugBelch("mutable list %p: ", gen->mut_list);
1237
1238     for (bd = gen->mut_list; bd != NULL; bd = bd->link) {
1239         for (p = bd->start; p < bd->free; p++) {
1240             debugBelch("%p (%s), ", (void *)*p, info_type((StgClosure *)*p));
1241         }
1242     }
1243     debugBelch("\n");
1244 }
1245 #endif /* DEBUG */