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