rts/sm/Scav.c

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