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   /* -------------------------------------------------------------------------
 486    * Repeatedly scavenge all the areas we know about until there's no
 487    * more scavenging to be done.
 488    */
 489   {
 490     rtsBool flag;
 491   loop:
 492     flag = rtsFalse;
 493
 494     // scavenge static objects
 495     if (major_gc && static_objects != END_OF_STATIC_LIST) {
 496         IF_DEBUG(sanity, checkStaticObjects(static_objects));
 497         scavenge_static();
 498     }
 499
 500     /* When scavenging the older generations:  Objects may have been
 501      * evacuated from generations <= N into older generations, and we
 502      * need to scavenge these objects.  We're going to try to ensure that
 503      * any evacuations that occur move the objects into at least the
 504      * same generation as the object being scavenged, otherwise we
 505      * have to create new entries on the mutable list for the older
 506      * generation.
 507      */
 508
 509     // scavenge each step in generations 0..maxgen
 510     {
 511       long gen;
 512       int st;
 513
 514     loop2:
 515       // scavenge objects in compacted generation
 516       if (mark_stack_overflowed || oldgen_scan_bd != NULL ||
 517           (mark_stack_bdescr != NULL && !mark_stack_empty())) {
 518           scavenge_mark_stack();
 519           flag = rtsTrue;
 520       }
 521
 522       for (gen = RtsFlags.GcFlags.generations; --gen >= 0; ) {
 523         for (st = generations[gen].n_steps; --st >= 0; ) {
 524           if (gen == 0 && st == 0 && RtsFlags.GcFlags.generations > 1) {
 525             continue;
 526           }
 527           stp = &generations[gen].steps[st];
 528           evac_gen = gen;
 529           if (stp->hp_bd != stp->scan_bd || stp->scan < stp->hp) {
 530             scavenge(stp);
 531             flag = rtsTrue;
 532             goto loop2;
 533           }
 534           if (stp->new_large_objects != NULL) {
 535             scavenge_large(stp);
 536             flag = rtsTrue;
 537             goto loop2;
 538           }
 539         }
 540       }
 541     }
 542
 543     // if any blackholes are alive, make the threads that wait on
 544     // them alive too.
 545     if (traverseBlackholeQueue())
 546         flag = rtsTrue;
 547
 548     if (flag) { goto loop; }
 549
 550     // must be last...  invariant is that everything is fully
 551     // scavenged at this point.
 552     if (traverseWeakPtrList()) { // returns rtsTrue if evaced something
 553       goto loop;
 554     }
 555   }
 556
 557   /* Update the pointers from the task list - these are
 558    * treated as weak pointers because we want to allow a main thread
 559    * to get a BlockedOnDeadMVar exception in the same way as any other
 560    * thread.  Note that the threads should all have been retained by
 561    * GC by virtue of being on the all_threads list, we're just
 562    * updating pointers here.
 563    */
 564   {
 565       Task *task;
 566       StgTSO *tso;
 567       for (task = all_tasks; task != NULL; task = task->all_link) {
 568           if (!task->stopped && task->tso) {
 569               ASSERT(task->tso->bound == task);
 570               tso = (StgTSO *) isAlive((StgClosure *)task->tso);
 571               if (tso == NULL) {
 572                   barf("task %p: main thread %d has been GC'd",
 573 #ifdef THREADED_RTS
 574                        (void *)task->id,
 575 #else
 576                        (void *)task,
 577 #endif
 578                        task->tso->id);
 579               }
 580               task->tso = tso;
 581           }
 582       }
 583   }
 584
 585   // Now see which stable names are still alive.
 586   gcStablePtrTable();
 587
 588   // Tidy the end of the to-space chains
 589   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 590       for (s = 0; s < generations[g].n_steps; s++) {
 591           stp = &generations[g].steps[s];
 592           if (!(g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1)) {
 593               ASSERT(Bdescr(stp->hp) == stp->hp_bd);
 594               stp->hp_bd->free = stp->hp;
 595               Bdescr(stp->scavd_hp)->free = stp->scavd_hp;
 596           }
 597       }
 598   }
 599
 600 #ifdef PROFILING
 601   // We call processHeapClosureForDead() on every closure destroyed during
 602   // the current garbage collection, so we invoke LdvCensusForDead().
 603   if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_LDV
 604       || RtsFlags.ProfFlags.bioSelector != NULL)
 605     LdvCensusForDead(N);
 606 #endif
 607
 608   // NO MORE EVACUATION AFTER THIS POINT!
 609   // Finally: compaction of the oldest generation.
 610   if (major_gc && oldest_gen->steps[0].is_compacted) {
 611       // save number of blocks for stats
 612       oldgen_saved_blocks = oldest_gen->steps[0].n_old_blocks;
 613       compact();
 614   }
 615
 616   IF_DEBUG(sanity, checkGlobalTSOList(rtsFalse));
 617
 618   /* run through all the generations/steps and tidy up
 619    */
 620   copied = new_blocks * BLOCK_SIZE_W;
 621   scavd_copied =  new_scavd_blocks * BLOCK_SIZE_W;
 622   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 623
 624     if (g <= N) {
 625       generations[g].collections++; // for stats
 626     }
 627
 628     // Count the mutable list as bytes "copied" for the purposes of
 629     // stats.  Every mutable list is copied during every GC.
 630     if (g > 0) {
 631         nat mut_list_size = 0;
 632         for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
 633             mut_list_size += bd->free - bd->start;
 634         }
 635         copied +=  mut_list_size;
 636
 637         debugTrace(DEBUG_gc,
 638                    "mut_list_size: %lu (%d vars, %d arrays, %d others)",
 639                    (unsigned long)(mut_list_size * sizeof(W_)),
 640                    mutlist_MUTVARS, mutlist_MUTARRS, mutlist_OTHERS);
 641     }
 642
 643     for (s = 0; s < generations[g].n_steps; s++) {
 644       bdescr *next;
 645       stp = &generations[g].steps[s];
 646
 647       if (!(g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1)) {
 648         // stats information: how much we copied
 649         if (g <= N) {
 650           copied -= stp->hp_bd->start + BLOCK_SIZE_W -
 651             stp->hp_bd->free;
 652           scavd_copied -= (P_)(BLOCK_ROUND_UP(stp->scavd_hp)) - stp->scavd_hp;
 653         }
 654       }
 655
 656       // for generations we collected...
 657       if (g <= N) {
 658
 659         /* free old memory and shift to-space into from-space for all
 660          * the collected steps (except the allocation area).  These
 661          * freed blocks will probaby be quickly recycled.
 662          */
 663         if (!(g == 0 && s == 0)) {
 664             if (stp->is_compacted) {
 665                 // for a compacted step, just shift the new to-space
 666                 // onto the front of the now-compacted existing blocks.
 667                 for (bd = stp->blocks; bd != NULL; bd = bd->link) {
 668                     bd->flags &= ~BF_EVACUATED;  // now from-space
 669                 }
 670                 // tack the new blocks on the end of the existing blocks
 671                 if (stp->old_blocks != NULL) {
 672                     for (bd = stp->old_blocks; bd != NULL; bd = next) {
 673                         // NB. this step might not be compacted next
 674                         // time, so reset the BF_COMPACTED flags.
 675                         // They are set before GC if we're going to
 676                         // compact.  (search for BF_COMPACTED above).
 677                         bd->flags &= ~BF_COMPACTED;
 678                         next = bd->link;
 679                         if (next == NULL) {
 680                             bd->link = stp->blocks;
 681                         }
 682                     }
 683                     stp->blocks = stp->old_blocks;
 684                 }
 685                 // add the new blocks to the block tally
 686                 stp->n_blocks += stp->n_old_blocks;
 687                 ASSERT(countBlocks(stp->blocks) == stp->n_blocks);
 688             } else {
 689                 freeChain(stp->old_blocks);
 690                 for (bd = stp->blocks; bd != NULL; bd = bd->link) {
 691                     bd->flags &= ~BF_EVACUATED;  // now from-space
 692                 }
 693             }
 694             stp->old_blocks = NULL;
 695             stp->n_old_blocks = 0;
 696         }
 697
 698         /* LARGE OBJECTS.  The current live large objects are chained on
 699          * scavenged_large, having been moved during garbage
 700          * collection from large_objects.  Any objects left on
 701          * large_objects list are therefore dead, so we free them here.
 702          */
 703         for (bd = stp->large_objects; bd != NULL; bd = next) {
 704           next = bd->link;
 705           freeGroup(bd);
 706           bd = next;
 707         }
 708
 709         // update the count of blocks used by large objects
 710         for (bd = stp->scavenged_large_objects; bd != NULL; bd = bd->link) {
 711           bd->flags &= ~BF_EVACUATED;
 712         }
 713         stp->large_objects  = stp->scavenged_large_objects;
 714         stp->n_large_blocks = stp->n_scavenged_large_blocks;
 715
 716       } else {
 717         // for older generations...
 718
 719         /* For older generations, we need to append the
 720          * scavenged_large_object list (i.e. large objects that have been
 721          * promoted during this GC) to the large_object list for that step.
 722          */
 723         for (bd = stp->scavenged_large_objects; bd; bd = next) {
 724           next = bd->link;
 725           bd->flags &= ~BF_EVACUATED;
 726           dbl_link_onto(bd, &stp->large_objects);
 727         }
 728
 729         // add the new blocks we promoted during this GC
 730         stp->n_large_blocks += stp->n_scavenged_large_blocks;
 731       }
 732     }
 733   }
 734
 735   /* Reset the sizes of the older generations when we do a major
 736    * collection.
 737    *
 738    * CURRENT STRATEGY: make all generations except zero the same size.
 739    * We have to stay within the maximum heap size, and leave a certain
 740    * percentage of the maximum heap size available to allocate into.
 741    */
 742   if (major_gc && RtsFlags.GcFlags.generations > 1) {
 743       nat live, size, min_alloc;
 744       nat max  = RtsFlags.GcFlags.maxHeapSize;
 745       nat gens = RtsFlags.GcFlags.generations;
 746
 747       // live in the oldest generations
 748       live = oldest_gen->steps[0].n_blocks +
 749              oldest_gen->steps[0].n_large_blocks;
 750
 751       // default max size for all generations except zero
 752       size = stg_max(live * RtsFlags.GcFlags.oldGenFactor,
 753                      RtsFlags.GcFlags.minOldGenSize);
 754
 755       // minimum size for generation zero
 756       min_alloc = stg_max((RtsFlags.GcFlags.pcFreeHeap * max) / 200,
 757                           RtsFlags.GcFlags.minAllocAreaSize);
 758
 759       // Auto-enable compaction when the residency reaches a
 760       // certain percentage of the maximum heap size (default: 30%).
 761       if (RtsFlags.GcFlags.generations > 1 &&
 762           (RtsFlags.GcFlags.compact ||
 763            (max > 0 &&
 764             oldest_gen->steps[0].n_blocks >
 765             (RtsFlags.GcFlags.compactThreshold * max) / 100))) {
 766           oldest_gen->steps[0].is_compacted = 1;
 767 //        debugBelch("compaction: on\n", live);
 768       } else {
 769           oldest_gen->steps[0].is_compacted = 0;
 770 //        debugBelch("compaction: off\n", live);
 771       }
 772
 773       // if we're going to go over the maximum heap size, reduce the
 774       // size of the generations accordingly.  The calculation is
 775       // different if compaction is turned on, because we don't need
 776       // to double the space required to collect the old generation.
 777       if (max != 0) {
 778
 779           // this test is necessary to ensure that the calculations
 780           // below don't have any negative results - we're working
 781           // with unsigned values here.
 782           if (max < min_alloc) {
 783               heapOverflow();
 784           }
 785
 786           if (oldest_gen->steps[0].is_compacted) {
 787               if ( (size + (size - 1) * (gens - 2) * 2) + min_alloc > max ) {
 788                   size = (max - min_alloc) / ((gens - 1) * 2 - 1);
 789               }
 790           } else {
 791               if ( (size * (gens - 1) * 2) + min_alloc > max ) {
 792                   size = (max - min_alloc) / ((gens - 1) * 2);
 793               }
 794           }
 795
 796           if (size < live) {
 797               heapOverflow();
 798           }
 799       }
 800
 801 #if 0
 802       debugBelch("live: %d, min_alloc: %d, size : %d, max = %d\n", live,
 803               min_alloc, size, max);
 804 #endif
 805
 806       for (g = 0; g < gens; g++) {
 807           generations[g].max_blocks = size;
 808       }
 809   }
 810
 811   // Guess the amount of live data for stats.
 812   live = calcLive();
 813
 814   /* Free the small objects allocated via allocate(), since this will
 815    * all have been copied into G0S1 now.
 816    */
 817   if (small_alloc_list != NULL) {
 818     freeChain(small_alloc_list);
 819   }
 820   small_alloc_list = NULL;
 821   alloc_blocks = 0;
 822   alloc_Hp = NULL;
 823   alloc_HpLim = NULL;
 824   alloc_blocks_lim = RtsFlags.GcFlags.minAllocAreaSize;
 825
 826   // Start a new pinned_object_block
 827   pinned_object_block = NULL;
 828
 829   /* Free the mark stack.
 830    */
 831   if (mark_stack_bdescr != NULL) {
 832       freeGroup(mark_stack_bdescr);
 833   }
 834
 835   /* Free any bitmaps.
 836    */
 837   for (g = 0; g <= N; g++) {
 838       for (s = 0; s < generations[g].n_steps; s++) {
 839           stp = &generations[g].steps[s];
 840           if (stp->bitmap != NULL) {
 841               freeGroup(stp->bitmap);
 842               stp->bitmap = NULL;
 843           }
 844       }
 845   }
 846
 847   /* Two-space collector:
 848    * Free the old to-space, and estimate the amount of live data.
 849    */
 850   if (RtsFlags.GcFlags.generations == 1) {
 851     nat blocks;
 852
 853     if (g0s0->old_blocks != NULL) {
 854       freeChain(g0s0->old_blocks);
 855     }
 856     for (bd = g0s0->blocks; bd != NULL; bd = bd->link) {
 857       bd->flags = 0;    // now from-space
 858     }
 859     g0s0->old_blocks = g0s0->blocks;
 860     g0s0->n_old_blocks = g0s0->n_blocks;
 861     g0s0->blocks = saved_nursery;
 862     g0s0->n_blocks = saved_n_blocks;
 863
 864     /* For a two-space collector, we need to resize the nursery. */
 865
 866     /* set up a new nursery.  Allocate a nursery size based on a
 867      * function of the amount of live data (by default a factor of 2)
 868      * Use the blocks from the old nursery if possible, freeing up any
 869      * left over blocks.
 870      *
 871      * If we get near the maximum heap size, then adjust our nursery
 872      * size accordingly.  If the nursery is the same size as the live
 873      * data (L), then we need 3L bytes.  We can reduce the size of the
 874      * nursery to bring the required memory down near 2L bytes.
 875      *
 876      * A normal 2-space collector would need 4L bytes to give the same
 877      * performance we get from 3L bytes, reducing to the same
 878      * performance at 2L bytes.
 879      */
 880     blocks = g0s0->n_old_blocks;
 881
 882     if ( RtsFlags.GcFlags.maxHeapSize != 0 &&
 883          blocks * RtsFlags.GcFlags.oldGenFactor * 2 >
 884            RtsFlags.GcFlags.maxHeapSize ) {
 885       long adjusted_blocks;  // signed on purpose
 886       int pc_free;
 887
 888       adjusted_blocks = (RtsFlags.GcFlags.maxHeapSize - 2 * blocks);
 889
 890       debugTrace(DEBUG_gc, "near maximum heap size of 0x%x blocks, blocks = %d, adjusted to %ld",
 891                  RtsFlags.GcFlags.maxHeapSize, blocks, adjusted_blocks);
 892
 893       pc_free = adjusted_blocks * 100 / RtsFlags.GcFlags.maxHeapSize;
 894       if (pc_free < RtsFlags.GcFlags.pcFreeHeap) /* might even be < 0 */ {
 895         heapOverflow();
 896       }
 897       blocks = adjusted_blocks;
 898
 899     } else {
 900       blocks *= RtsFlags.GcFlags.oldGenFactor;
 901       if (blocks < RtsFlags.GcFlags.minAllocAreaSize) {
 902         blocks = RtsFlags.GcFlags.minAllocAreaSize;
 903       }
 904     }
 905     resizeNurseries(blocks);
 906
 907   } else {
 908     /* Generational collector:
 909      * If the user has given us a suggested heap size, adjust our
 910      * allocation area to make best use of the memory available.
 911      */
 912
 913     if (RtsFlags.GcFlags.heapSizeSuggestion) {
 914       long blocks;
 915       nat needed = calcNeeded();        // approx blocks needed at next GC
 916
 917       /* Guess how much will be live in generation 0 step 0 next time.
 918        * A good approximation is obtained by finding the
 919        * percentage of g0s0 that was live at the last minor GC.
 920        */
 921       if (N == 0) {
 922         g0s0_pcnt_kept = (new_blocks * 100) / countNurseryBlocks();
 923       }
 924
 925       /* Estimate a size for the allocation area based on the
 926        * information available.  We might end up going slightly under
 927        * or over the suggested heap size, but we should be pretty
 928        * close on average.
 929        *
 930        * Formula:            suggested - needed
 931        *                ----------------------------
 932        *                    1 + g0s0_pcnt_kept/100
 933        *
 934        * where 'needed' is the amount of memory needed at the next
 935        * collection for collecting all steps except g0s0.
 936        */
 937       blocks =
 938         (((long)RtsFlags.GcFlags.heapSizeSuggestion - (long)needed) * 100) /
 939         (100 + (long)g0s0_pcnt_kept);
 940
 941       if (blocks < (long)RtsFlags.GcFlags.minAllocAreaSize) {
 942         blocks = RtsFlags.GcFlags.minAllocAreaSize;
 943       }
 944
 945       resizeNurseries((nat)blocks);
 946
 947     } else {
 948       // we might have added extra large blocks to the nursery, so
 949       // resize back to minAllocAreaSize again.
 950       resizeNurseriesFixed(RtsFlags.GcFlags.minAllocAreaSize);
 951     }
 952   }
 953
 954  // mark the garbage collected CAFs as dead
 955 #if 0 && defined(DEBUG) // doesn't work at the moment
 956   if (major_gc) { gcCAFs(); }
 957 #endif
 958
 959 #ifdef PROFILING
 960   // resetStaticObjectForRetainerProfiling() must be called before
 961   // zeroing below.
 962   resetStaticObjectForRetainerProfiling();
 963 #endif
 964
 965   // zero the scavenged static object list
 966   if (major_gc) {
 967     zero_static_object_list(scavenged_static_objects);
 968   }
 969
 970   // Reset the nursery
 971   resetNurseries();
 972
 973   // start any pending finalizers
 974   RELEASE_SM_LOCK;
 975   scheduleFinalizers(last_free_capability, old_weak_ptr_list);
 976   ACQUIRE_SM_LOCK;
 977
 978   // send exceptions to any threads which were about to die
 979   RELEASE_SM_LOCK;
 980   resurrectThreads(resurrected_threads);
 981   ACQUIRE_SM_LOCK;
 982
 983   // Update the stable pointer hash table.
 984   updateStablePtrTable(major_gc);
 985
 986   // check sanity after GC
 987   IF_DEBUG(sanity, checkSanity());
 988
 989   // extra GC trace info
 990   IF_DEBUG(gc, statDescribeGens());
 991
 992 #ifdef DEBUG
 993   // symbol-table based profiling
 994   /*  heapCensus(to_blocks); */ /* ToDo */
 995 #endif
 996
 997   // restore enclosing cost centre
 998 #ifdef PROFILING
 999   CCCS = prev_CCS;
