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                     // Must be on the mutable list because its link
1494                     // field is dirty.
1495                     ASSERT(tso->flags & TSO_LINK_DIRTY);
1496
1497                     scavenge_TSO_link(tso);
1498                     if (gct->failed_to_evac) {
1499                         recordMutableGen_GC((StgClosure *)p,gen->no);
1500                         gct->failed_to_evac = rtsFalse;
1501                     } else {
1502                         tso->flags &= ~TSO_LINK_DIRTY;
1503                     }
1504                     continue;
1505                 }
1506             }
1507             default:
1508                 ;
1509             }
1510
1511             if (scavenge_one(p)) {
1512                 // didn't manage to promote everything, so put the
1513                 // object back on the list.
1514                 recordMutableGen_GC((StgClosure *)p,gen->no);
1515             }
1516         }
1517     }
1518 }
1519
1520 void
1521 scavenge_capability_mut_lists (Capability *cap)
1522 {
1523     nat g;
1524
1525     /* Mutable lists from each generation > N
1526      * we want to *scavenge* these roots, not evacuate them: they're not
1527      * going to move in this GC.
1528      * Also do them in reverse generation order, for the usual reason:
1529      * namely to reduce the likelihood of spurious old->new pointers.
1530      */
1531     for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
1532         scavenge_mutable_list(cap->saved_mut_lists[g], &generations[g]);
1533         freeChain_sync(cap->saved_mut_lists[g]);
1534         cap->saved_mut_lists[g] = NULL;
1535     }
1536 }
1537
1538 /* -----------------------------------------------------------------------------
1539    Scavenging the static objects.
1540
1541    We treat the mutable list of each generation > N (i.e. all the
1542    generations older than the one being collected) as roots.  We also
1543    remove non-mutable objects from the mutable list at this point.
1544    -------------------------------------------------------------------------- */
1545
1546 static void
1547 scavenge_static(void)
1548 {
1549   StgClosure* p;
1550   const StgInfoTable *info;
1551
1552   debugTrace(DEBUG_gc, "scavenging static objects");
1553
1554   /* Always evacuate straight to the oldest generation for static
1555    * objects */
1556   gct->evac_gen = oldest_gen;
1557
1558   /* keep going until we've scavenged all the objects on the linked
1559      list... */
1560
1561   while (1) {
1562
1563     /* get the next static object from the list.  Remember, there might
1564      * be more stuff on this list after each evacuation...
1565      * (static_objects is a global)
1566      */
1567     p = gct->static_objects;
1568     if (p == END_OF_STATIC_LIST) {
1569           break;
1570     }
1571
1572     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
1573     info = get_itbl(p);
1574     /*
1575         if (info->type==RBH)
1576         info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
1577     */
1578     // make sure the info pointer is into text space
1579
1580     /* Take this object *off* the static_objects list,
1581      * and put it on the scavenged_static_objects list.
1582      */
1583     gct->static_objects = *STATIC_LINK(info,p);
1584     *STATIC_LINK(info,p) = gct->scavenged_static_objects;
1585     gct->scavenged_static_objects = p;
1586
1587     switch (info -> type) {
1588
1589     case IND_STATIC:
1590       {
1591         StgInd *ind = (StgInd *)p;
1592         evacuate(&ind->indirectee);
1593
1594         /* might fail to evacuate it, in which case we have to pop it
1595          * back on the mutable list of the oldest generation.  We
1596          * leave it *on* the scavenged_static_objects list, though,
1597          * in case we visit this object again.
1598          */
1599         if (gct->failed_to_evac) {
1600           gct->failed_to_evac = rtsFalse;
1601           recordMutableGen_GC((StgClosure *)p,oldest_gen->no);
1602         }
1603         break;
1604       }
1605
1606     case THUNK_STATIC:
1607       scavenge_thunk_srt(info);
1608       break;
1609
1610     case FUN_STATIC:
1611       scavenge_fun_srt(info);
1612       break;
1613
1614     case CONSTR_STATIC:
1615       {
1616         StgPtr q, next;
1617
1618         next = (P_)p->payload + info->layout.payload.ptrs;
1619         // evacuate the pointers
1620         for (q = (P_)p->payload; q < next; q++) {
1621             evacuate((StgClosure **)q);
1622         }
1623         break;
1624       }
1625
1626     default:
1627       barf("scavenge_static: strange closure %d", (int)(info->type));
1628     }
1629
1630     ASSERT(gct->failed_to_evac == rtsFalse);
1631   }
1632 }
1633
1634 /* -----------------------------------------------------------------------------
1635    scavenge a chunk of memory described by a bitmap
1636    -------------------------------------------------------------------------- */
1637
1638 static void
1639 scavenge_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, nat size )
1640 {
1641     nat i, b;
1642     StgWord bitmap;
1643
1644     b = 0;
1645     bitmap = large_bitmap->bitmap[b];
1646     for (i = 0; i < size; ) {
1647         if ((bitmap & 1) == 0) {
1648             evacuate((StgClosure **)p);
1649         }
1650         i++;
1651         p++;
1652         if (i % BITS_IN(W_) == 0) {
1653             b++;
1654             bitmap = large_bitmap->bitmap[b];
1655         } else {
1656             bitmap = bitmap >> 1;
1657         }
1658     }
1659 }
1660
1661 STATIC_INLINE StgPtr
1662 scavenge_small_bitmap (StgPtr p, nat size, StgWord bitmap)
1663 {
1664     while (size > 0) {
1665         if ((bitmap & 1) == 0) {
1666             evacuate((StgClosure **)p);
1667         }
1668         p++;
1669         bitmap = bitmap >> 1;
1670         size--;
1671     }
1672     return p;
1673 }
1674
1675 /* -----------------------------------------------------------------------------
1676    scavenge_stack walks over a section of stack and evacuates all the
1677    objects pointed to by it.  We can use the same code for walking
1678    AP_STACK_UPDs, since these are just sections of copied stack.
1679    -------------------------------------------------------------------------- */
1680
1681 static void
1682 scavenge_stack(StgPtr p, StgPtr stack_end)
1683 {
1684   const StgRetInfoTable* info;
1685   StgWord bitmap;
1686   nat size;
1687
1688   /*
1689    * Each time around this loop, we are looking at a chunk of stack
1690    * that starts with an activation record.
1691    */
1692
1693   while (p < stack_end) {
1694     info  = get_ret_itbl((StgClosure *)p);
1695
1696     switch (info->i.type) {
1697
1698     case UPDATE_FRAME:
1699         // In SMP, we can get update frames that point to indirections
1700         // when two threads evaluate the same thunk.  We do attempt to
1701         // discover this situation in threadPaused(), but it's
1702         // possible that the following sequence occurs:
1703         //
1704         //        A             B
1705         //                  enter T
1706         //     enter T
1707         //     blackhole T
1708         //                  update T
1709         //     GC
1710         //
1711         // Now T is an indirection, and the update frame is already
1712         // marked on A's stack, so we won't traverse it again in
1713         // threadPaused().  We could traverse the whole stack again
1714         // before GC, but that seems like overkill.
1715         //
1716         // Scavenging this update frame as normal would be disastrous;
1717         // the updatee would end up pointing to the value.  So we turn
1718         // the indirection into an IND_PERM, so that evacuate will
1719         // copy the indirection into the old generation instead of
1720         // discarding it.
1721         //
1722         // Note [upd-black-hole]
1723         // One slight hiccup is that the THUNK_SELECTOR machinery can
1724         // overwrite the updatee with an IND.  In parallel GC, this
1725         // could even be happening concurrently, so we can't check for
1726         // the IND.  Fortunately if we assume that blackholing is
1727         // happening (either lazy or eager), then we can be sure that
1728         // the updatee is never a THUNK_SELECTOR and we're ok.
1729         // NB. this is a new invariant: blackholing is not optional.
1730     {
1731         nat type;
1732         const StgInfoTable *i;
1733         StgClosure *updatee;
1734
1735         updatee = ((StgUpdateFrame *)p)->updatee;
1736         i = updatee->header.info;
1737         if (!IS_FORWARDING_PTR(i)) {
1738             type = get_itbl(updatee)->type;
1739             if (type == IND) {
1740                 updatee->header.info = &stg_IND_PERM_info;
1741             } else if (type == IND_OLDGEN) {
1742                 updatee->header.info = &stg_IND_OLDGEN_PERM_info;
1743             }
1744         }
1745         evacuate(&((StgUpdateFrame *)p)->updatee);
1746         ASSERT(GET_CLOSURE_TAG(((StgUpdateFrame *)p)->updatee) == 0);
1747         p += sizeofW(StgUpdateFrame);
1748         continue;
1749     }
1750
1751       // small bitmap (< 32 entries, or 64 on a 64-bit machine)
1752     case CATCH_STM_FRAME:
1753     case CATCH_RETRY_FRAME:
1754     case ATOMICALLY_FRAME:
1755     case STOP_FRAME:
1756     case CATCH_FRAME:
1757     case RET_SMALL:
1758         bitmap = BITMAP_BITS(info->i.layout.bitmap);
1759         size   = BITMAP_SIZE(info->i.layout.bitmap);
1760         // NOTE: the payload starts immediately after the info-ptr, we
1761         // don't have an StgHeader in the same sense as a heap closure.
1762         p++;
1763         p = scavenge_small_bitmap(p, size, bitmap);
1764
1765     follow_srt:
1766         if (major_gc)
1767             scavenge_srt((StgClosure **)GET_SRT(info), info->i.srt_bitmap);
1768         continue;
1769
1770     case RET_BCO: {
1771         StgBCO *bco;
1772         nat size;
1773
1774         p++;
1775         evacuate((StgClosure **)p);
1776         bco = (StgBCO *)*p;
1777         p++;
1778         size = BCO_BITMAP_SIZE(bco);
1779         scavenge_large_bitmap(p, BCO_BITMAP(bco), size);
1780         p += size;
1781         continue;
1782     }
1783
1784       // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
1785     case RET_BIG:
1786     {
1787         nat size;
1788
1789         size = GET_LARGE_BITMAP(&info->i)->size;
1790         p++;
1791         scavenge_large_bitmap(p, GET_LARGE_BITMAP(&info->i), size);
1792         p += size;
1793         // and don't forget to follow the SRT
1794         goto follow_srt;
1795     }
1796
1797       // Dynamic bitmap: the mask is stored on the stack, and
1798       // there are a number of non-pointers followed by a number
1799       // of pointers above the bitmapped area.  (see StgMacros.h,
1800       // HEAP_CHK_GEN).
1801     case RET_DYN:
1802     {
1803         StgWord dyn;
1804         dyn = ((StgRetDyn *)p)->liveness;
1805
1806         // traverse the bitmap first
1807         bitmap = RET_DYN_LIVENESS(dyn);
1808         p      = (P_)&((StgRetDyn *)p)->payload[0];
1809         size   = RET_DYN_BITMAP_SIZE;
1810         p = scavenge_small_bitmap(p, size, bitmap);
1811
1812         // skip over the non-ptr words
1813         p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
1814
1815         // follow the ptr words
1816         for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
1817             evacuate((StgClosure **)p);
1818             p++;
1819         }
1820         continue;
1821     }
1822
1823     case RET_FUN:
1824     {
1825         StgRetFun *ret_fun = (StgRetFun *)p;
1826         StgFunInfoTable *fun_info;
1827
1828         evacuate(&ret_fun->fun);
1829         fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
1830         p = scavenge_arg_block(fun_info, ret_fun->payload);
1831         goto follow_srt;
1832     }
1833
1834     default:
1835         barf("scavenge_stack: weird activation record found on stack: %d", (int)(info->i.type));
1836     }
1837   }
1838 }
1839
1840 /*-----------------------------------------------------------------------------
1841   scavenge the large object list.
1842
1843   evac_gen set by caller; similar games played with evac_gen as with
1844   scavenge() - see comment at the top of scavenge().  Most large
1845   objects are (repeatedly) mutable, so most of the time evac_gen will
1846   be zero.
1847   --------------------------------------------------------------------------- */
1848
1849 static void
1850 scavenge_large (gen_workspace *ws)
1851 {
1852     bdescr *bd;
1853     StgPtr p;
1854
1855     gct->evac_gen = ws->gen;
1856
1857     bd = ws->todo_large_objects;
1858
1859     for (; bd != NULL; bd = ws->todo_large_objects) {
1860
1861         // take this object *off* the large objects list and put it on
1862         // the scavenged large objects list.  This is so that we can
1863         // treat new_large_objects as a stack and push new objects on
1864         // the front when evacuating.
1865         ws->todo_large_objects = bd->link;
1866
1867         ACQUIRE_SPIN_LOCK(&ws->gen->sync_large_objects);
1868         dbl_link_onto(bd, &ws->gen->scavenged_large_objects);
1869         ws->gen->n_scavenged_large_blocks += bd->blocks;
1870         RELEASE_SPIN_LOCK(&ws->gen->sync_large_objects);
1871
1872         p = bd->start;
1873         if (scavenge_one(p)) {
1874             if (ws->gen->no > 0) {
1875                 recordMutableGen_GC((StgClosure *)p, ws->gen->no);
1876             }
1877         }
1878
1879         // stats
1880         gct->scanned += closure_sizeW((StgClosure*)p);
1881     }
1882 }
1883
1884 /* ----------------------------------------------------------------------------
1885    Look for work to do.
1886
1887    We look for the oldest gen that has either a todo block that can
1888    be scanned, or a block of work on the global queue that we can
1889    scan.
1890
1891    It is important to take work from the *oldest* generation that we
1892    has work available, because that minimizes the likelihood of
1893    evacuating objects into a young generation when they should have
1894    been eagerly promoted.  This really does make a difference (the
1895    cacheprof benchmark is one that is affected).
1896
1897    We also want to scan the todo block if possible before grabbing
1898    work from the global queue, the reason being that we don't want to
1899    steal work from the global queue and starve other threads if there
1900    is other work we can usefully be doing.
1901    ------------------------------------------------------------------------- */
1902
1903 static rtsBool
1904 scavenge_find_work (void)
1905 {
1906     int g;
1907     gen_workspace *ws;
1908     rtsBool did_something, did_anything;
1909     bdescr *bd;
1910
1911     gct->scav_find_work++;
1912
1913     did_anything = rtsFalse;
1914
1915 loop:
1916     did_something = rtsFalse;
1917     for (g = RtsFlags.GcFlags.generations-1; g >= 0; g--) {
1918         ws = &gct->gens[g];
1919
1920         gct->scan_bd = NULL;
1921
1922         // If we have a scan block with some work to do,
1923         // scavenge everything up to the free pointer.
1924         if (ws->todo_bd->u.scan < ws->todo_free)
1925         {
1926             scavenge_block(ws->todo_bd);
1927             did_something = rtsTrue;
1928             break;
1929         }
1930
1931         // If we have any large objects to scavenge, do them now.
1932         if (ws->todo_large_objects) {
1933             scavenge_large(ws);
1934             did_something = rtsTrue;
1935             break;
1936         }
1937
1938         if ((bd = grab_local_todo_block(ws)) != NULL) {
1939             scavenge_block(bd);
1940             did_something = rtsTrue;
1941             break;
1942         }
1943     }
1944
1945     if (did_something) {
1946         did_anything = rtsTrue;
1947         goto loop;
1948     }
1949
1950 #if defined(THREADED_RTS)
1951     if (work_stealing) {
1952         // look for work to steal
1953         for (g = RtsFlags.GcFlags.generations-1; g >= 0; g--) {
1954             if ((bd = steal_todo_block(g)) != NULL) {
1955                 scavenge_block(bd);
1956                 did_something = rtsTrue;
1957                 break;
1958             }
1959         }
1960
1961         if (did_something) {
1962             did_anything = rtsTrue;
1963             goto loop;
1964         }
1965     }
1966 #endif
1967
1968     // only return when there is no more work to do
1969
1970     return did_anything;
1971 }
1972
1973 /* ----------------------------------------------------------------------------
1974    Scavenge until we can't find anything more to scavenge.
1975    ------------------------------------------------------------------------- */
1976
1977 void
1978 scavenge_loop(void)
1979 {
1980     rtsBool work_to_do;
1981
1982 loop:
1983     work_to_do = rtsFalse;
1984
1985     // scavenge static objects
1986     if (major_gc && gct->static_objects != END_OF_STATIC_LIST) {
1987         IF_DEBUG(sanity, checkStaticObjects(gct->static_objects));
1988         scavenge_static();
1989     }
1990
1991     // scavenge objects in compacted generation
1992     if (mark_stack_bd != NULL && !mark_stack_empty()) {
1993         scavenge_mark_stack();
1994         work_to_do = rtsTrue;
1995     }
1996
1997     // Order is important here: we want to deal in full blocks as
1998     // much as possible, so go for global work in preference to
1999     // local work.  Only if all the global work has been exhausted
2000     // do we start scavenging the fragments of blocks in the local
2001     // workspaces.
2002     if (scavenge_find_work()) goto loop;
2003
2004     if (work_to_do) goto loop;
2005 }
2006