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