rts/sm/Scav.c

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