rts/sm/Scav.c

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