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     ACQUIRE_SPIN_LOCK(&static_objects_sync);
1082
1083     /* get the next static object from the list.  Remember, there might
1084      * be more stuff on this list after each evacuation...
1085      * (static_objects is a global)
1086      */
1087     p = static_objects;
1088     if (p == END_OF_STATIC_LIST) {
1089           RELEASE_SPIN_LOCK(&static_objects_sync);
1090           break;
1091     }
1092
1093     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
1094     info = get_itbl(p);
1095     /*
1096         if (info->type==RBH)
1097         info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
1098     */
1099     // make sure the info pointer is into text space
1100
1101     /* Take this object *off* the static_objects list,
1102      * and put it on the scavenged_static_objects list.
1103      */
1104     static_objects = *STATIC_LINK(info,p);
1105     *STATIC_LINK(info,p) = scavenged_static_objects;
1106     scavenged_static_objects = p;
1107
1108     RELEASE_SPIN_LOCK(&static_objects_sync);
1109
1110     switch (info -> type) {
1111
1112     case IND_STATIC:
1113       {
1114         StgInd *ind = (StgInd *)p;
1115         evacuate(&ind->indirectee);
1116
1117         /* might fail to evacuate it, in which case we have to pop it
1118          * back on the mutable list of the oldest generation.  We
1119          * leave it *on* the scavenged_static_objects list, though,
1120          * in case we visit this object again.
1121          */
1122         if (gct->failed_to_evac) {
1123           gct->failed_to_evac = rtsFalse;
1124           recordMutableGen_GC((StgClosure *)p,oldest_gen);
1125         }
1126         break;
1127       }
1128
1129     case THUNK_STATIC:
1130       scavenge_thunk_srt(info);
1131       break;
1132
1133     case FUN_STATIC:
1134       scavenge_fun_srt(info);
1135       break;
1136
1137     case CONSTR_STATIC:
1138       {
1139         StgPtr q, next;
1140
1141         next = (P_)p->payload + info->layout.payload.ptrs;
1142         // evacuate the pointers
1143         for (q = (P_)p->payload; q < next; q++) {
1144             evacuate((StgClosure **)q);
1145         }
1146         break;
1147       }
1148
1149     default:
1150       barf("scavenge_static: strange closure %d", (int)(info->type));
1151     }
1152
1153     ASSERT(gct->failed_to_evac == rtsFalse);
1154   }
1155 }
1156
1157 /* -----------------------------------------------------------------------------
1158    scavenge a chunk of memory described by a bitmap
1159    -------------------------------------------------------------------------- */
1160
1161 static void
1162 scavenge_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, nat size )
1163 {
1164     nat i, b;
1165     StgWord bitmap;
1166
1167     b = 0;
1168     bitmap = large_bitmap->bitmap[b];
1169     for (i = 0; i < size; ) {
1170         if ((bitmap & 1) == 0) {
1171             evacuate((StgClosure **)p);
1172         }
1173         i++;
1174         p++;
1175         if (i % BITS_IN(W_) == 0) {
1176             b++;
1177             bitmap = large_bitmap->bitmap[b];
1178         } else {
1179             bitmap = bitmap >> 1;
1180         }
1181     }
1182 }
1183
1184 STATIC_INLINE StgPtr
1185 scavenge_small_bitmap (StgPtr p, nat size, StgWord bitmap)
1186 {
1187     while (size > 0) {
1188         if ((bitmap & 1) == 0) {
1189             evacuate((StgClosure **)p);
1190         }
1191         p++;
1192         bitmap = bitmap >> 1;
1193         size--;
1194     }
1195     return p;
1196 }
1197
1198 /* -----------------------------------------------------------------------------
1199    scavenge_stack walks over a section of stack and evacuates all the
1200    objects pointed to by it.  We can use the same code for walking
1201    AP_STACK_UPDs, since these are just sections of copied stack.
1202    -------------------------------------------------------------------------- */
1203
1204 static void
1205 scavenge_stack(StgPtr p, StgPtr stack_end)
1206 {
1207   const StgRetInfoTable* info;
1208   StgWord bitmap;
1209   nat size;
1210
1211   /*
1212    * Each time around this loop, we are looking at a chunk of stack
1213    * that starts with an activation record.
1214    */
1215
1216   while (p < stack_end) {
1217     info  = get_ret_itbl((StgClosure *)p);
1218
1219     switch (info->i.type) {
1220
1221     case UPDATE_FRAME:
1222         // In SMP, we can get update frames that point to indirections
1223         // when two threads evaluate the same thunk.  We do attempt to
1224         // discover this situation in threadPaused(), but it's
1225         // possible that the following sequence occurs:
1226         //
1227         //        A             B
1228         //                  enter T
1229         //     enter T
1230         //     blackhole T
1231         //                  update T
1232         //     GC
1233         //
1234         // Now T is an indirection, and the update frame is already
1235         // marked on A's stack, so we won't traverse it again in
1236         // threadPaused().  We could traverse the whole stack again
1237         // before GC, but that seems like overkill.
1238         //
1239         // Scavenging this update frame as normal would be disastrous;
1240         // the updatee would end up pointing to the value.  So we turn
1241         // the indirection into an IND_PERM, so that evacuate will
1242         // copy the indirection into the old generation instead of
1243         // discarding it.
1244     {
1245         nat type;
1246         type = get_itbl(((StgUpdateFrame *)p)->updatee)->type;
1247         if (type == IND) {
1248             ((StgUpdateFrame *)p)->updatee->header.info =
1249                 (StgInfoTable *)&stg_IND_PERM_info;
1250         } else if (type == IND_OLDGEN) {
1251             ((StgUpdateFrame *)p)->updatee->header.info =
1252                 (StgInfoTable *)&stg_IND_OLDGEN_PERM_info;
1253         }
1254         evacuate(&((StgUpdateFrame *)p)->updatee);
1255         p += sizeofW(StgUpdateFrame);
1256         continue;
1257     }
1258
1259       // small bitmap (< 32 entries, or 64 on a 64-bit machine)
1260     case CATCH_STM_FRAME:
1261     case CATCH_RETRY_FRAME:
1262     case ATOMICALLY_FRAME:
1263     case STOP_FRAME:
1264     case CATCH_FRAME:
1265     case RET_SMALL:
1266         bitmap = BITMAP_BITS(info->i.layout.bitmap);
1267         size   = BITMAP_SIZE(info->i.layout.bitmap);
1268         // NOTE: the payload starts immediately after the info-ptr, we
1269         // don't have an StgHeader in the same sense as a heap closure.
1270         p++;
1271         p = scavenge_small_bitmap(p, size, bitmap);
1272
1273     follow_srt:
1274         if (major_gc)
1275             scavenge_srt((StgClosure **)GET_SRT(info), info->i.srt_bitmap);
1276         continue;
1277
1278     case RET_BCO: {
1279         StgBCO *bco;
1280         nat size;
1281
1282         p++;
1283         evacuate((StgClosure **)p);
1284         bco = (StgBCO *)*p;
1285         p++;
1286         size = BCO_BITMAP_SIZE(bco);
1287         scavenge_large_bitmap(p, BCO_BITMAP(bco), size);
1288         p += size;
1289         continue;
1290     }
1291
1292       // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
1293     case RET_BIG:
1294     {
1295         nat size;
1296
1297         size = GET_LARGE_BITMAP(&info->i)->size;
1298         p++;
1299         scavenge_large_bitmap(p, GET_LARGE_BITMAP(&info->i), size);
1300         p += size;
1301         // and don't forget to follow the SRT
1302         goto follow_srt;
1303     }
1304
1305       // Dynamic bitmap: the mask is stored on the stack, and
1306       // there are a number of non-pointers followed by a number
1307       // of pointers above the bitmapped area.  (see StgMacros.h,
1308       // HEAP_CHK_GEN).
1309     case RET_DYN:
1310     {
1311         StgWord dyn;
1312         dyn = ((StgRetDyn *)p)->liveness;
1313
1314         // traverse the bitmap first
1315         bitmap = RET_DYN_LIVENESS(dyn);
1316         p      = (P_)&((StgRetDyn *)p)->payload[0];
1317         size   = RET_DYN_BITMAP_SIZE;
1318         p = scavenge_small_bitmap(p, size, bitmap);
1319
1320         // skip over the non-ptr words
1321         p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
1322
1323         // follow the ptr words
1324         for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
1325             evacuate((StgClosure **)p);
1326             p++;
1327         }
1328         continue;
1329     }
1330
1331     case RET_FUN:
1332     {
1333         StgRetFun *ret_fun = (StgRetFun *)p;
1334         StgFunInfoTable *fun_info;
1335
1336         evacuate(&ret_fun->fun);
1337         fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
1338         p = scavenge_arg_block(fun_info, ret_fun->payload);
1339         goto follow_srt;
1340     }
1341
1342     default:
1343         barf("scavenge_stack: weird activation record found on stack: %d", (int)(info->i.type));
1344     }
1345   }
1346 }
1347
1348 /*-----------------------------------------------------------------------------
1349   scavenge the large object list.
1350
1351   evac_step set by caller; similar games played with evac_step as with
1352   scavenge() - see comment at the top of scavenge().  Most large
1353   objects are (repeatedly) mutable, so most of the time evac_step will
1354   be zero.
1355   --------------------------------------------------------------------------- */
1356
1357 static void
1358 scavenge_large (step_workspace *ws)
1359 {
1360     bdescr *bd;
1361     StgPtr p;
1362
1363     gct->evac_step = ws->stp;
1364
1365     bd = ws->todo_large_objects;
1366
1367     for (; bd != NULL; bd = ws->todo_large_objects) {
1368
1369         // take this object *off* the large objects list and put it on
1370         // the scavenged large objects list.  This is so that we can
1371         // treat new_large_objects as a stack and push new objects on
1372         // the front when evacuating.
1373         ws->todo_large_objects = bd->link;
1374
1375         ACQUIRE_SPIN_LOCK(&ws->stp->sync_large_objects);
1376         dbl_link_onto(bd, &ws->stp->scavenged_large_objects);
1377         ws->stp->n_scavenged_large_blocks += bd->blocks;
1378         RELEASE_SPIN_LOCK(&ws->stp->sync_large_objects);
1379
1380         p = bd->start;
1381         if (scavenge_one(p)) {
1382             if (ws->stp->gen_no > 0) {
1383                 recordMutableGen_GC((StgClosure *)p, ws->stp->gen);
1384             }
1385         }
1386     }
1387 }
1388
1389 /* ----------------------------------------------------------------------------
1390    Scavenge a block
1391    ------------------------------------------------------------------------- */
1392
1393 #define MINOR_GC
1394 #include "Scav.c-inc"
1395 #undef MINOR_GC
1396 #include "Scav.c-inc"
1397
1398 /* ----------------------------------------------------------------------------
1399    Find the oldest full block to scavenge, and scavenge it.
1400    ------------------------------------------------------------------------- */
1401
1402 static rtsBool
1403 scavenge_find_global_work (void)
1404 {
1405     bdescr *bd;
1406     int s;
1407     rtsBool flag;
1408     step_workspace *ws;
1409
1410     gct->scav_global_work++;
1411
1412     flag = rtsFalse;
1413     for (s = total_steps-1; s>=0; s--)
1414     {
1415         if (s == 0 && RtsFlags.GcFlags.generations > 1) {
1416             continue;
1417         }
1418         ws = &gct->steps[s];
1419
1420         // If we have any large objects to scavenge, do them now.
1421         if (ws->todo_large_objects) {
1422             scavenge_large(ws);
1423             flag = rtsTrue;
1424         }
1425
1426         if ((bd = grab_todo_block(ws)) != NULL) {
1427             // no need to assign this to ws->scan_bd, we're going
1428             // to scavenge the whole thing and then push it on
1429             // our scavd list.  This saves pushing out the
1430             // scan_bd block, which might be partial.
1431             if (N == 0) {
1432                 scavenge_block0(bd, bd->start);
1433             } else {
1434                 scavenge_block(bd, bd->start);
1435             }
1436             push_scan_block(bd, ws);
1437             return rtsTrue;
1438         }
1439
1440         if (flag) return rtsTrue;
1441     }
1442     return rtsFalse;
1443 }
1444
1445 /* ----------------------------------------------------------------------------
1446    Look for local work to do.
1447
1448    We can have outstanding scavenging to do if, for any of the workspaces,
1449
1450      - the scan block is the same as the todo block, and new objects
1451        have been evacuated to the todo block.
1452
1453      - the scan block *was* the same as the todo block, but the todo
1454        block filled up and a new one has been allocated.
1455    ------------------------------------------------------------------------- */
1456
1457 static rtsBool
1458 scavenge_find_local_work (void)
1459 {
1460     int s;
1461     step_workspace *ws;
1462     rtsBool flag;
1463
1464     gct->scav_local_work++;
1465
1466     flag = rtsFalse;
1467     for (s = total_steps-1; s >= 0; s--) {
1468         if (s == 0 && RtsFlags.GcFlags.generations > 1) {
1469             continue;
1470         }
1471         ws = &gct->steps[s];
1472
1473         if (ws->todo_bd != NULL)
1474         {
1475             ws->todo_bd->free = ws->todo_free;
1476         }
1477
1478         // If we have a todo block and no scan block, start
1479         // scanning the todo block.
1480         if (ws->scan_bd == NULL && ws->todo_bd != NULL)
1481         {
1482             ws->scan_bd = ws->todo_bd;
1483             ws->scan = ws->scan_bd->start;
1484         }
1485
1486         // If we have a scan block with some work to do,
1487         // scavenge everything up to the free pointer.
1488         if (ws->scan != NULL && ws->scan < ws->scan_bd->free)
1489         {
1490             if (N == 0) {
1491                 scavenge_block0(ws->scan_bd, ws->scan);
1492             } else {
1493                 scavenge_block(ws->scan_bd, ws->scan);
1494             }
1495             ws->scan = ws->scan_bd->free;
1496             flag = rtsTrue;
1497         }
1498
1499         if (ws->scan_bd != NULL && ws->scan == ws->scan_bd->free
1500             && ws->scan_bd != ws->todo_bd)
1501         {
1502             // we're not going to evac any more objects into
1503             // this block, so push it now.
1504             push_scan_block(ws->scan_bd, ws);
1505             ws->scan_bd = NULL;
1506             ws->scan = NULL;
1507             // we might be able to scan the todo block now.  But
1508             // don't do it right away: there might be full blocks
1509             // waiting to be scanned as a result of scavenge_block above.
1510             flag = rtsTrue;
1511         }
1512
1513         if (flag) return rtsTrue;
1514     }
1515     return rtsFalse;
1516 }
1517
1518 /* ----------------------------------------------------------------------------
1519    Scavenge until we can't find anything more to scavenge.
1520    ------------------------------------------------------------------------- */
1521
1522 void
1523 scavenge_loop(void)
1524 {
1525     rtsBool work_to_do;
1526
1527 loop:
1528     work_to_do = rtsFalse;
1529
1530     // scavenge static objects
1531     if (major_gc && static_objects != END_OF_STATIC_LIST) {
1532         IF_DEBUG(sanity, checkStaticObjects(static_objects));
1533         scavenge_static();
1534     }
1535
1536     // scavenge objects in compacted generation
1537     if (mark_stack_overflowed || oldgen_scan_bd != NULL ||
1538         (mark_stack_bdescr != NULL && !mark_stack_empty())) {
1539         scavenge_mark_stack();
1540         work_to_do = rtsTrue;
1541     }
1542
1543     // Order is important here: we want to deal in full blocks as
1544     // much as possible, so go for global work in preference to
1545     // local work.  Only if all the global work has been exhausted
1546     // do we start scavenging the fragments of blocks in the local
1547     // workspaces.
1548     if (scavenge_find_global_work()) goto loop;
1549     if (scavenge_find_local_work())  goto loop;
1550
1551     if (work_to_do) goto loop;
1552 }
1553
1554 rtsBool
1555 any_work (void)
1556 {
1557     int s;
1558     step_workspace *ws;
1559
1560     gct->any_work++;
1561
1562     write_barrier();
1563
1564     // scavenge static objects
1565     if (major_gc && static_objects != END_OF_STATIC_LIST) {
1566         return rtsTrue;
1567     }
1568
1569     // scavenge objects in compacted generation
1570     if (mark_stack_overflowed || oldgen_scan_bd != NULL ||
1571         (mark_stack_bdescr != NULL && !mark_stack_empty())) {
1572         return rtsTrue;
1573     }
1574
1575     // Check for global work in any step.  We don't need to check for
1576     // local work, because we have already exited scavenge_loop(),
1577     // which means there is no local work for this thread.
1578     for (s = total_steps-1; s >= 0; s--) {
1579         if (s == 0 && RtsFlags.GcFlags.generations > 1) {
1580             continue;
1581         }
1582         ws = &gct->steps[s];
1583         if (ws->todo_large_objects) return rtsTrue;
1584         if (ws->stp->todos) return rtsTrue;
1585     }
1586
1587     gct->no_work++;
1588     usleep(1);
1589
1590     return rtsFalse;
1591 }