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