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 #include "Capability.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->flags |= TSO_DIRTY;
  93         scavenge_TSO_link(tso);
  94     } else {
  95         tso->flags &= ~TSO_DIRTY;
  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_OLDGEN:
1365     case IND_OLDGEN_PERM:
1366     case IND_STATIC:
1367     {
1368         /* Careful here: a THUNK can be on the mutable list because
1369          * it contains pointers to young gen objects.  If such a thunk
1370          * is updated, the IND_OLDGEN will be added to the mutable
1371          * list again, and we'll scavenge it twice.  evacuate()
1372          * doesn't check whether the object has already been
1373          * evacuated, so we perform that check here.
1374          */
1375         StgClosure *q = ((StgInd *)p)->indirectee;
1376         if (HEAP_ALLOCED_GC(q) && Bdescr((StgPtr)q)->flags & BF_EVACUATED) {
1377             break;
1378         }
1379         evacuate(&((StgInd *)p)->indirectee);
1380     }
1381
1382 #if 0 && defined(DEBUG)
1383       if (RtsFlags.DebugFlags.gc)
1384       /* Debugging code to print out the size of the thing we just
1385        * promoted
1386        */
1387       {
1388         StgPtr start = gen->steps[0].scan;
1389         bdescr *start_bd = gen->steps[0].scan_bd;
1390         nat size = 0;
1391         scavenge(&gen->steps[0]);
1392         if (start_bd != gen->steps[0].scan_bd) {
1393           size += (P_)BLOCK_ROUND_UP(start) - start;
1394           start_bd = start_bd->link;
1395           while (start_bd != gen->steps[0].scan_bd) {
1396             size += BLOCK_SIZE_W;
1397             start_bd = start_bd->link;
1398           }
1399           size += gen->steps[0].scan -
1400             (P_)BLOCK_ROUND_DOWN(gen->steps[0].scan);
1401         } else {
1402           size = gen->steps[0].scan - start;
1403         }
1404         debugBelch("evac IND_OLDGEN: %ld bytes", size * sizeof(W_));
1405       }
1406 #endif
1407       break;
1408
1409     default:
1410         barf("scavenge_one: strange object %d", (int)(info->type));
1411     }
1412
1413     no_luck = gct->failed_to_evac;
1414     gct->failed_to_evac = rtsFalse;
1415     return (no_luck);
1416 }
1417
1418 /* -----------------------------------------------------------------------------
1419    Scavenging mutable lists.
1420
1421    We treat the mutable list of each generation > N (i.e. all the
1422    generations older than the one being collected) as roots.  We also
1423    remove non-mutable objects from the mutable list at this point.
1424    -------------------------------------------------------------------------- */
1425
1426 void
1427 scavenge_mutable_list(bdescr *bd, generation *gen)
1428 {
1429     StgPtr p, q;
1430
1431     gct->evac_step = &gen->steps[0];
1432     for (; bd != NULL; bd = bd->link) {
1433         for (q = bd->start; q < bd->free; q++) {
1434             p = (StgPtr)*q;
1435             ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
1436
1437 #ifdef DEBUG
1438             switch (get_itbl((StgClosure *)p)->type) {
1439             case MUT_VAR_CLEAN:
1440                 barf("MUT_VAR_CLEAN on mutable list");
1441             case MUT_VAR_DIRTY:
1442                 mutlist_MUTVARS++; break;
1443             case MUT_ARR_PTRS_CLEAN:
1444             case MUT_ARR_PTRS_DIRTY:
1445             case MUT_ARR_PTRS_FROZEN:
1446             case MUT_ARR_PTRS_FROZEN0:
1447                 mutlist_MUTARRS++; break;
1448             case MVAR_CLEAN:
1449                 barf("MVAR_CLEAN on mutable list");
1450             case MVAR_DIRTY:
1451                 mutlist_MVARS++; break;
1452             default:
1453                 mutlist_OTHERS++; break;
1454             }
1455 #endif
1456
1457             // Check whether this object is "clean", that is it
1458             // definitely doesn't point into a young generation.
1459             // Clean objects don't need to be scavenged.  Some clean
1460             // objects (MUT_VAR_CLEAN) are not kept on the mutable
1461             // list at all; others, such as MUT_ARR_PTRS_CLEAN
1462             // are always on the mutable list.
1463             //
1464             switch (get_itbl((StgClosure *)p)->type) {
1465             case MUT_ARR_PTRS_CLEAN:
1466                 recordMutableGen_GC((StgClosure *)p,gen->no);
1467                 continue;
1468             case TSO: {
1469                 StgTSO *tso = (StgTSO *)p;
1470                 if ((tso->flags & TSO_DIRTY) == 0) {
1471                     // Must be on the mutable list because its link
1472                     // field is dirty.
1473                     ASSERT(tso->flags & TSO_LINK_DIRTY);
1474
1475                     scavenge_TSO_link(tso);
1476                     if (gct->failed_to_evac) {
1477                         recordMutableGen_GC((StgClosure *)p,gen->no);
1478                         gct->failed_to_evac = rtsFalse;
1479                     } else {
1480                         tso->flags &= ~TSO_LINK_DIRTY;
1481                     }
1482                     continue;
1483                 }
1484             }
1485             default:
1486                 ;
1487             }
1488
1489             if (scavenge_one(p)) {
1490                 // didn't manage to promote everything, so put the
1491                 // object back on the list.
1492                 recordMutableGen_GC((StgClosure *)p,gen->no);
1493             }
1494         }
1495     }
1496 }
1497
1498 void
1499 scavenge_capability_mut_lists (Capability *cap)
1500 {
1501     nat g;
1502
1503     /* Mutable lists from each generation > N
1504      * we want to *scavenge* these roots, not evacuate them: they're not
1505      * going to move in this GC.
1506      * Also do them in reverse generation order, for the usual reason:
1507      * namely to reduce the likelihood of spurious old->new pointers.
1508      */
1509     for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
1510         scavenge_mutable_list(cap->saved_mut_lists[g], &generations[g]);
1511         freeChain_sync(cap->saved_mut_lists[g]);
1512         cap->saved_mut_lists[g] = NULL;
1513     }
1514 }
1515
1516 /* -----------------------------------------------------------------------------
1517    Scavenging the static objects.
1518
1519    We treat the mutable list of each generation > N (i.e. all the
1520    generations older than the one being collected) as roots.  We also
1521    remove non-mutable objects from the mutable list at this point.
1522    -------------------------------------------------------------------------- */
1523
1524 static void
1525 scavenge_static(void)
1526 {
1527   StgClosure* p;
1528   const StgInfoTable *info;
1529
1530   debugTrace(DEBUG_gc, "scavenging static objects");
1531
1532   /* Always evacuate straight to the oldest generation for static
1533    * objects */
1534   gct->evac_step = &oldest_gen->steps[0];
1535
1536   /* keep going until we've scavenged all the objects on the linked
1537      list... */
1538
1539   while (1) {
1540
1541     /* get the next static object from the list.  Remember, there might
1542      * be more stuff on this list after each evacuation...
1543      * (static_objects is a global)
1544      */
1545     p = gct->static_objects;
1546     if (p == END_OF_STATIC_LIST) {
1547           break;
1548     }
1549
1550     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
1551     info = get_itbl(p);
1552     /*
1553         if (info->type==RBH)
1554         info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
1555     */
1556     // make sure the info pointer is into text space
1557
1558     /* Take this object *off* the static_objects list,
1559      * and put it on the scavenged_static_objects list.
1560      */
1561     gct->static_objects = *STATIC_LINK(info,p);
1562     *STATIC_LINK(info,p) = gct->scavenged_static_objects;
1563     gct->scavenged_static_objects = p;
1564
1565     switch (info -> type) {
1566
1567     case IND_STATIC:
1568       {
1569         StgInd *ind = (StgInd *)p;
1570         evacuate(&ind->indirectee);
1571
1572         /* might fail to evacuate it, in which case we have to pop it
1573          * back on the mutable list of the oldest generation.  We
1574          * leave it *on* the scavenged_static_objects list, though,
1575          * in case we visit this object again.
1576          */
1577         if (gct->failed_to_evac) {
1578           gct->failed_to_evac = rtsFalse;
1579           recordMutableGen_GC((StgClosure *)p,oldest_gen->no);
1580         }
1581         break;
1582       }
1583
1584     case THUNK_STATIC:
1585       scavenge_thunk_srt(info);
1586       break;
1587
1588     case FUN_STATIC:
1589       scavenge_fun_srt(info);
1590       break;
1591
1592     case CONSTR_STATIC:
1593       {
1594         StgPtr q, next;
1595
1596         next = (P_)p->payload + info->layout.payload.ptrs;
1597         // evacuate the pointers
1598         for (q = (P_)p->payload; q < next; q++) {
1599             evacuate((StgClosure **)q);
1600         }
1601         break;
1602       }
1603
1604     default:
1605       barf("scavenge_static: strange closure %d", (int)(info->type));
1606     }
1607
1608     ASSERT(gct->failed_to_evac == rtsFalse);
1609   }
1610 }
1611
1612 /* -----------------------------------------------------------------------------
1613    scavenge a chunk of memory described by a bitmap
1614    -------------------------------------------------------------------------- */
1615
1616 static void
1617 scavenge_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, nat size )
1618 {
1619     nat i, b;
1620     StgWord bitmap;
1621
1622     b = 0;
1623     bitmap = large_bitmap->bitmap[b];
1624     for (i = 0; i < size; ) {
1625         if ((bitmap & 1) == 0) {
1626             evacuate((StgClosure **)p);
1627         }
1628         i++;
1629         p++;
1630         if (i % BITS_IN(W_) == 0) {
1631             b++;
1632             bitmap = large_bitmap->bitmap[b];
1633         } else {
1634             bitmap = bitmap >> 1;
1635         }
1636     }
1637 }
1638
1639 STATIC_INLINE StgPtr
1640 scavenge_small_bitmap (StgPtr p, nat size, StgWord bitmap)
1641 {
1642     while (size > 0) {
1643         if ((bitmap & 1) == 0) {
1644             evacuate((StgClosure **)p);
1645         }
1646         p++;
1647         bitmap = bitmap >> 1;
1648         size--;
1649     }
1650     return p;
1651 }
1652
1653 /* -----------------------------------------------------------------------------
1654    scavenge_stack walks over a section of stack and evacuates all the
1655    objects pointed to by it.  We can use the same code for walking
1656    AP_STACK_UPDs, since these are just sections of copied stack.
1657    -------------------------------------------------------------------------- */
1658
1659 static void
1660 scavenge_stack(StgPtr p, StgPtr stack_end)
1661 {
1662   const StgRetInfoTable* info;
1663   StgWord bitmap;
1664   nat size;
1665
1666   /*
1667    * Each time around this loop, we are looking at a chunk of stack
1668    * that starts with an activation record.
1669    */
1670
1671   while (p < stack_end) {
1672     info  = get_ret_itbl((StgClosure *)p);
1673
1674     switch (info->i.type) {
1675
1676     case UPDATE_FRAME:
1677         // In SMP, we can get update frames that point to indirections
1678         // when two threads evaluate the same thunk.  We do attempt to
1679         // discover this situation in threadPaused(), but it's
1680         // possible that the following sequence occurs:
1681         //
1682         //        A             B
1683         //                  enter T
1684         //     enter T
1685         //     blackhole T
1686         //                  update T
1687         //     GC
1688         //
1689         // Now T is an indirection, and the update frame is already
1690         // marked on A's stack, so we won't traverse it again in
1691         // threadPaused().  We could traverse the whole stack again
1692         // before GC, but that seems like overkill.
1693         //
1694         // Scavenging this update frame as normal would be disastrous;
1695         // the updatee would end up pointing to the value.  So we turn
1696         // the indirection into an IND_PERM, so that evacuate will
1697         // copy the indirection into the old generation instead of
1698         // discarding it.
1699         //
1700         // Note [upd-black-hole]
1701         // One slight hiccup is that the THUNK_SELECTOR machinery can
1702         // overwrite the updatee with an IND.  In parallel GC, this
1703         // could even be happening concurrently, so we can't check for
1704         // the IND.  Fortunately if we assume that blackholing is
1705         // happening (either lazy or eager), then we can be sure that
1706         // the updatee is never a THUNK_SELECTOR and we're ok.
1707         // NB. this is a new invariant: blackholing is not optional.
1708     {
1709         nat type;
1710         const StgInfoTable *i;
1711         StgClosure *updatee;
1712
1713         updatee = ((StgUpdateFrame *)p)->updatee;
1714         i = updatee->header.info;
1715         if (!IS_FORWARDING_PTR(i)) {
1716             type = get_itbl(updatee)->type;
1717             if (type == IND) {
1718                 updatee->header.info = &stg_IND_PERM_info;
1719             } else if (type == IND_OLDGEN) {
1720                 updatee->header.info = &stg_IND_OLDGEN_PERM_info;
1721             }
1722         }
1723         evacuate(&((StgUpdateFrame *)p)->updatee);
1724         ASSERT(GET_CLOSURE_TAG(((StgUpdateFrame *)p)->updatee) == 0);
1725         p += sizeofW(StgUpdateFrame);
1726         continue;
1727     }
1728
1729       // small bitmap (< 32 entries, or 64 on a 64-bit machine)
1730     case CATCH_STM_FRAME:
1731     case CATCH_RETRY_FRAME:
1732     case ATOMICALLY_FRAME:
1733     case STOP_FRAME:
1734     case CATCH_FRAME:
1735     case RET_SMALL:
1736         bitmap = BITMAP_BITS(info->i.layout.bitmap);
1737         size   = BITMAP_SIZE(info->i.layout.bitmap);
1738         // NOTE: the payload starts immediately after the info-ptr, we
1739         // don't have an StgHeader in the same sense as a heap closure.
1740         p++;
1741         p = scavenge_small_bitmap(p, size, bitmap);
1742
1743     follow_srt:
1744         if (major_gc)
1745             scavenge_srt((StgClosure **)GET_SRT(info), info->i.srt_bitmap);
1746         continue;
1747
1748     case RET_BCO: {
1749         StgBCO *bco;
1750         nat size;
1751
1752         p++;
1753         evacuate((StgClosure **)p);
1754         bco = (StgBCO *)*p;
1755         p++;
1756         size = BCO_BITMAP_SIZE(bco);
1757         scavenge_large_bitmap(p, BCO_BITMAP(bco), size);
1758         p += size;
1759         continue;
1760     }
1761
1762       // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
1763     case RET_BIG:
1764     {
1765         nat size;
1766
1767         size = GET_LARGE_BITMAP(&info->i)->size;
1768         p++;
1769         scavenge_large_bitmap(p, GET_LARGE_BITMAP(&info->i), size);
1770         p += size;
1771         // and don't forget to follow the SRT
1772         goto follow_srt;
1773     }
1774
1775       // Dynamic bitmap: the mask is stored on the stack, and
1776       // there are a number of non-pointers followed by a number
1777       // of pointers above the bitmapped area.  (see StgMacros.h,
1778       // HEAP_CHK_GEN).
1779     case RET_DYN:
1780     {
1781         StgWord dyn;
1782         dyn = ((StgRetDyn *)p)->liveness;
1783
1784         // traverse the bitmap first
1785         bitmap = RET_DYN_LIVENESS(dyn);
1786         p      = (P_)&((StgRetDyn *)p)->payload[0];
1787         size   = RET_DYN_BITMAP_SIZE;
1788         p = scavenge_small_bitmap(p, size, bitmap);
1789
1790         // skip over the non-ptr words
1791         p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
1792
1793         // follow the ptr words
1794         for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
1795             evacuate((StgClosure **)p);
1796             p++;
1797         }
1798         continue;
1799     }
1800
1801     case RET_FUN:
1802     {
1803         StgRetFun *ret_fun = (StgRetFun *)p;
1804         StgFunInfoTable *fun_info;
1805
1806         evacuate(&ret_fun->fun);
1807         fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
1808         p = scavenge_arg_block(fun_info, ret_fun->payload);
1809         goto follow_srt;
1810     }
1811
1812     default:
1813         barf("scavenge_stack: weird activation record found on stack: %d", (int)(info->i.type));
1814     }
1815   }
1816 }
1817
1818 /*-----------------------------------------------------------------------------
1819   scavenge the large object list.
1820
1821   evac_step set by caller; similar games played with evac_step as with
1822   scavenge() - see comment at the top of scavenge().  Most large
1823   objects are (repeatedly) mutable, so most of the time evac_step will
1824   be zero.
1825   --------------------------------------------------------------------------- */
1826
1827 static void
1828 scavenge_large (step_workspace *ws)
1829 {
1830     bdescr *bd;
1831     StgPtr p;
1832
1833     gct->evac_step = ws->step;
1834
1835     bd = ws->todo_large_objects;
1836
1837     for (; bd != NULL; bd = ws->todo_large_objects) {
1838
1839         // take this object *off* the large objects list and put it on
1840         // the scavenged large objects list.  This is so that we can
1841         // treat new_large_objects as a stack and push new objects on
1842         // the front when evacuating.
1843         ws->todo_large_objects = bd->link;
1844
1845         ACQUIRE_SPIN_LOCK(&ws->step->sync_large_objects);
1846         dbl_link_onto(bd, &ws->step->scavenged_large_objects);
1847         ws->step->n_scavenged_large_blocks += bd->blocks;
1848         RELEASE_SPIN_LOCK(&ws->step->sync_large_objects);
1849
1850         p = bd->start;
1851         if (scavenge_one(p)) {
1852             if (ws->step->gen_no > 0) {
1853                 recordMutableGen_GC((StgClosure *)p, ws->step->gen_no);
1854             }
1855         }
1856
1857         // stats
1858         gct->scanned += closure_sizeW((StgClosure*)p);
1859     }
1860 }
1861
1862 /* ----------------------------------------------------------------------------
1863    Look for work to do.
1864
1865    We look for the oldest step that has either a todo block that can
1866    be scanned, or a block of work on the global queue that we can
1867    scan.
1868
1869    It is important to take work from the *oldest* generation that we
1870    has work available, because that minimizes the likelihood of
1871    evacuating objects into a young generation when they should have
1872    been eagerly promoted.  This really does make a difference (the
1873    cacheprof benchmark is one that is affected).
1874
1875    We also want to scan the todo block if possible before grabbing
1876    work from the global queue, the reason being that we don't want to
1877    steal work from the global queue and starve other threads if there
1878    is other work we can usefully be doing.
1879    ------------------------------------------------------------------------- */
1880
1881 static rtsBool
1882 scavenge_find_work (void)
1883 {
1884     int s;
1885     step_workspace *ws;
1886     rtsBool did_something, did_anything;
1887     bdescr *bd;
1888
1889     gct->scav_find_work++;
1890
1891     did_anything = rtsFalse;
1892
1893 loop:
1894     did_something = rtsFalse;
1895     for (s = total_steps-1; s >= 0; s--) {
1896         if (s == 0 && RtsFlags.GcFlags.generations > 1) {
1897             continue;
1898         }
1899         ws = &gct->steps[s];
1900
1901         gct->scan_bd = NULL;
1902
1903         // If we have a scan block with some work to do,
1904         // scavenge everything up to the free pointer.
1905         if (ws->todo_bd->u.scan < ws->todo_free)
1906         {
1907             scavenge_block(ws->todo_bd);
1908             did_something = rtsTrue;
1909             break;
1910         }
1911
1912         // If we have any large objects to scavenge, do them now.
1913         if (ws->todo_large_objects) {
1914             scavenge_large(ws);
1915             did_something = rtsTrue;
1916             break;
1917         }
1918
1919         if ((bd = grab_local_todo_block(ws)) != NULL) {
1920             scavenge_block(bd);
1921             did_something = rtsTrue;
1922             break;
1923         }
1924     }
1925
1926     if (did_something) {
1927         did_anything = rtsTrue;
1928         goto loop;
1929     }
1930
1931 #if defined(THREADED_RTS)
1932     if (work_stealing) {
1933         // look for work to steal
1934         for (s = total_steps-1; s >= 0; s--) {
1935             if (s == 0 && RtsFlags.GcFlags.generations > 1) {
1936                 continue;
1937             }
1938             if ((bd = steal_todo_block(s)) != NULL) {
1939                 scavenge_block(bd);
1940                 did_something = rtsTrue;
1941                 break;
1942             }
1943         }
1944
1945         if (did_something) {
1946             did_anything = rtsTrue;
1947             goto loop;
1948         }
1949     }
1950 #endif
1951
1952     // only return when there is no more work to do
1953
1954     return did_anything;
1955 }
1956
1957 /* ----------------------------------------------------------------------------
1958    Scavenge until we can't find anything more to scavenge.
1959    ------------------------------------------------------------------------- */
1960
1961 void
1962 scavenge_loop(void)
1963 {
1964     rtsBool work_to_do;
1965
1966 loop:
1967     work_to_do = rtsFalse;
1968
1969     // scavenge static objects
1970     if (major_gc && gct->static_objects != END_OF_STATIC_LIST) {
1971         IF_DEBUG(sanity, checkStaticObjects(gct->static_objects));
1972         scavenge_static();
1973     }
1974
1975     // scavenge objects in compacted generation
1976     if (mark_stack_overflowed || oldgen_scan_bd != NULL ||
1977         (mark_stack_bdescr != NULL && !mark_stack_empty())) {
1978         scavenge_mark_stack();
1979         work_to_do = rtsTrue;
1980     }
1981
1982     // Order is important here: we want to deal in full blocks as
1983     // much as possible, so go for global work in preference to
1984     // local work.  Only if all the global work has been exhausted
1985     // do we start scavenging the fragments of blocks in the local
1986     // workspaces.
1987     if (scavenge_find_work()) goto loop;
1988
1989     if (work_to_do) goto loop;
1990 }
1991