rts/sm/Scav.c

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