rts/sm/Scav.c

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