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