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