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, j, b;
1538     StgWord bitmap;
1539
1540     b = 0;
1541
1542     for (i = 0; i < size; b++) {
1543         bitmap = large_bitmap->bitmap[b];
1544         j = stg_min(size-i, BITS_IN(W_));
1545         i += j;
1546         for (; j > 0; j--, p++) {
1547             if ((bitmap & 1) == 0) {
1548                 evacuate((StgClosure **)p);
1549             }
1550             bitmap = bitmap >> 1;
1551         }
1552     }
1553 }
1554
1555 STATIC_INLINE StgPtr
1556 scavenge_small_bitmap (StgPtr p, nat size, StgWord bitmap)
1557 {
1558     while (size > 0) {
1559         if ((bitmap & 1) == 0) {
1560             evacuate((StgClosure **)p);
1561         }
1562         p++;
1563         bitmap = bitmap >> 1;
1564         size--;
1565     }
1566     return p;
1567 }
1568
1569 /* -----------------------------------------------------------------------------
1570    scavenge_stack walks over a section of stack and evacuates all the
1571    objects pointed to by it.  We can use the same code for walking
1572    AP_STACK_UPDs, since these are just sections of copied stack.
1573    -------------------------------------------------------------------------- */
1574
1575 static void
1576 scavenge_stack(StgPtr p, StgPtr stack_end)
1577 {
1578   const StgRetInfoTable* info;
1579   StgWord bitmap;
1580   nat size;
1581
1582   /*
1583    * Each time around this loop, we are looking at a chunk of stack
1584    * that starts with an activation record.
1585    */
1586
1587   while (p < stack_end) {
1588     info  = get_ret_itbl((StgClosure *)p);
1589
1590     switch (info->i.type) {
1591
1592     case UPDATE_FRAME:
1593         // In SMP, we can get update frames that point to indirections
1594         // when two threads evaluate the same thunk.  We do attempt to
1595         // discover this situation in threadPaused(), but it's
1596         // possible that the following sequence occurs:
1597         //
1598         //        A             B
1599         //                  enter T
1600         //     enter T
1601         //     blackhole T
1602         //                  update T
1603         //     GC
1604         //
1605         // Now T is an indirection, and the update frame is already
1606         // marked on A's stack, so we won't traverse it again in
1607         // threadPaused().  We could traverse the whole stack again
1608         // before GC, but that seems like overkill.
1609         //
1610         // Scavenging this update frame as normal would be disastrous;
1611         // the updatee would end up pointing to the value.  So we
1612         // check whether the value after evacuation is a BLACKHOLE,
1613         // and if not, we change the update frame to an stg_enter
1614         // frame that simply returns the value.  Hence, blackholing is
1615         // compulsory (otherwise we would have to check for thunks
1616         // too).
1617         //
1618         // Note [upd-black-hole]
1619         // One slight hiccup is that the THUNK_SELECTOR machinery can
1620         // overwrite the updatee with an IND.  In parallel GC, this
1621         // could even be happening concurrently, so we can't check for
1622         // the IND.  Fortunately if we assume that blackholing is
1623         // happening (either lazy or eager), then we can be sure that
1624         // the updatee is never a THUNK_SELECTOR and we're ok.
1625         // NB. this is a new invariant: blackholing is not optional.
1626     {
1627         StgUpdateFrame *frame = (StgUpdateFrame *)p;
1628         StgClosure *v;
1629
1630         evacuate(&frame->updatee);
1631         v = frame->updatee;
1632         if (GET_CLOSURE_TAG(v) != 0 ||
1633             (get_itbl(v)->type != BLACKHOLE)) {
1634             // blackholing is compulsory, see above.
1635             frame->header.info = (const StgInfoTable*)&stg_enter_checkbh_info;
1636         }
1637         ASSERT(v->header.info != &stg_TSO_info);
1638         p += sizeofW(StgUpdateFrame);
1639         continue;
1640     }
1641
1642       // small bitmap (< 32 entries, or 64 on a 64-bit machine)
1643     case CATCH_STM_FRAME:
1644     case CATCH_RETRY_FRAME:
1645     case ATOMICALLY_FRAME:
1646     case STOP_FRAME:
1647     case CATCH_FRAME:
1648     case RET_SMALL:
1649         bitmap = BITMAP_BITS(info->i.layout.bitmap);
1650         size   = BITMAP_SIZE(info->i.layout.bitmap);
1651         // NOTE: the payload starts immediately after the info-ptr, we
1652         // don't have an StgHeader in the same sense as a heap closure.
1653         p++;
1654         p = scavenge_small_bitmap(p, size, bitmap);
1655
1656     follow_srt:
1657         if (major_gc)
1658             scavenge_srt((StgClosure **)GET_SRT(info), info->i.srt_bitmap);
1659         continue;
1660
1661     case RET_BCO: {
1662         StgBCO *bco;
1663         nat size;
1664
1665         p++;
1666         evacuate((StgClosure **)p);
1667         bco = (StgBCO *)*p;
1668         p++;
1669         size = BCO_BITMAP_SIZE(bco);
1670         scavenge_large_bitmap(p, BCO_BITMAP(bco), size);
1671         p += size;
1672         continue;
1673     }
1674
1675       // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
1676     case RET_BIG:
1677     {
1678         nat size;
1679
1680         size = GET_LARGE_BITMAP(&info->i)->size;
1681         p++;
1682         scavenge_large_bitmap(p, GET_LARGE_BITMAP(&info->i), size);
1683         p += size;
1684         // and don't forget to follow the SRT
1685         goto follow_srt;
1686     }
1687
1688       // Dynamic bitmap: the mask is stored on the stack, and
1689       // there are a number of non-pointers followed by a number
1690       // of pointers above the bitmapped area.  (see StgMacros.h,
1691       // HEAP_CHK_GEN).
1692     case RET_DYN:
1693     {
1694         StgWord dyn;
1695         dyn = ((StgRetDyn *)p)->liveness;
1696
1697         // traverse the bitmap first
1698         bitmap = RET_DYN_LIVENESS(dyn);
1699         p      = (P_)&((StgRetDyn *)p)->payload[0];
1700         size   = RET_DYN_BITMAP_SIZE;
1701         p = scavenge_small_bitmap(p, size, bitmap);
1702
1703         // skip over the non-ptr words
1704         p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
1705
1706         // follow the ptr words
1707         for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
1708             evacuate((StgClosure **)p);
1709             p++;
1710         }
1711         continue;
1712     }
1713
1714     case RET_FUN:
1715     {
1716         StgRetFun *ret_fun = (StgRetFun *)p;
1717         StgFunInfoTable *fun_info;
1718
1719         evacuate(&ret_fun->fun);
1720         fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
1721         p = scavenge_arg_block(fun_info, ret_fun->payload);
1722         goto follow_srt;
1723     }
1724
1725     default:
1726         barf("scavenge_stack: weird activation record found on stack: %d", (int)(info->i.type));
1727     }
1728   }
1729 }
1730
1731 /*-----------------------------------------------------------------------------
1732   scavenge the large object list.
1733
1734   evac_gen set by caller; similar games played with evac_gen as with
1735   scavenge() - see comment at the top of scavenge().  Most large
1736   objects are (repeatedly) mutable, so most of the time evac_gen will
1737   be zero.
1738   --------------------------------------------------------------------------- */
1739
1740 static void
1741 scavenge_large (gen_workspace *ws)
1742 {
1743     bdescr *bd;
1744     StgPtr p;
1745
1746     gct->evac_gen = ws->gen;
1747
1748     bd = ws->todo_large_objects;
1749
1750     for (; bd != NULL; bd = ws->todo_large_objects) {
1751
1752         // take this object *off* the large objects list and put it on
1753         // the scavenged large objects list.  This is so that we can
1754         // treat new_large_objects as a stack and push new objects on
1755         // the front when evacuating.
1756         ws->todo_large_objects = bd->link;
1757
1758         ACQUIRE_SPIN_LOCK(&ws->gen->sync_large_objects);
1759         dbl_link_onto(bd, &ws->gen->scavenged_large_objects);
1760         ws->gen->n_scavenged_large_blocks += bd->blocks;
1761         RELEASE_SPIN_LOCK(&ws->gen->sync_large_objects);
1762
1763         p = bd->start;
1764         if (scavenge_one(p)) {
1765             if (ws->gen->no > 0) {
1766                 recordMutableGen_GC((StgClosure *)p, ws->gen->no);
1767             }
1768         }
1769
1770         // stats
1771         gct->scanned += closure_sizeW((StgClosure*)p);
1772     }
1773 }
1774
1775 /* ----------------------------------------------------------------------------
1776    Look for work to do.
1777
1778    We look for the oldest gen that has either a todo block that can
1779    be scanned, or a block of work on the global queue that we can
1780    scan.
1781
1782    It is important to take work from the *oldest* generation that we
1783    has work available, because that minimizes the likelihood of
1784    evacuating objects into a young generation when they should have
1785    been eagerly promoted.  This really does make a difference (the
1786    cacheprof benchmark is one that is affected).
1787
1788    We also want to scan the todo block if possible before grabbing
1789    work from the global queue, the reason being that we don't want to
1790    steal work from the global queue and starve other threads if there
1791    is other work we can usefully be doing.
1792    ------------------------------------------------------------------------- */
1793
1794 static rtsBool
1795 scavenge_find_work (void)
1796 {
1797     int g;
1798     gen_workspace *ws;
1799     rtsBool did_something, did_anything;
1800     bdescr *bd;
1801
1802     gct->scav_find_work++;
1803
1804     did_anything = rtsFalse;
1805
1806 loop:
1807     did_something = rtsFalse;
1808     for (g = RtsFlags.GcFlags.generations-1; g >= 0; g--) {
1809         ws = &gct->gens[g];
1810
1811         gct->scan_bd = NULL;
1812
1813         // If we have a scan block with some work to do,
1814         // scavenge everything up to the free pointer.
1815         if (ws->todo_bd->u.scan < ws->todo_free)
1816         {
1817             scavenge_block(ws->todo_bd);
1818             did_something = rtsTrue;
1819             break;
1820         }
1821
1822         // If we have any large objects to scavenge, do them now.
1823         if (ws->todo_large_objects) {
1824             scavenge_large(ws);
1825             did_something = rtsTrue;
1826             break;
1827         }
1828
1829         if ((bd = grab_local_todo_block(ws)) != NULL) {
1830             scavenge_block(bd);
1831             did_something = rtsTrue;
1832             break;
1833         }
1834     }
1835
1836     if (did_something) {
1837         did_anything = rtsTrue;
1838         goto loop;
1839     }
1840
1841 #if defined(THREADED_RTS)
1842     if (work_stealing) {
1843         // look for work to steal
1844         for (g = RtsFlags.GcFlags.generations-1; g >= 0; g--) {
1845             if ((bd = steal_todo_block(g)) != NULL) {
1846                 scavenge_block(bd);
1847                 did_something = rtsTrue;
1848                 break;
1849             }
1850         }
1851
1852         if (did_something) {
1853             did_anything = rtsTrue;
1854             goto loop;
1855         }
1856     }
1857 #endif
1858
1859     // only return when there is no more work to do
1860
1861     return did_anything;
1862 }
1863
1864 /* ----------------------------------------------------------------------------
1865    Scavenge until we can't find anything more to scavenge.
1866    ------------------------------------------------------------------------- */
1867
1868 void
1869 scavenge_loop(void)
1870 {
1871     rtsBool work_to_do;
1872
1873 loop:
1874     work_to_do = rtsFalse;
1875
1876     // scavenge static objects
1877     if (major_gc && gct->static_objects != END_OF_STATIC_LIST) {
1878         IF_DEBUG(sanity, checkStaticObjects(gct->static_objects));
1879         scavenge_static();
1880     }
1881
1882     // scavenge objects in compacted generation
1883     if (mark_stack_bd != NULL && !mark_stack_empty()) {
1884         scavenge_mark_stack();
1885         work_to_do = rtsTrue;
1886     }
1887
1888     // Order is important here: we want to deal in full blocks as
1889     // much as possible, so go for global work in preference to
1890     // local work.  Only if all the global work has been exhausted
1891     // do we start scavenging the fragments of blocks in the local
1892     // workspaces.
1893     if (scavenge_find_work()) goto loop;
1894
1895     if (work_to_do) goto loop;
1896 }
1897