rts/sm/Scav.c

   1 /* -----------------------------------------------------------------------------
   2  *
   3  * (c) The GHC Team 1998-2008
   4  *
   5  * Generational garbage collector: scavenging functions
   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 "Rts.h"
  15 #include "RtsFlags.h"
  16 #include "Storage.h"
  17 #include "MBlock.h"
  18 #include "GC.h"
  19 #include "GCThread.h"
  20 #include "GCUtils.h"
  21 #include "Compact.h"
  22 #include "Evac.h"
  23 #include "Scav.h"
  24 #include "Apply.h"
  25 #include "Trace.h"
  26 #include "LdvProfile.h"
  27 #include "Sanity.h"
  28
  29 static void scavenge_stack (StgPtr p, StgPtr stack_end);
  30
  31 static void scavenge_large_bitmap (StgPtr p,
  32                                    StgLargeBitmap *large_bitmap,
  33                                    nat size );
  34
  35
  36 /* Similar to scavenge_large_bitmap(), but we don't write back the
  37  * pointers we get back from evacuate().
  38  */
  39 static void
  40 scavenge_large_srt_bitmap( StgLargeSRT *large_srt )
  41 {
  42     nat i, b, size;
  43     StgWord bitmap;
  44     StgClosure **p;
  45
  46     b = 0;
  47     bitmap = large_srt->l.bitmap[b];
  48     size   = (nat)large_srt->l.size;
  49     p      = (StgClosure **)large_srt->srt;
  50     for (i = 0; i < size; ) {
  51         if ((bitmap & 1) != 0) {
  52             evacuate(p);
  53         }
  54         i++;
  55         p++;
  56         if (i % BITS_IN(W_) == 0) {
  57             b++;
  58             bitmap = large_srt->l.bitmap[b];
  59         } else {
  60             bitmap = bitmap >> 1;
  61         }
  62     }
  63 }
  64
  65 /* evacuate the SRT.  If srt_bitmap is zero, then there isn't an
  66  * srt field in the info table.  That's ok, because we'll
  67  * never dereference it.
  68  */
  69 STATIC_INLINE void
  70 scavenge_srt (StgClosure **srt, nat srt_bitmap)
  71 {
  72   nat bitmap;
  73   StgClosure **p;
  74
  75   bitmap = srt_bitmap;
  76   p = srt;
  77
  78   if (bitmap == (StgHalfWord)(-1)) {
  79       scavenge_large_srt_bitmap( (StgLargeSRT *)srt );
  80       return;
  81   }
  82
  83   while (bitmap != 0) {
  84       if ((bitmap & 1) != 0) {
  85 #if defined(__PIC__) && defined(mingw32_TARGET_OS)
  86           // Special-case to handle references to closures hiding out in DLLs, since
  87           // double indirections required to get at those. The code generator knows
  88           // which is which when generating the SRT, so it stores the (indirect)
  89           // reference to the DLL closure in the table by first adding one to it.
  90           // We check for this here, and undo the addition before evacuating it.
  91           //
  92           // If the SRT entry hasn't got bit 0 set, the SRT entry points to a
  93           // closure that's fixed at link-time, and no extra magic is required.
  94           if ( (unsigned long)(*srt) & 0x1 ) {
  95               evacuate(stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)));
  96           } else {
  97               evacuate(p);
  98           }
  99 #else
 100           evacuate(p);
 101 #endif
 102       }
 103       p++;
 104       bitmap = bitmap >> 1;
 105   }
 106 }
 107
 108
 109 STATIC_INLINE void
 110 scavenge_thunk_srt(const StgInfoTable *info)
 111 {
 112     StgThunkInfoTable *thunk_info;
 113
 114     if (!major_gc) return;
 115
 116     thunk_info = itbl_to_thunk_itbl(info);
 117     scavenge_srt((StgClosure **)GET_SRT(thunk_info), thunk_info->i.srt_bitmap);
 118 }
 119
 120 STATIC_INLINE void
 121 scavenge_fun_srt(const StgInfoTable *info)
 122 {
 123     StgFunInfoTable *fun_info;
 124
 125     if (!major_gc) return;
 126
 127     fun_info = itbl_to_fun_itbl(info);
 128     scavenge_srt((StgClosure **)GET_FUN_SRT(fun_info), fun_info->i.srt_bitmap);
 129 }
 130
 131 /* -----------------------------------------------------------------------------
 132    Scavenge a TSO.
 133    -------------------------------------------------------------------------- */
 134
 135 STATIC_INLINE void
 136 scavenge_TSO_link (StgTSO *tso)
 137 {
 138     // We don't always chase the link field: TSOs on the blackhole
 139     // queue are not automatically alive, so the link field is a
 140     // "weak" pointer in that case.
 141     if (tso->why_blocked != BlockedOnBlackHole) {
 142         evacuate((StgClosure **)&tso->_link);
 143     }
 144 }
 145
 146 static void
 147 scavengeTSO (StgTSO *tso)
 148 {
 149     rtsBool saved_eager;
 150
 151     if (tso->what_next == ThreadRelocated) {
 152         // the only way this can happen is if the old TSO was on the
 153         // mutable list.  We might have other links to this defunct
 154         // TSO, so we must update its link field.
 155         evacuate((StgClosure**)&tso->_link);
 156         return;
 157     }
 158
 159     saved_eager = gct->eager_promotion;
 160     gct->eager_promotion = rtsFalse;
 161
 162     if (   tso->why_blocked == BlockedOnMVar
 163         || tso->why_blocked == BlockedOnBlackHole
 164         || tso->why_blocked == BlockedOnException
 165         ) {
 166         evacuate(&tso->block_info.closure);
 167     }
 168     evacuate((StgClosure **)&tso->blocked_exceptions);
 169
 170     // scavange current transaction record
 171     evacuate((StgClosure **)&tso->trec);
 172
 173     // scavenge this thread's stack
 174     scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
 175
 176     if (gct->failed_to_evac) {
 177         tso->flags |= TSO_DIRTY;
 178         scavenge_TSO_link(tso);
 179     } else {
 180         tso->flags &= ~TSO_DIRTY;
 181         scavenge_TSO_link(tso);
 182         if (gct->failed_to_evac) {
 183             tso->flags |= TSO_LINK_DIRTY;
 184         } else {
 185             tso->flags &= ~TSO_LINK_DIRTY;
 186         }
 187     }
 188
 189     gct->eager_promotion = saved_eager;
 190 }
 191
 192 /* -----------------------------------------------------------------------------
 193    Blocks of function args occur on the stack (at the top) and
 194    in PAPs.
 195    -------------------------------------------------------------------------- */
 196
 197 STATIC_INLINE StgPtr
 198 scavenge_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
 199 {
 200     StgPtr p;
 201     StgWord bitmap;
 202     nat size;
 203
 204     p = (StgPtr)args;
 205     switch (fun_info->f.fun_type) {
 206     case ARG_GEN:
 207         bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
 208         size = BITMAP_SIZE(fun_info->f.b.bitmap);
 209         goto small_bitmap;
 210     case ARG_GEN_BIG:
 211         size = GET_FUN_LARGE_BITMAP(fun_info)->size;
 212         scavenge_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
 213         p += size;
 214         break;
 215     default:
 216         bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
 217         size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
 218     small_bitmap:
 219         while (size > 0) {
 220             if ((bitmap & 1) == 0) {
 221                 evacuate((StgClosure **)p);
 222             }
 223             p++;
 224             bitmap = bitmap >> 1;
 225             size--;
 226         }
 227         break;
 228     }
 229     return p;
 230 }
 231
 232 STATIC_INLINE StgPtr
 233 scavenge_PAP_payload (StgClosure *fun, StgClosure **payload, StgWord size)
 234 {
 235     StgPtr p;
 236     StgWord bitmap;
 237     StgFunInfoTable *fun_info;
 238
 239     fun_info = get_fun_itbl(UNTAG_CLOSURE(fun));
 240     ASSERT(fun_info->i.type != PAP);
 241     p = (StgPtr)payload;
 242
 243     switch (fun_info->f.fun_type) {
 244     case ARG_GEN:
 245         bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
 246         goto small_bitmap;
 247     case ARG_GEN_BIG:
 248         scavenge_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
 249         p += size;
 250         break;
 251     case ARG_BCO:
 252         scavenge_large_bitmap((StgPtr)payload, BCO_BITMAP(fun), size);
 253         p += size;
 254         break;
 255     default:
 256         bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
 257     small_bitmap:
 258         while (size > 0) {
 259             if ((bitmap & 1) == 0) {
 260                 evacuate((StgClosure **)p);
 261             }
 262             p++;
 263             bitmap = bitmap >> 1;
 264             size--;
 265         }
 266         break;
 267     }
 268     return p;
 269 }
 270
 271 STATIC_INLINE StgPtr
 272 scavenge_PAP (StgPAP *pap)
 273 {
 274     evacuate(&pap->fun);
 275     return scavenge_PAP_payload (pap->fun, pap->payload, pap->n_args);
 276 }
 277
 278 STATIC_INLINE StgPtr
 279 scavenge_AP (StgAP *ap)
 280 {
 281     evacuate(&ap->fun);
 282     return scavenge_PAP_payload (ap->fun, ap->payload, ap->n_args);
 283 }
 284
 285 /* -----------------------------------------------------------------------------
 286    Scavenge everything on the mark stack.
 287
 288    This is slightly different from scavenge():
 289       - we don't walk linearly through the objects, so the scavenger
 290         doesn't need to advance the pointer on to the next object.
 291    -------------------------------------------------------------------------- */
 292
 293 static void
 294 scavenge_mark_stack(void)
 295 {
 296     StgPtr p, q;
 297     StgInfoTable *info;
 298     step *saved_evac_step;
 299
 300     gct->evac_step = &oldest_gen->steps[0];
 301     saved_evac_step = gct->evac_step;
 302
 303 linear_scan:
 304     while (!mark_stack_empty()) {
 305         p = pop_mark_stack();
 306
 307         ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
 308         info = get_itbl((StgClosure *)p);
 309
 310         q = p;
 311         switch (((volatile StgWord *)info)[1] & 0xffff) {
 312
 313         case MVAR_CLEAN:
 314         case MVAR_DIRTY:
 315         {
 316             rtsBool saved_eager_promotion = gct->eager_promotion;
 317
 318             StgMVar *mvar = ((StgMVar *)p);
 319             gct->eager_promotion = rtsFalse;
 320             evacuate((StgClosure **)&mvar->head);
 321             evacuate((StgClosure **)&mvar->tail);
 322             evacuate((StgClosure **)&mvar->value);
 323             gct->eager_promotion = saved_eager_promotion;
 324
 325             if (gct->failed_to_evac) {
 326                 mvar->header.info = &stg_MVAR_DIRTY_info;
 327             } else {
 328                 mvar->header.info = &stg_MVAR_CLEAN_info;
 329             }
 330             break;
 331         }
 332
 333         case FUN_2_0:
 334             scavenge_fun_srt(info);
 335             evacuate(&((StgClosure *)p)->payload[1]);
 336             evacuate(&((StgClosure *)p)->payload[0]);
 337             break;
 338
 339         case THUNK_2_0:
 340             scavenge_thunk_srt(info);
 341             evacuate(&((StgThunk *)p)->payload[1]);
 342             evacuate(&((StgThunk *)p)->payload[0]);
 343             break;
 344
 345         case CONSTR_2_0:
 346             evacuate(&((StgClosure *)p)->payload[1]);
 347             evacuate(&((StgClosure *)p)->payload[0]);
 348             break;
 349
 350         case FUN_1_0:
 351         case FUN_1_1:
 352             scavenge_fun_srt(info);
 353             evacuate(&((StgClosure *)p)->payload[0]);
 354             break;
 355
 356         case THUNK_1_0:
 357         case THUNK_1_1:
 358             scavenge_thunk_srt(info);
 359             evacuate(&((StgThunk *)p)->payload[0]);
 360             break;
 361
 362         case CONSTR_1_0:
 363         case CONSTR_1_1:
 364             evacuate(&((StgClosure *)p)->payload[0]);
 365             break;
 366
 367         case FUN_0_1:
 368         case FUN_0_2:
 369             scavenge_fun_srt(info);
 370             break;
 371
 372         case THUNK_0_1:
 373         case THUNK_0_2:
 374             scavenge_thunk_srt(info);
 375             break;
 376
 377         case CONSTR_0_1:
 378         case CONSTR_0_2:
 379             break;
 380
 381         case FUN:
 382             scavenge_fun_srt(info);
 383             goto gen_obj;
 384
 385         case THUNK:
 386         {
 387             StgPtr end;
 388
 389             scavenge_thunk_srt(info);
 390             end = (P_)((StgThunk *)p)->payload + info->layout.payload.ptrs;
 391             for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
 392                 evacuate((StgClosure **)p);
 393             }
 394             break;
 395         }
 396
 397         gen_obj:
 398         case CONSTR:
 399         case WEAK:
 400         case STABLE_NAME:
 401         {
 402             StgPtr end;
 403
 404             end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
 405             for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
 406                 evacuate((StgClosure **)p);
 407             }
 408             break;
 409         }
 410
 411         case BCO: {
 412             StgBCO *bco = (StgBCO *)p;
 413             evacuate((StgClosure **)&bco->instrs);
 414             evacuate((StgClosure **)&bco->literals);
 415             evacuate((StgClosure **)&bco->ptrs);
 416             break;
 417         }
 418
 419         case IND_PERM:
 420             // don't need to do anything here: the only possible case
 421             // is that we're in a 1-space compacting collector, with
 422             // no "old" generation.
 423             break;
 424
 425         case IND_OLDGEN:
 426         case IND_OLDGEN_PERM:
 427             evacuate(&((StgInd *)p)->indirectee);
 428             break;
 429
 430         case MUT_VAR_CLEAN:
 431         case MUT_VAR_DIRTY: {
 432             rtsBool saved_eager_promotion = gct->eager_promotion;
 433
 434             gct->eager_promotion = rtsFalse;
 435             evacuate(&((StgMutVar *)p)->var);
 436             gct->eager_promotion = saved_eager_promotion;
 437
 438             if (gct->failed_to_evac) {
 439                 ((StgClosure *)q)->header.info = &stg_MUT_VAR_DIRTY_info;
 440             } else {
 441                 ((StgClosure *)q)->header.info = &stg_MUT_VAR_CLEAN_info;
 442             }
 443             break;
 444         }
 445
 446         case CAF_BLACKHOLE:
 447         case SE_CAF_BLACKHOLE:
 448         case SE_BLACKHOLE:
 449         case BLACKHOLE:
 450         case ARR_WORDS:
 451             break;
 452
 453         case THUNK_SELECTOR:
 454         {
 455             StgSelector *s = (StgSelector *)p;
 456             evacuate(&s->selectee);
 457             break;
 458         }
 459
 460         // A chunk of stack saved in a heap object
 461         case AP_STACK:
 462         {
 463             StgAP_STACK *ap = (StgAP_STACK *)p;
 464
 465             evacuate(&ap->fun);
 466             scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
 467             break;
 468         }
 469
 470         case PAP:
 471             scavenge_PAP((StgPAP *)p);
 472             break;
 473
 474         case AP:
 475             scavenge_AP((StgAP *)p);
 476             break;
 477
 478         case MUT_ARR_PTRS_CLEAN:
 479         case MUT_ARR_PTRS_DIRTY:
 480             // follow everything
 481         {
 482             StgPtr next;
 483             rtsBool saved_eager;
 484
 485             // We don't eagerly promote objects pointed to by a mutable
 486             // array, but if we find the array only points to objects in
 487             // the same or an older generation, we mark it "clean" and
 488             // avoid traversing it during minor GCs.
 489             saved_eager = gct->eager_promotion;
 490             gct->eager_promotion = rtsFalse;
 491             next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
 492             for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
 493                 evacuate((StgClosure **)p);
 494             }
 495             gct->eager_promotion = saved_eager;
 496
 497             if (gct->failed_to_evac) {
 498                 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_DIRTY_info;
 499             } else {
 500                 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_CLEAN_info;
 501             }
 502
 503             gct->failed_to_evac = rtsTrue; // mutable anyhow.
 504             break;
 505         }
 506
 507         case MUT_ARR_PTRS_FROZEN:
 508         case MUT_ARR_PTRS_FROZEN0:
 509             // follow everything
 510         {
 511             StgPtr next, q = p;
 512
 513             next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
 514             for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
 515                 evacuate((StgClosure **)p);
 516             }
 517
 518             // If we're going to put this object on the mutable list, then
 519             // set its info ptr to MUT_ARR_PTRS_FROZEN0 to indicate that.
 520             if (gct->failed_to_evac) {
 521                 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN0_info;
 522             } else {
 523                 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN_info;
 524             }
 525             break;
 526         }
 527
 528         case TSO:
 529         {
 530             scavengeTSO((StgTSO*)p);
 531             break;
 532         }
 533
 534         case TVAR_WATCH_QUEUE:
 535           {
 536             StgTVarWatchQueue *wq = ((StgTVarWatchQueue *) p);
 537             gct->evac_step = 0;
 538             evacuate((StgClosure **)&wq->closure);
 539             evacuate((StgClosure **)&wq->next_queue_entry);
 540             evacuate((StgClosure **)&wq->prev_queue_entry);
 541             gct->evac_step = saved_evac_step;
 542             gct->failed_to_evac = rtsTrue; // mutable
 543             break;
 544           }
 545
 546         case TVAR:
 547           {
 548             StgTVar *tvar = ((StgTVar *) p);
 549             gct->evac_step = 0;
 550             evacuate((StgClosure **)&tvar->current_value);
 551             evacuate((StgClosure **)&tvar->first_watch_queue_entry);
 552             gct->evac_step = saved_evac_step;
 553             gct->failed_to_evac = rtsTrue; // mutable
 554             break;
 555           }
 556
 557         case TREC_CHUNK:
 558           {
 559             StgWord i;
 560             StgTRecChunk *tc = ((StgTRecChunk *) p);
 561             TRecEntry *e = &(tc -> entries[0]);
 562             gct->evac_step = 0;
 563             evacuate((StgClosure **)&tc->prev_chunk);
 564             for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
 565               evacuate((StgClosure **)&e->tvar);
 566               evacuate((StgClosure **)&e->expected_value);
 567               evacuate((StgClosure **)&e->new_value);
 568             }
 569             gct->evac_step = saved_evac_step;
 570             gct->failed_to_evac = rtsTrue; // mutable
 571             break;
 572           }
 573
 574         case TREC_HEADER:
 575           {
 576             StgTRecHeader *trec = ((StgTRecHeader *) p);
 577             gct->evac_step = 0;
 578             evacuate((StgClosure **)&trec->enclosing_trec);
 579             evacuate((StgClosure **)&trec->current_chunk);
 580             evacuate((StgClosure **)&trec->invariants_to_check);
 581             gct->evac_step = saved_evac_step;
 582             gct->failed_to_evac = rtsTrue; // mutable
 583             break;
 584           }
 585
 586         case ATOMIC_INVARIANT:
 587           {
 588             StgAtomicInvariant *invariant = ((StgAtomicInvariant *) p);
 589             gct->evac_step = 0;
 590             evacuate(&invariant->code);
 591             evacuate((StgClosure **)&invariant->last_execution);
 592             gct->evac_step = saved_evac_step;
 593             gct->failed_to_evac = rtsTrue; // mutable
 594             break;
 595           }
 596
 597         case INVARIANT_CHECK_QUEUE:
 598           {
 599             StgInvariantCheckQueue *queue = ((StgInvariantCheckQueue *) p);
 600             gct->evac_step = 0;
 601             evacuate((StgClosure **)&queue->invariant);
 602             evacuate((StgClosure **)&queue->my_execution);
 603             evacuate((StgClosure **)&queue->next_queue_entry);
 604             gct->evac_step = saved_evac_step;
 605             gct->failed_to_evac = rtsTrue; // mutable
 606             break;
 607           }
 608
 609         default:
 610             barf("scavenge_mark_stack: unimplemented/strange closure type %d @ %p",
 611                  info->type, p);
 612         }
 613
 614         if (gct->failed_to_evac) {
 615             gct->failed_to_evac = rtsFalse;
 616             if (gct->evac_step) {
 617                 recordMutableGen_GC((StgClosure *)q, gct->evac_step->gen);
 618             }
 619         }
 620
 621         // mark the next bit to indicate "scavenged"
 622         mark(q+1, Bdescr(q));
 623
 624     } // while (!mark_stack_empty())
 625
 626     // start a new linear scan if the mark stack overflowed at some point
 627     if (mark_stack_overflowed && oldgen_scan_bd == NULL) {
 628         debugTrace(DEBUG_gc, "scavenge_mark_stack: starting linear scan");
 629         mark_stack_overflowed = rtsFalse;
 630         oldgen_scan_bd = oldest_gen->steps[0].old_blocks;
 631         oldgen_scan = oldgen_scan_bd->start;
 632     }
 633
 634     if (oldgen_scan_bd) {
 635         // push a new thing on the mark stack
 636     loop:
 637         // find a closure that is marked but not scavenged, and start
 638         // from there.
 639         while (oldgen_scan < oldgen_scan_bd->free
 640                && !is_marked(oldgen_scan,oldgen_scan_bd)) {
 641             oldgen_scan++;
 642         }
 643
 644         if (oldgen_scan < oldgen_scan_bd->free) {
 645
 646             // already scavenged?
 647             if (is_marked(oldgen_scan+1,oldgen_scan_bd)) {
 648                 oldgen_scan += sizeofW(StgHeader) + MIN_PAYLOAD_SIZE;
 649                 goto loop;
 650             }
 651             push_mark_stack(oldgen_scan);
 652             // ToDo: bump the linear scan by the actual size of the object
 653             oldgen_scan += sizeofW(StgHeader) + MIN_PAYLOAD_SIZE;
 654             goto linear_scan;
 655         }
 656
 657         oldgen_scan_bd = oldgen_scan_bd->link;
 658         if (oldgen_scan_bd != NULL) {
 659             oldgen_scan = oldgen_scan_bd->start;
 660             goto loop;
 661         }
 662     }
 663 }
 664
 665 /* -----------------------------------------------------------------------------
 666    Scavenge one object.
 667
 668    This is used for objects that are temporarily marked as mutable
 669    because they contain old-to-new generation pointers.  Only certain
 670    objects can have this property.
 671    -------------------------------------------------------------------------- */
 672
 673 static rtsBool
 674 scavenge_one(StgPtr p)
 675 {
 676     const StgInfoTable *info;
 677     step *saved_evac_step = gct->evac_step;
 678     rtsBool no_luck;
 679
 680     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
 681     info = get_itbl((StgClosure *)p);
 682
 683     switch (info->type) {
 684
 685     case MVAR_CLEAN:
 686     case MVAR_DIRTY:
 687     {
 688         rtsBool saved_eager_promotion = gct->eager_promotion;
 689
 690         StgMVar *mvar = ((StgMVar *)p);
 691         gct->eager_promotion = rtsFalse;
 692         evacuate((StgClosure **)&mvar->head);
 693         evacuate((StgClosure **)&mvar->tail);
 694         evacuate((StgClosure **)&mvar->value);
 695         gct->eager_promotion = saved_eager_promotion;
 696
 697         if (gct->failed_to_evac) {
 698             mvar->header.info = &stg_MVAR_DIRTY_info;
 699         } else {
 700             mvar->header.info = &stg_MVAR_CLEAN_info;
 701         }
 702         break;
 703     }
 704
 705     case THUNK:
 706     case THUNK_1_0:
 707     case THUNK_0_1:
 708     case THUNK_1_1:
 709     case THUNK_0_2:
 710     case THUNK_2_0:
 711     {
 712         StgPtr q, end;
 713
 714         end = (StgPtr)((StgThunk *)p)->payload + info->layout.payload.ptrs;
 715         for (q = (StgPtr)((StgThunk *)p)->payload; q < end; q++) {
 716             evacuate((StgClosure **)q);
 717         }
 718         break;
 719     }
 720
 721     case FUN:
 722     case FUN_1_0:                       // hardly worth specialising these guys
 723     case FUN_0_1:
 724     case FUN_1_1:
 725     case FUN_0_2:
 726     case FUN_2_0:
 727     case CONSTR:
 728     case CONSTR_1_0:
 729     case CONSTR_0_1:
 730     case CONSTR_1_1:
 731     case CONSTR_0_2:
 732     case CONSTR_2_0:
 733     case WEAK:
 734     case IND_PERM:
 735     {
 736         StgPtr q, end;
 737
 738         end = (StgPtr)((StgClosure *)p)->payload + info->layout.payload.ptrs;
 739         for (q = (StgPtr)((StgClosure *)p)->payload; q < end; q++) {
 740             evacuate((StgClosure **)q);
 741         }
 742         break;
 743     }
 744
 745     case MUT_VAR_CLEAN:
 746     case MUT_VAR_DIRTY: {
 747         StgPtr q = p;
 748         rtsBool saved_eager_promotion = gct->eager_promotion;
 749
 750         gct->eager_promotion = rtsFalse;
 751         evacuate(&((StgMutVar *)p)->var);
 752         gct->eager_promotion = saved_eager_promotion;
 753
 754         if (gct->failed_to_evac) {
 755             ((StgClosure *)q)->header.info = &stg_MUT_VAR_DIRTY_info;
 756         } else {
 757             ((StgClosure *)q)->header.info = &stg_MUT_VAR_CLEAN_info;
 758         }
 759         break;
 760     }
 761
 762     case CAF_BLACKHOLE:
 763     case SE_CAF_BLACKHOLE:
 764     case SE_BLACKHOLE:
 765     case BLACKHOLE:
 766         break;
 767
 768     case THUNK_SELECTOR:
 769     {
 770         StgSelector *s = (StgSelector *)p;
 771         evacuate(&s->selectee);
 772         break;
 773     }
 774
 775     case AP_STACK:
 776     {
 777         StgAP_STACK *ap = (StgAP_STACK *)p;
 778
 779         evacuate(&ap->fun);
 780         scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
 781         p = (StgPtr)ap->payload + ap->size;
 782         break;
 783     }
 784
 785     case PAP:
 786         p = scavenge_PAP((StgPAP *)p);
 787         break;
 788
 789     case AP:
 790         p = scavenge_AP((StgAP *)p);
 791         break;
 792
 793     case ARR_WORDS:
 794         // nothing to follow
 795         break;
 796
 797     case MUT_ARR_PTRS_CLEAN:
 798     case MUT_ARR_PTRS_DIRTY:
 799     {
 800         StgPtr next, q;
 801         rtsBool saved_eager;
 802
 803         // We don't eagerly promote objects pointed to by a mutable
 804         // array, but if we find the array only points to objects in
 805         // the same or an older generation, we mark it "clean" and
 806         // avoid traversing it during minor GCs.
 807         saved_eager = gct->eager_promotion;
 808         gct->eager_promotion = rtsFalse;
 809         q = p;
 810         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
 811         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
 812             evacuate((StgClosure **)p);
 813         }
 814         gct->eager_promotion = saved_eager;
 815
 816         if (gct->failed_to_evac) {
 817             ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_DIRTY_info;
 818         } else {
 819             ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_CLEAN_info;
 820         }
 821
 822         gct->failed_to_evac = rtsTrue;
 823         break;
 824     }
 825
 826     case MUT_ARR_PTRS_FROZEN:
 827     case MUT_ARR_PTRS_FROZEN0:
 828     {
 829         // follow everything
 830         StgPtr next, q=p;
 831
 832         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
 833         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
 834             evacuate((StgClosure **)p);
 835         }
 836
 837         // If we're going to put this object on the mutable list, then
 838         // set its info ptr to MUT_ARR_PTRS_FROZEN0 to indicate that.
 839         if (gct->failed_to_evac) {
 840             ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN0_info;
 841         } else {
 842             ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN_info;
 843         }
 844         break;
 845     }
 846
 847     case TSO:
 848     {
 849         scavengeTSO((StgTSO*)p);
 850         break;
 851     }
 852
 853     case TVAR_WATCH_QUEUE:
 854       {
 855         StgTVarWatchQueue *wq = ((StgTVarWatchQueue *) p);
 856         gct->evac_step = 0;
 857         evacuate((StgClosure **)&wq->closure);
 858         evacuate((StgClosure **)&wq->next_queue_entry);
 859         evacuate((StgClosure **)&wq->prev_queue_entry);
 860         gct->evac_step = saved_evac_step;
 861         gct->failed_to_evac = rtsTrue; // mutable
 862         break;
 863       }
 864
 865     case TVAR:
 866       {
 867         StgTVar *tvar = ((StgTVar *) p);
 868         gct->evac_step = 0;
 869         evacuate((StgClosure **)&tvar->current_value);
 870         evacuate((StgClosure **)&tvar->first_watch_queue_entry);
 871         gct->evac_step = saved_evac_step;
 872         gct->failed_to_evac = rtsTrue; // mutable
 873         break;
 874       }
 875
 876     case TREC_HEADER:
 877       {
 878         StgTRecHeader *trec = ((StgTRecHeader *) p);
 879         gct->evac_step = 0;
 880         evacuate((StgClosure **)&trec->enclosing_trec);
 881         evacuate((StgClosure **)&trec->current_chunk);
 882         evacuate((StgClosure **)&trec->invariants_to_check);
 883         gct->evac_step = saved_evac_step;
 884         gct->failed_to_evac = rtsTrue; // mutable
 885         break;
 886       }
 887
 888     case TREC_CHUNK:
 889       {
 890         StgWord i;
 891         StgTRecChunk *tc = ((StgTRecChunk *) p);
 892         TRecEntry *e = &(tc -> entries[0]);
 893         gct->evac_step = 0;
 894         evacuate((StgClosure **)&tc->prev_chunk);
 895         for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
 896           evacuate((StgClosure **)&e->tvar);
 897           evacuate((StgClosure **)&e->expected_value);
 898           evacuate((StgClosure **)&e->new_value);
 899         }
 900         gct->evac_step = saved_evac_step;
 901         gct->failed_to_evac = rtsTrue; // mutable
 902         break;
 903       }
 904
 905     case ATOMIC_INVARIANT:
 906     {
 907       StgAtomicInvariant *invariant = ((StgAtomicInvariant *) p);
 908       gct->evac_step = 0;
 909       evacuate(&invariant->code);
 910       evacuate((StgClosure **)&invariant->last_execution);
 911       gct->evac_step = saved_evac_step;
 912       gct->failed_to_evac = rtsTrue; // mutable
 913       break;
 914     }
 915
 916     case INVARIANT_CHECK_QUEUE:
 917     {
 918       StgInvariantCheckQueue *queue = ((StgInvariantCheckQueue *) p);
 919       gct->evac_step = 0;
 920       evacuate((StgClosure **)&queue->invariant);
 921       evacuate((StgClosure **)&queue->my_execution);
 922       evacuate((StgClosure **)&queue->next_queue_entry);
 923       gct->evac_step = saved_evac_step;
 924       gct->failed_to_evac = rtsTrue; // mutable
 925       break;
 926     }
 927
 928     case IND_OLDGEN:
 929     case IND_OLDGEN_PERM:
 930     case IND_STATIC:
 931     {
 932         /* Careful here: a THUNK can be on the mutable list because
 933          * it contains pointers to young gen objects.  If such a thunk
 934          * is updated, the IND_OLDGEN will be added to the mutable
 935          * list again, and we'll scavenge it twice.  evacuate()
 936          * doesn't check whether the object has already been
 937          * evacuated, so we perform that check here.
 938          */
 939         StgClosure *q = ((StgInd *)p)->indirectee;
 940         if (HEAP_ALLOCED(q) && Bdescr((StgPtr)q)->flags & BF_EVACUATED) {
 941             break;
 942         }
 943         evacuate(&((StgInd *)p)->indirectee);
 944     }
 945
 946 #if 0 && defined(DEBUG)
 947       if (RtsFlags.DebugFlags.gc)
 948       /* Debugging code to print out the size of the thing we just
 949        * promoted
 950        */
 951       {
 952         StgPtr start = gen->steps[0].scan;
 953         bdescr *start_bd = gen->steps[0].scan_bd;
 954         nat size = 0;
 955         scavenge(&gen->steps[0]);
 956         if (start_bd != gen->steps[0].scan_bd) {
 957           size += (P_)BLOCK_ROUND_UP(start) - start;
 958           start_bd = start_bd->link;
 959           while (start_bd != gen->steps[0].scan_bd) {
 960             size += BLOCK_SIZE_W;
 961             start_bd = start_bd->link;
 962           }
 963           size += gen->steps[0].scan -
 964             (P_)BLOCK_ROUND_DOWN(gen->steps[0].scan);
 965         } else {
 966           size = gen->steps[0].scan - start;
 967         }
 968         debugBelch("evac IND_OLDGEN: %ld bytes", size * sizeof(W_));
 969       }
 970 #endif
 971       break;
 972
 973     default:
 974         barf("scavenge_one: strange object %d", (int)(info->type));
 975     }
 976
 977     no_luck = gct->failed_to_evac;
 978     gct->failed_to_evac = rtsFalse;
 979     return (no_luck);
 980 }
 981
 982 /* -----------------------------------------------------------------------------
 983    Scavenging mutable lists.
 984
 985    We treat the mutable list of each generation > N (i.e. all the
 986    generations older than the one being collected) as roots.  We also
 987    remove non-mutable objects from the mutable list at this point.
 988    -------------------------------------------------------------------------- */
 989
 990 void
 991 scavenge_mutable_list(generation *gen)
 992 {
 993     bdescr *bd;
 994     StgPtr p, q;
 995
 996     bd = gen->saved_mut_list;
 997
 998     gct->evac_step = &gen->steps[0];
 999     for (; bd != NULL; bd = bd->link) {
1000         for (q = bd->start; q < bd->free; q++) {
1001             p = (StgPtr)*q;
1002             ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
1003
1004 #ifdef DEBUG
1005             switch (get_itbl((StgClosure *)p)->type) {
1006             case MUT_VAR_CLEAN:
1007                 barf("MUT_VAR_CLEAN on mutable list");
1008             case MUT_VAR_DIRTY:
1009                 mutlist_MUTVARS++; break;
1010             case MUT_ARR_PTRS_CLEAN:
1011             case MUT_ARR_PTRS_DIRTY:
1012             case MUT_ARR_PTRS_FROZEN:
1013             case MUT_ARR_PTRS_FROZEN0:
1014                 mutlist_MUTARRS++; break;
1015             case MVAR_CLEAN:
1016                 barf("MVAR_CLEAN on mutable list");
1017             case MVAR_DIRTY:
1018                 mutlist_MVARS++; break;
1019             default:
1020                 mutlist_OTHERS++; break;
1021             }
1022 #endif
1023
1024             // Check whether this object is "clean", that is it
1025             // definitely doesn't point into a young generation.
1026             // Clean objects don't need to be scavenged.  Some clean
1027             // objects (MUT_VAR_CLEAN) are not kept on the mutable
1028             // list at all; others, such as MUT_ARR_PTRS_CLEAN and
1029             // TSO, are always on the mutable list.
1030             //
1031             switch (get_itbl((StgClosure *)p)->type) {
1032             case MUT_ARR_PTRS_CLEAN:
1033                 recordMutableGen_GC((StgClosure *)p,gen);
1034                 continue;
1035             case TSO: {
1036                 StgTSO *tso = (StgTSO *)p;
1037                 if ((tso->flags & TSO_DIRTY) == 0) {
1038                     // Must be on the mutable list because its link
1039                     // field is dirty.
1040                     ASSERT(tso->flags & TSO_LINK_DIRTY);
1041
1042                     scavenge_TSO_link(tso);
1043                     if (gct->failed_to_evac) {
1044                         recordMutableGen_GC((StgClosure *)p,gen);
1045                         gct->failed_to_evac = rtsFalse;
1046                     } else {
1047                         tso->flags &= ~TSO_LINK_DIRTY;
1048                     }
1049                     continue;
1050                 }
1051             }
1052             default:
1053                 ;
1054             }
1055
1056             if (scavenge_one(p)) {
1057                 // didn't manage to promote everything, so put the
1058                 // object back on the list.
1059                 recordMutableGen_GC((StgClosure *)p,gen);
1060             }
1061         }
1062     }
1063
1064     // free the old mut_list
1065     freeChain_sync(gen->saved_mut_list);
1066     gen->saved_mut_list = NULL;
1067 }
1068
1069 /* -----------------------------------------------------------------------------
1070    Scavenging the static objects.
1071
1072    We treat the mutable list of each generation > N (i.e. all the
1073    generations older than the one being collected) as roots.  We also
1074    remove non-mutable objects from the mutable list at this point.
1075    -------------------------------------------------------------------------- */
1076
1077 static void
1078 scavenge_static(void)
1079 {
1080   StgClosure* p;
1081   const StgInfoTable *info;
1082
1083   debugTrace(DEBUG_gc, "scavenging static objects");
1084
1085   /* Always evacuate straight to the oldest generation for static
1086    * objects */
1087   gct->evac_step = &oldest_gen->steps[0];
1088
1089   /* keep going until we've scavenged all the objects on the linked
1090      list... */
1091
1092   while (1) {
1093
1094     /* get the next static object from the list.  Remember, there might
1095      * be more stuff on this list after each evacuation...
1096      * (static_objects is a global)
1097      */
1098     p = gct->static_objects;
1099     if (p == END_OF_STATIC_LIST) {
1100           break;
1101     }
1102
1103     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
1104     info = get_itbl(p);
1105     /*
1106         if (info->type==RBH)
1107         info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
1108     */
1109     // make sure the info pointer is into text space
1110
1111     /* Take this object *off* the static_objects list,
1112      * and put it on the scavenged_static_objects list.
1113      */
1114     gct->static_objects = *STATIC_LINK(info,p);
1115     *STATIC_LINK(info,p) = gct->scavenged_static_objects;
1116     gct->scavenged_static_objects = p;
1117
1118     switch (info -> type) {
1119
1120     case IND_STATIC:
1121       {
1122         StgInd *ind = (StgInd *)p;
1123         evacuate(&ind->indirectee);
1124
1125         /* might fail to evacuate it, in which case we have to pop it
1126          * back on the mutable list of the oldest generation.  We
1127          * leave it *on* the scavenged_static_objects list, though,
1128          * in case we visit this object again.
1129          */
1130         if (gct->failed_to_evac) {
1131           gct->failed_to_evac = rtsFalse;
1132           recordMutableGen_GC((StgClosure *)p,oldest_gen);
1133         }
1134         break;
1135       }
1136
1137     case THUNK_STATIC:
1138       scavenge_thunk_srt(info);
1139       break;
1140
1141     case FUN_STATIC:
1142       scavenge_fun_srt(info);
1143       break;
1144
1145     case CONSTR_STATIC:
1146       {
1147         StgPtr q, next;
1148
1149         next = (P_)p->payload + info->layout.payload.ptrs;
1150         // evacuate the pointers
1151         for (q = (P_)p->payload; q < next; q++) {
1152             evacuate((StgClosure **)q);
1153         }
1154         break;
1155       }
1156
1157     default:
1158       barf("scavenge_static: strange closure %d", (int)(info->type));
1159     }
1160
1161     ASSERT(gct->failed_to_evac == rtsFalse);
1162   }
1163 }
1164
1165 /* -----------------------------------------------------------------------------
1166    scavenge a chunk of memory described by a bitmap
1167    -------------------------------------------------------------------------- */
1168
1169 static void
1170 scavenge_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, nat size )
1171 {
1172     nat i, b;
1173     StgWord bitmap;
1174
1175     b = 0;
1176     bitmap = large_bitmap->bitmap[b];
1177     for (i = 0; i < size; ) {
1178         if ((bitmap & 1) == 0) {
1179             evacuate((StgClosure **)p);
1180         }
1181         i++;
1182         p++;
1183         if (i % BITS_IN(W_) == 0) {
1184             b++;
1185             bitmap = large_bitmap->bitmap[b];
1186         } else {
1187             bitmap = bitmap >> 1;
1188         }
1189     }
1190 }
1191
1192 STATIC_INLINE StgPtr
1193 scavenge_small_bitmap (StgPtr p, nat size, StgWord bitmap)
1194 {
1195     while (size > 0) {
1196         if ((bitmap & 1) == 0) {
1197             evacuate((StgClosure **)p);
1198         }
1199         p++;
1200         bitmap = bitmap >> 1;
1201         size--;
1202     }
1203     return p;
1204 }
1205
1206 /* -----------------------------------------------------------------------------
1207    scavenge_stack walks over a section of stack and evacuates all the
1208    objects pointed to by it.  We can use the same code for walking
1209    AP_STACK_UPDs, since these are just sections of copied stack.
1210    -------------------------------------------------------------------------- */
1211
1212 static void
1213 scavenge_stack(StgPtr p, StgPtr stack_end)
1214 {
1215   const StgRetInfoTable* info;
1216   StgWord bitmap;
1217   nat size;
1218
1219   /*
1220    * Each time around this loop, we are looking at a chunk of stack
1221    * that starts with an activation record.
1222    */
1223
1224   while (p < stack_end) {
1225     info  = get_ret_itbl((StgClosure *)p);
1226
1227     switch (info->i.type) {
1228
1229     case UPDATE_FRAME:
1230         // In SMP, we can get update frames that point to indirections
1231         // when two threads evaluate the same thunk.  We do attempt to
1232         // discover this situation in threadPaused(), but it's
1233         // possible that the following sequence occurs:
1234         //
1235         //        A             B
1236         //                  enter T
1237         //     enter T
1238         //     blackhole T
1239         //                  update T
1240         //     GC
1241         //
1242         // Now T is an indirection, and the update frame is already
1243         // marked on A's stack, so we won't traverse it again in
1244         // threadPaused().  We could traverse the whole stack again
1245         // before GC, but that seems like overkill.
1246         //
1247         // Scavenging this update frame as normal would be disastrous;
1248         // the updatee would end up pointing to the value.  So we turn
1249         // the indirection into an IND_PERM, so that evacuate will
1250         // copy the indirection into the old generation instead of
1251         // discarding it.
1252     {
1253         nat type;
1254         const StgInfoTable *i;
1255
1256         i = ((StgUpdateFrame *)p)->updatee->header.info;
1257         if (!IS_FORWARDING_PTR(i)) {
1258             type = get_itbl(((StgUpdateFrame *)p)->updatee)->type;
1259             if (type == IND) {
1260                 ((StgUpdateFrame *)p)->updatee->header.info =
1261                     (StgInfoTable *)&stg_IND_PERM_info;
1262             } else if (type == IND_OLDGEN) {
1263                 ((StgUpdateFrame *)p)->updatee->header.info =
1264                     (StgInfoTable *)&stg_IND_OLDGEN_PERM_info;
1265             }
1266             evacuate(&((StgUpdateFrame *)p)->updatee);
1267             p += sizeofW(StgUpdateFrame);
1268             continue;
1269         }
1270     }
1271
1272       // small bitmap (< 32 entries, or 64 on a 64-bit machine)
1273     case CATCH_STM_FRAME:
1274     case CATCH_RETRY_FRAME:
1275     case ATOMICALLY_FRAME:
1276     case STOP_FRAME:
1277     case CATCH_FRAME:
1278     case RET_SMALL:
1279         bitmap = BITMAP_BITS(info->i.layout.bitmap);
1280         size   = BITMAP_SIZE(info->i.layout.bitmap);
1281         // NOTE: the payload starts immediately after the info-ptr, we
1282         // don't have an StgHeader in the same sense as a heap closure.
1283         p++;
1284         p = scavenge_small_bitmap(p, size, bitmap);
1285
1286     follow_srt:
1287         if (major_gc)
1288             scavenge_srt((StgClosure **)GET_SRT(info), info->i.srt_bitmap);
1289         continue;
1290
1291     case RET_BCO: {
1292         StgBCO *bco;
1293         nat size;
1294
1295         p++;
1296         evacuate((StgClosure **)p);
1297         bco = (StgBCO *)*p;
1298         p++;
1299         size = BCO_BITMAP_SIZE(bco);
1300         scavenge_large_bitmap(p, BCO_BITMAP(bco), size);
1301         p += size;
1302         continue;
1303     }
1304
1305       // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
1306     case RET_BIG:
1307     {
1308         nat size;
1309
1310         size = GET_LARGE_BITMAP(&info->i)->size;
1311         p++;
1312         scavenge_large_bitmap(p, GET_LARGE_BITMAP(&info->i), size);
1313         p += size;
1314         // and don't forget to follow the SRT
1315         goto follow_srt;
1316     }
1317
1318       // Dynamic bitmap: the mask is stored on the stack, and
1319       // there are a number of non-pointers followed by a number
1320       // of pointers above the bitmapped area.  (see StgMacros.h,
1321       // HEAP_CHK_GEN).
1322     case RET_DYN:
1323     {
1324         StgWord dyn;
1325         dyn = ((StgRetDyn *)p)->liveness;
1326
1327         // traverse the bitmap first
1328         bitmap = RET_DYN_LIVENESS(dyn);
1329         p      = (P_)&((StgRetDyn *)p)->payload[0];
1330         size   = RET_DYN_BITMAP_SIZE;
1331         p = scavenge_small_bitmap(p, size, bitmap);
1332
1333         // skip over the non-ptr words
1334         p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
1335
1336         // follow the ptr words
1337         for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
1338             evacuate((StgClosure **)p);
1339             p++;
1340         }
1341         continue;
1342     }
1343
1344     case RET_FUN:
1345     {
1346         StgRetFun *ret_fun = (StgRetFun *)p;
1347         StgFunInfoTable *fun_info;
1348
1349         evacuate(&ret_fun->fun);
1350         fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
1351         p = scavenge_arg_block(fun_info, ret_fun->payload);
1352         goto follow_srt;
1353     }
1354
1355     default:
1356         barf("scavenge_stack: weird activation record found on stack: %d", (int)(info->i.type));
1357     }
1358   }
1359 }
1360
1361 /*-----------------------------------------------------------------------------
1362   scavenge the large object list.
1363
1364   evac_step set by caller; similar games played with evac_step as with
1365   scavenge() - see comment at the top of scavenge().  Most large
1366   objects are (repeatedly) mutable, so most of the time evac_step will
1367   be zero.
1368   --------------------------------------------------------------------------- */
1369
1370 static void
1371 scavenge_large (step_workspace *ws)
1372 {
1373     bdescr *bd;
1374     StgPtr p;
1375
1376     gct->evac_step = ws->step;
1377
1378     bd = ws->todo_large_objects;
1379
1380     for (; bd != NULL; bd = ws->todo_large_objects) {
1381
1382         // take this object *off* the large objects list and put it on
1383         // the scavenged large objects list.  This is so that we can
1384         // treat new_large_objects as a stack and push new objects on
1385         // the front when evacuating.
1386         ws->todo_large_objects = bd->link;
1387
1388         ACQUIRE_SPIN_LOCK(&ws->step->sync_large_objects);
1389         dbl_link_onto(bd, &ws->step->scavenged_large_objects);
1390         ws->step->n_scavenged_large_blocks += bd->blocks;
1391         RELEASE_SPIN_LOCK(&ws->step->sync_large_objects);
1392
1393         p = bd->start;
1394         if (scavenge_one(p)) {
1395             if (ws->step->gen_no > 0) {
1396                 recordMutableGen_GC((StgClosure *)p, ws->step->gen);
1397             }
1398         }
1399
1400         // stats
1401         gct->scanned += closure_sizeW((StgClosure*)p);
1402     }
1403 }
1404
1405 /* ----------------------------------------------------------------------------
1406    Scavenge a block
1407    ------------------------------------------------------------------------- */
1408
1409 #undef PARALLEL_GC
1410 #include "Scav.c-inc"
1411
1412 #ifdef THREADED_RTS
1413 #define PARALLEL_GC
1414 #include "Scav.c-inc"
1415 #endif
1416
1417 /* ----------------------------------------------------------------------------
1418    Look for work to do.
1419
1420    We look for the oldest step that has either a todo block that can
1421    be scanned, or a block of work on the global queue that we can
1422    scan.
1423
1424    It is important to take work from the *oldest* generation that we
1425    has work available, because that minimizes the likelihood of
1426    evacuating objects into a young generation when they should have
1427    been eagerly promoted.  This really does make a difference (the
1428    cacheprof benchmark is one that is affected).
1429
1430    We also want to scan the todo block if possible before grabbing
1431    work from the global queue, the reason being that we don't want to
1432    steal work from the global queue and starve other threads if there
1433    is other work we can usefully be doing.
1434    ------------------------------------------------------------------------- */
1435
1436 static rtsBool
1437 scavenge_find_work (void)
1438 {
1439     int s;
1440     step_workspace *ws;
1441     rtsBool did_something, did_anything;
1442     bdescr *bd;
1443
1444     gct->scav_find_work++;
1445
1446     did_anything = rtsFalse;
1447
1448 loop:
1449     did_something = rtsFalse;
1450     for (s = total_steps-1; s >= 0; s--) {
1451         if (s == 0 && RtsFlags.GcFlags.generations > 1) {
1452             continue;
1453         }
1454         ws = &gct->steps[s];
1455
1456         gct->scan_bd = NULL;
1457
1458         // If we have a scan block with some work to do,
1459         // scavenge everything up to the free pointer.
1460         if (ws->todo_bd->u.scan < ws->todo_free)
1461         {
1462             if (n_gc_threads == 1) {
1463                 scavenge_block1(ws->todo_bd);
1464             } else {
1465                 scavenge_block(ws->todo_bd);
1466             }
1467             did_something = rtsTrue;
1468             break;
1469         }
1470
1471         // If we have any large objects to scavenge, do them now.
1472         if (ws->todo_large_objects) {
1473             scavenge_large(ws);
1474             did_something = rtsTrue;
1475             break;
1476         }
1477
1478         if ((bd = grab_todo_block(ws)) != NULL) {
1479             if (n_gc_threads == 1) {
1480                 scavenge_block1(bd);
1481             } else {
1482                 scavenge_block(bd);
1483             }
1484             did_something = rtsTrue;
1485             break;
1486         }
1487     }
1488
1489     if (did_something) {
1490         did_anything = rtsTrue;
1491         goto loop;
1492     }
1493     // only return when there is no more work to do
1494
1495     return did_anything;
1496 }
1497
1498 /* ----------------------------------------------------------------------------
1499    Scavenge until we can't find anything more to scavenge.
1500    ------------------------------------------------------------------------- */
1501
1502 void
1503 scavenge_loop(void)
1504 {
1505     rtsBool work_to_do;
1506
1507 loop:
1508     work_to_do = rtsFalse;
1509
1510     // scavenge static objects
1511     if (major_gc && gct->static_objects != END_OF_STATIC_LIST) {
1512         IF_DEBUG(sanity, checkStaticObjects(gct->static_objects));
1513         scavenge_static();
1514     }
1515
1516     // scavenge objects in compacted generation
1517     if (mark_stack_overflowed || oldgen_scan_bd != NULL ||
1518         (mark_stack_bdescr != NULL && !mark_stack_empty())) {
1519         scavenge_mark_stack();
1520         work_to_do = rtsTrue;
1521     }
1522
1523     // Order is important here: we want to deal in full blocks as
1524     // much as possible, so go for global work in preference to
1525     // local work.  Only if all the global work has been exhausted
1526     // do we start scavenging the fragments of blocks in the local
1527     // workspaces.
1528     if (scavenge_find_work()) goto loop;
1529
1530     if (work_to_do) goto loop;
1531 }
1532
1533 rtsBool
1534 any_work (void)
1535 {
1536     int s;
1537     step_workspace *ws;
1538
1539     gct->any_work++;
1540
1541     write_barrier();
1542
1543     // scavenge objects in compacted generation
1544     if (mark_stack_overflowed || oldgen_scan_bd != NULL ||
1545         (mark_stack_bdescr != NULL && !mark_stack_empty())) {
1546         return rtsTrue;
1547     }
1548
1549     // Check for global work in any step.  We don't need to check for
1550     // local work, because we have already exited scavenge_loop(),
1551     // which means there is no local work for this thread.
1552     for (s = total_steps-1; s >= 0; s--) {
1553         if (s == 0 && RtsFlags.GcFlags.generations > 1) {
1554             continue;
1555         }
1556         ws = &gct->steps[s];
1557         if (ws->todo_large_objects) return rtsTrue;
1558         if (ws->step->todos) return rtsTrue;
1559     }
1560
1561     gct->no_work++;
1562
1563     return rtsFalse;
1564 }