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