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