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