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