1000 #endif
1001
1002 #ifdef DEBUG
1003   // check for memory leaks if DEBUG is on
1004   memInventory();
1005 #endif
1006
1007 #ifdef RTS_GTK_FRONTPANEL
1008   if (RtsFlags.GcFlags.frontpanel) {
1009       updateFrontPanelAfterGC( N, live );
1010   }
1011 #endif
1012
1013   // ok, GC over: tell the stats department what happened.
1014   stat_endGC(allocated, live, copied, scavd_copied, N);
1015
1016 #if defined(RTS_USER_SIGNALS)
1017   // unblock signals again
1018   unblockUserSignals();
1019 #endif
1020
1021   RELEASE_SM_LOCK;
1022 }
1023
1024 /* -----------------------------------------------------------------------------
1025    isAlive determines whether the given closure is still alive (after
1026    a garbage collection) or not.  It returns the new address of the
1027    closure if it is alive, or NULL otherwise.
1028
1029    NOTE: Use it before compaction only!
1030    -------------------------------------------------------------------------- */
1031
1032
1033 StgClosure *
1034 isAlive(StgClosure *p)
1035 {
1036   const StgInfoTable *info;
1037   bdescr *bd;
1038
1039   while (1) {
1040
1041     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
1042     info = get_itbl(p);
1043
1044     // ignore static closures
1045     //
1046     // ToDo: for static closures, check the static link field.
1047     // Problem here is that we sometimes don't set the link field, eg.
1048     // for static closures with an empty SRT or CONSTR_STATIC_NOCAFs.
1049     //
1050     if (!HEAP_ALLOCED(p)) {
1051         return p;
1052     }
1053
1054     // ignore closures in generations that we're not collecting.
1055     bd = Bdescr((P_)p);
1056     if (bd->gen_no > N) {
1057         return p;
1058     }
1059
1060     // if it's a pointer into to-space, then we're done
1061     if (bd->flags & BF_EVACUATED) {
1062         return p;
1063     }
1064
1065     // large objects use the evacuated flag
1066     if (bd->flags & BF_LARGE) {
1067         return NULL;
1068     }
1069
1070     // check the mark bit for compacted steps
1071     if ((bd->flags & BF_COMPACTED) && is_marked((P_)p,bd)) {
1072         return p;
1073     }
1074
1075     switch (info->type) {
1076
1077     case IND:
1078     case IND_STATIC:
1079     case IND_PERM:
1080     case IND_OLDGEN:            // rely on compatible layout with StgInd
1081     case IND_OLDGEN_PERM:
1082       // follow indirections
1083       p = ((StgInd *)p)->indirectee;
1084       continue;
1085
1086     case EVACUATED:
1087       // alive!
1088       return ((StgEvacuated *)p)->evacuee;
1089
1090     case TSO:
1091       if (((StgTSO *)p)->what_next == ThreadRelocated) {
1092         p = (StgClosure *)((StgTSO *)p)->link;
1093         continue;
1094       }
1095       return NULL;
1096
1097     default:
1098       // dead.
1099       return NULL;
1100     }
1101   }
1102 }
1103
1104 static void
1105 mark_root(StgClosure **root)
1106 {
1107   *root = evacuate(*root);
1108 }
1109
1110 /* -----------------------------------------------------------------------------
1111    Initialising the static object & mutable lists
1112    -------------------------------------------------------------------------- */
1113
1114 static void
1115 zero_static_object_list(StgClosure* first_static)
1116 {
1117   StgClosure* p;
1118   StgClosure* link;
1119   const StgInfoTable *info;
1120
1121   for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
1122     info = get_itbl(p);
1123     link = *STATIC_LINK(info, p);
1124     *STATIC_LINK(info,p) = NULL;
1125   }
1126 }
1127
1128 /* -----------------------------------------------------------------------------
1129    Reverting CAFs
1130    -------------------------------------------------------------------------- */
1131
1132 void
1133 revertCAFs( void )
1134 {
1135     StgIndStatic *c;
1136
1137     for (c = (StgIndStatic *)revertible_caf_list; c != NULL;
1138          c = (StgIndStatic *)c->static_link)
1139     {
1140         SET_INFO(c, c->saved_info);
1141         c->saved_info = NULL;
1142         // could, but not necessary: c->static_link = NULL;
1143     }
1144     revertible_caf_list = NULL;
1145 }
1146
1147 void
1148 markCAFs( evac_fn evac )
1149 {
1150     StgIndStatic *c;
1151
1152     for (c = (StgIndStatic *)caf_list; c != NULL;
1153          c = (StgIndStatic *)c->static_link)
1154     {
1155         evac(&c->indirectee);
1156     }
1157     for (c = (StgIndStatic *)revertible_caf_list; c != NULL;
1158          c = (StgIndStatic *)c->static_link)
1159     {
1160         evac(&c->indirectee);
1161     }
1162 }
1163
1164 /* -----------------------------------------------------------------------------
1165    Sanity code for CAF garbage collection.
1166
1167    With DEBUG turned on, we manage a CAF list in addition to the SRT
1168    mechanism.  After GC, we run down the CAF list and blackhole any
1169    CAFs which have been garbage collected.  This means we get an error
1170    whenever the program tries to enter a garbage collected CAF.
1171
1172    Any garbage collected CAFs are taken off the CAF list at the same
1173    time.
1174    -------------------------------------------------------------------------- */
1175
1176 #if 0 && defined(DEBUG)
1177
1178 static void
1179 gcCAFs(void)
1180 {
1181   StgClosure*  p;
1182   StgClosure** pp;
1183   const StgInfoTable *info;
1184   nat i;
1185
1186   i = 0;
1187   p = caf_list;
1188   pp = &caf_list;
1189
1190   while (p != NULL) {
1191
1192     info = get_itbl(p);
1193
1194     ASSERT(info->type == IND_STATIC);
1195
1196     if (STATIC_LINK(info,p) == NULL) {
1197         debugTrace(DEBUG_gccafs, "CAF gc'd at 0x%04lx", (long)p);
1198         // black hole it
1199         SET_INFO(p,&stg_BLACKHOLE_info);
1200         p = STATIC_LINK2(info,p);
1201         *pp = p;
1202     }
1203     else {
1204       pp = &STATIC_LINK2(info,p);
1205       p = *pp;
1206       i++;
1207     }
1208
1209   }
1210
1211   debugTrace(DEBUG_gccafs, "%d CAFs live", i);
1212 }
1213 #endif
1214
1215 /* -----------------------------------------------------------------------------
1216  * Debugging
1217  * -------------------------------------------------------------------------- */
1218
1219 #if DEBUG
1220 void
1221 printMutableList(generation *gen)
1222 {
1223     bdescr *bd;
1224     StgPtr p;
1225
1226     debugBelch("mutable list %p: ", gen->mut_list);
1227
1228     for (bd = gen->mut_list; bd != NULL; bd = bd->link) {
1229         for (p = bd->start; p < bd->free; p++) {
1230             debugBelch("%p (%s), ", (void *)*p, info_type((StgClosure *)*p));
1231         }
1232     }
1233     debugBelch("\n");
1234 }
1235 #endif /* DEBUG */