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