rts/sm/Evac.c

   1 /* -----------------------------------------------------------------------------
   2  *
   3  * (c) The GHC Team 1998-2006
   4  *
   5  * Generational garbage collector: evacuation functions
   6  *
   7  * Documentation on the architecture of the Garbage Collector can be
   8  * found in the online commentary:
   9  *
  10  *   http://hackage.haskell.org/trac/ghc/wiki/Commentary/Rts/Storage/GC
  11  *
  12  * ---------------------------------------------------------------------------*/
  13
  14 #include "Rts.h"
  15 #include "Storage.h"
  16 #include "MBlock.h"
  17 #include "Evac.h"
  18 #include "GC.h"
  19 #include "GCUtils.h"
  20 #include "Compact.h"
  21 #include "Prelude.h"
  22 #include "LdvProfile.h"
  23
  24 /* Used to avoid long recursion due to selector thunks
  25  */
  26 #define MAX_THUNK_SELECTOR_DEPTH 16
  27
  28 static void eval_thunk_selector (StgClosure **q, StgSelector * p, rtsBool);
  29
  30 STATIC_INLINE StgPtr
  31 alloc_for_copy (nat size, step *stp)
  32 {
  33     StgPtr to;
  34     step_workspace *ws;
  35     bdescr *bd;
  36
  37     /* Find out where we're going, using the handy "to" pointer in
  38      * the step of the source object.  If it turns out we need to
  39      * evacuate to an older generation, adjust it here (see comment
  40      * by evacuate()).
  41      */
  42     if (stp < gct->evac_step) {
  43         if (gct->eager_promotion) {
  44             stp = gct->evac_step;
  45         } else {
  46             gct->failed_to_evac = rtsTrue;
  47         }
  48     }
  49
  50     ws = &gct->steps[stp->gen_no][stp->no];
  51
  52     /* chain a new block onto the to-space for the destination step if
  53      * necessary.
  54      */
  55     bd = ws->todo_bd;
  56     to = bd->free;
  57     if (to + size >= bd->start + BLOCK_SIZE_W) {
  58         bd = gc_alloc_todo_block(ws);
  59         to = bd->free;
  60     }
  61     bd->free = to + size;
  62
  63     return to;
  64 }
  65
  66 STATIC_INLINE StgPtr
  67 alloc_for_copy_noscav (nat size, step *stp)
  68 {
  69     StgPtr to;
  70     step_workspace *ws;
  71     bdescr *bd;
  72
  73     /* Find out where we're going, using the handy "to" pointer in
  74      * the step of the source object.  If it turns out we need to
  75      * evacuate to an older generation, adjust it here (see comment
  76      * by evacuate()).
  77      */
  78     if (stp < gct->evac_step) {
  79         if (gct->eager_promotion) {
  80             stp = gct->evac_step;
  81         } else {
  82             gct->failed_to_evac = rtsTrue;
  83         }
  84     }
  85
  86     ws = &gct->steps[stp->gen_no][stp->no];
  87
  88     /* chain a new block onto the to-space for the destination step if
  89      * necessary.
  90      */
  91     bd = ws->scavd_list;
  92     to = bd->free;
  93     if (to + size >= bd->start + BLOCK_SIZE_W) {
  94         bd = gc_alloc_scavd_block(ws);
  95         to = bd->free;
  96     }
  97     bd->free = to + size;
  98
  99     return to;
 100 }
 101
 102 STATIC_INLINE void
 103 copy_tag(StgClosure **p, StgClosure *src, nat size, step *stp,StgWord tag)
 104 {
 105     StgPtr to, tagged_to, from;
 106     nat i;
 107     StgWord info;
 108
 109 #ifdef THREADED_RTS
 110     do {
 111         info = xchg((StgPtr)&src->header.info, (W_)&stg_WHITEHOLE_info);
 112         // so..  what is it?
 113     } while (info == (W_)&stg_WHITEHOLE_info);
 114     if (info == (W_)&stg_EVACUATED_info) {
 115         src->header.info = (const StgInfoTable *)info;
 116         return evacuate(p); // does the failed_to_evac stuff
 117     }
 118 #else
 119     info = (W_)src->header.info;
 120     src->header.info = &stg_EVACUATED_info;
 121 #endif
 122
 123     to = alloc_for_copy(size,stp);
 124     tagged_to = (StgPtr)TAG_CLOSURE(tag,(StgClosure*)to);
 125     *p = (StgClosure *)tagged_to;
 126
 127     TICK_GC_WORDS_COPIED(size);
 128
 129     from = (StgPtr)src;
 130     to[0] = info;
 131     for (i = 1; i < size; i++) { // unroll for small i
 132         to[i] = from[i];
 133     }
 134
 135     ((StgEvacuated*)from)->evacuee = (StgClosure *)tagged_to;
 136
 137     // retag pointer before updating EVACUATE closure and returning
 138
 139 //  if (to+size+2 < bd->start + BLOCK_SIZE_W) {
 140 //      __builtin_prefetch(to + size + 2, 1);
 141 //  }
 142
 143 #ifdef THREADED_RTS
 144     write_barrier();
 145     ((StgEvacuated*)from)->header.info = &stg_EVACUATED_info;
 146 #endif
 147
 148 #ifdef PROFILING
 149     // We store the size of the just evacuated object in the LDV word so that
 150     // the profiler can guess the position of the next object later.
 151     SET_EVACUAEE_FOR_LDV(from, size);
 152 #endif
 153 }
 154
 155
 156 // Same as copy() above, except the object will be allocated in memory
 157 // that will not be scavenged.  Used for object that have no pointer
 158 // fields.
 159 STATIC_INLINE void
 160 copy_noscav_tag(StgClosure **p, StgClosure *src, nat size, step *stp, StgWord tag)
 161 {
 162     StgPtr to, tagged_to, from;
 163     nat i;
 164     StgWord info;
 165
 166 #ifdef THREADED_RTS
 167     do {
 168         info = xchg((StgPtr)&src->header.info, (W_)&stg_WHITEHOLE_info);
 169     } while (info == (W_)&stg_WHITEHOLE_info);
 170     if (info == (W_)&stg_EVACUATED_info) {
 171         src->header.info = (const StgInfoTable *)info;
 172         return evacuate(p); // does the failed_to_evac stuff
 173     }
 174 #else
 175     info = (W_)src->header.info;
 176     src->header.info = &stg_EVACUATED_info;
 177 #endif
 178
 179     to = alloc_for_copy_noscav(size,stp);
 180     tagged_to = (StgPtr)TAG_CLOSURE(tag,(StgClosure*)to);
 181     *p = (StgClosure *)tagged_to;
 182
 183     TICK_GC_WORDS_COPIED(size);
 184
 185     from = (StgPtr)src;
 186     to[0] = info;
 187     for (i = 1; i < size; i++) { // unroll for small i
 188         to[i] = from[i];
 189     }
 190
 191     ((StgEvacuated*)from)->evacuee = (StgClosure *)tagged_to;
 192
 193 #ifdef THREADED_RTS
 194     write_barrier();
 195     ((StgEvacuated*)from)->header.info = &stg_EVACUATED_info;
 196 #endif
 197
 198 #ifdef PROFILING
 199     // We store the size of the just evacuated object in the LDV word so that
 200     // the profiler can guess the position of the next object later.
 201     SET_EVACUAEE_FOR_LDV(from, size);
 202 #endif
 203 }
 204
 205
 206 /* Special version of copy() for when we only want to copy the info
 207  * pointer of an object, but reserve some padding after it.  This is
 208  * used to optimise evacuation of BLACKHOLEs.
 209  */
 210 static void
 211 copyPart(StgClosure **p, StgClosure *src, nat size_to_reserve, nat size_to_copy, step *stp)
 212 {
 213     StgPtr to, from;
 214     nat i;
 215     StgWord info;
 216
 217 #ifdef THREADED_RTS
 218     do {
 219         info = xchg((StgPtr)&src->header.info, (W_)&stg_WHITEHOLE_info);
 220     } while (info == (W_)&stg_WHITEHOLE_info);
 221     if (info == (W_)&stg_EVACUATED_info) {
 222         src->header.info = (const StgInfoTable *)info;
 223         return evacuate(p); // does the failed_to_evac stuff
 224     }
 225 #else
 226     info = (W_)src->header.info;
 227     src->header.info = &stg_EVACUATED_info;
 228 #endif
 229
 230     to = alloc_for_copy(size_to_reserve, stp);
 231     *p = (StgClosure *)to;
 232
 233     TICK_GC_WORDS_COPIED(size_to_copy);
 234
 235     from = (StgPtr)src;
 236     to[0] = info;
 237     for (i = 1; i < size_to_copy; i++) { // unroll for small i
 238         to[i] = from[i];
 239     }
 240
 241     ((StgEvacuated*)from)->evacuee = (StgClosure *)to;
 242 #ifdef THREADED_RTS
 243     write_barrier();
 244     ((StgEvacuated*)from)->header.info = &stg_EVACUATED_info;
 245 #endif
 246
 247 #ifdef PROFILING
 248     // We store the size of the just evacuated object in the LDV word so that
 249     // the profiler can guess the position of the next object later.
 250     SET_EVACUAEE_FOR_LDV(from, size_to_reserve);
 251     // fill the slop
 252     if (size_to_reserve - size_to_copy > 0)
 253         LDV_FILL_SLOP(to + size_to_copy - 1, (int)(size_to_reserve - size_to_copy));
 254 #endif
 255 }
 256
 257
 258 /* Copy wrappers that don't tag the closure after copying */
 259 STATIC_INLINE void
 260 copy(StgClosure **p, StgClosure *src, nat size, step *stp)
 261 {
 262     copy_tag(p,src,size,stp,0);
 263 }
 264
 265 STATIC_INLINE void
 266 copy_noscav(StgClosure **p, StgClosure *src, nat size, step *stp)
 267 {
 268     copy_noscav_tag(p,src,size,stp,0);
 269 }
 270
 271 /* -----------------------------------------------------------------------------
 272    Evacuate a large object
 273
 274    This just consists of removing the object from the (doubly-linked)
 275    step->large_objects list, and linking it on to the (singly-linked)
 276    step->new_large_objects list, from where it will be scavenged later.
 277
 278    Convention: bd->flags has BF_EVACUATED set for a large object
 279    that has been evacuated, or unset otherwise.
 280    -------------------------------------------------------------------------- */
 281
 282
 283 STATIC_INLINE void
 284 evacuate_large(StgPtr p)
 285 {
 286   bdescr *bd = Bdescr(p);
 287   step *stp;
 288   step_workspace *ws;
 289
 290   // object must be at the beginning of the block (or be a ByteArray)
 291   ASSERT(get_itbl((StgClosure *)p)->type == ARR_WORDS ||
 292          (((W_)p & BLOCK_MASK) == 0));
 293
 294   // already evacuated?
 295   if (bd->flags & BF_EVACUATED) {
 296     /* Don't forget to set the gct->failed_to_evac flag if we didn't get
 297      * the desired destination (see comments in evacuate()).
 298      */
 299     if (bd->step < gct->evac_step) {
 300       gct->failed_to_evac = rtsTrue;
 301       TICK_GC_FAILED_PROMOTION();
 302     }
 303     return;
 304   }
 305
 306   stp = bd->step;
 307
 308   ACQUIRE_SPIN_LOCK(&stp->sync_large_objects);
 309   // remove from large_object list
 310   if (bd->u.back) {
 311     bd->u.back->link = bd->link;
 312   } else { // first object in the list
 313     stp->large_objects = bd->link;
 314   }
 315   if (bd->link) {
 316     bd->link->u.back = bd->u.back;
 317   }
 318   RELEASE_SPIN_LOCK(&stp->sync_large_objects);
 319
 320   /* link it on to the evacuated large object list of the destination step
 321    */
 322   stp = bd->step->to;
 323   if (stp < gct->evac_step) {
 324       if (gct->eager_promotion) {
 325           stp = gct->evac_step;
 326       } else {
 327           gct->failed_to_evac = rtsTrue;
 328       }
 329   }
 330
 331   ws = &gct->steps[stp->gen_no][stp->no];
 332   bd->step = stp;
 333   bd->gen_no = stp->gen_no;
 334   bd->link = ws->todo_large_objects;
 335   ws->todo_large_objects = bd;
 336   bd->flags |= BF_EVACUATED;
 337 }
 338
 339 /* -----------------------------------------------------------------------------
 340    Evacuate
 341
 342    This is called (eventually) for every live object in the system.
 343
 344    The caller to evacuate specifies a desired generation in the
 345    gct->evac_step thread-local variable.  The following conditions apply to
 346    evacuating an object which resides in generation M when we're
 347    collecting up to generation N
 348
 349    if  M >= gct->evac_step
 350            if  M > N     do nothing
 351            else          evac to step->to
 352
 353    if  M < gct->evac_step      evac to gct->evac_step, step 0
 354
 355    if the object is already evacuated, then we check which generation
 356    it now resides in.
 357
 358    if  M >= gct->evac_step     do nothing
 359    if  M <  gct->evac_step     set gct->failed_to_evac flag to indicate that we
 360                          didn't manage to evacuate this object into gct->evac_step.
 361
 362
 363    OPTIMISATION NOTES:
 364
 365    evacuate() is the single most important function performance-wise
 366    in the GC.  Various things have been tried to speed it up, but as
 367    far as I can tell the code generated by gcc 3.2 with -O2 is about
 368    as good as it's going to get.  We pass the argument to evacuate()
 369    in a register using the 'regparm' attribute (see the prototype for
 370    evacuate() near the top of this file).
 371
 372    Changing evacuate() to take an (StgClosure **) rather than
 373    returning the new pointer seems attractive, because we can avoid
 374    writing back the pointer when it hasn't changed (eg. for a static
 375    object, or an object in a generation > N).  However, I tried it and
 376    it doesn't help.  One reason is that the (StgClosure **) pointer
 377    gets spilled to the stack inside evacuate(), resulting in far more
 378    extra reads/writes than we save.
 379    -------------------------------------------------------------------------- */
 380
 381 REGPARM1 void
 382 evacuate(StgClosure **p)
 383 {
 384   bdescr *bd = NULL;
 385   step *stp;
 386   StgClosure *q;
 387   const StgInfoTable *info;
 388   StgWord tag;
 389
 390   q = *p;
 391
 392 loop:
 393   /* The tag and the pointer are split, to be merged after evacing */
 394   tag = GET_CLOSURE_TAG(q);
 395   q = UNTAG_CLOSURE(q);
 396
 397   ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
 398
 399   if (!HEAP_ALLOCED(q)) {
 400
 401       if (!major_gc) return;
 402
 403       info = get_itbl(q);
 404       switch (info->type) {
 405
 406       case THUNK_STATIC:
 407           if (info->srt_bitmap != 0 &&
 408               *THUNK_STATIC_LINK((StgClosure *)q) == NULL) {
 409               ACQUIRE_SPIN_LOCK(&static_objects_sync);
 410               if (*THUNK_STATIC_LINK((StgClosure *)q) == NULL) {
 411                   *THUNK_STATIC_LINK((StgClosure *)q) = static_objects;
 412                   static_objects = (StgClosure *)q;
 413               }
 414               RELEASE_SPIN_LOCK(&static_objects_sync);
 415           }
 416           return;
 417
 418       case FUN_STATIC:
 419           if (info->srt_bitmap != 0 &&
 420               *FUN_STATIC_LINK((StgClosure *)q) == NULL) {
 421               ACQUIRE_SPIN_LOCK(&static_objects_sync);
 422               if (*FUN_STATIC_LINK((StgClosure *)q) == NULL) {
 423                   *FUN_STATIC_LINK((StgClosure *)q) = static_objects;
 424                   static_objects = (StgClosure *)q;
 425               }
 426               RELEASE_SPIN_LOCK(&static_objects_sync);
 427           }
 428           return;
 429
 430       case IND_STATIC:
 431           /* If q->saved_info != NULL, then it's a revertible CAF - it'll be
 432            * on the CAF list, so don't do anything with it here (we'll
 433            * scavenge it later).
 434            */
 435           if (((StgIndStatic *)q)->saved_info == NULL) {
 436               ACQUIRE_SPIN_LOCK(&static_objects_sync);
 437               if (*IND_STATIC_LINK((StgClosure *)q) == NULL) {
 438                   *IND_STATIC_LINK((StgClosure *)q) = static_objects;
 439                   static_objects = (StgClosure *)q;
 440               }
 441               RELEASE_SPIN_LOCK(&static_objects_sync);
 442           }
 443           return;
 444
 445       case CONSTR_STATIC:
 446           if (*STATIC_LINK(info,(StgClosure *)q) == NULL) {
 447               ACQUIRE_SPIN_LOCK(&static_objects_sync);
 448               // re-test, after acquiring lock
 449               if (*STATIC_LINK(info,(StgClosure *)q) == NULL) {
 450                   *STATIC_LINK(info,(StgClosure *)q) = static_objects;
 451                   static_objects = (StgClosure *)q;
 452               }
 453               RELEASE_SPIN_LOCK(&static_objects_sync);
 454                 /* I am assuming that static_objects pointers are not
 455                  * written to other objects, and thus, no need to retag. */
 456           }
 457           return;
 458
 459       case CONSTR_NOCAF_STATIC:
 460           /* no need to put these on the static linked list, they don't need
 461            * to be scavenged.
 462            */
 463           return;
 464
 465       default:
 466           barf("evacuate(static): strange closure type %d", (int)(info->type));
 467       }
 468   }
 469
 470   bd = Bdescr((P_)q);
 471
 472   if (bd->gen_no > N) {
 473       /* Can't evacuate this object, because it's in a generation
 474        * older than the ones we're collecting.  Let's hope that it's
 475        * in gct->evac_step or older, or we will have to arrange to track
 476        * this pointer using the mutable list.
 477        */
 478       if (bd->step < gct->evac_step) {
 479           // nope
 480           gct->failed_to_evac = rtsTrue;
 481           TICK_GC_FAILED_PROMOTION();
 482       }
 483       return;
 484   }
 485
 486   if ((bd->flags & (BF_LARGE | BF_COMPACTED | BF_EVACUATED)) != 0) {
 487
 488       /* pointer into to-space: just return it.  This normally
 489        * shouldn't happen, but alllowing it makes certain things
 490        * slightly easier (eg. the mutable list can contain the same
 491        * object twice, for example).
 492        */
 493       if (bd->flags & BF_EVACUATED) {
 494           if (bd->step < gct->evac_step) {
 495               gct->failed_to_evac = rtsTrue;
 496               TICK_GC_FAILED_PROMOTION();
 497           }
 498           return;
 499       }
 500
 501       /* evacuate large objects by re-linking them onto a different list.
 502        */
 503       if (bd->flags & BF_LARGE) {
 504           info = get_itbl(q);
 505           if (info->type == TSO &&
 506               ((StgTSO *)q)->what_next == ThreadRelocated) {
 507               q = (StgClosure *)((StgTSO *)q)->link;
 508               *p = q;
 509               goto loop;
 510           }
 511           evacuate_large((P_)q);
 512           return;
 513       }
 514
 515       /* If the object is in a step that we're compacting, then we
 516        * need to use an alternative evacuate procedure.
 517        */
 518       if (bd->flags & BF_COMPACTED) {
 519           if (!is_marked((P_)q,bd)) {
 520               mark((P_)q,bd);
 521               if (mark_stack_full()) {
 522                   mark_stack_overflowed = rtsTrue;
 523                   reset_mark_stack();
 524               }
 525               push_mark_stack((P_)q);
 526           }
 527           return;
 528       }
 529   }
 530
 531   stp = bd->step->to;
 532
 533   info = get_itbl(q);
 534
 535   switch (info->type) {
 536
 537   case WHITEHOLE:
 538       goto loop;
 539
 540   case MUT_VAR_CLEAN:
 541   case MUT_VAR_DIRTY:
 542   case MVAR_CLEAN:
 543   case MVAR_DIRTY:
 544       copy(p,q,sizeW_fromITBL(info),stp);
 545       return;
 546
 547   case CONSTR_0_1:
 548   {
 549       StgWord w = (StgWord)q->payload[0];
 550       if (q->header.info == Czh_con_info &&
 551           // unsigned, so always true:  (StgChar)w >= MIN_CHARLIKE &&
 552           (StgChar)w <= MAX_CHARLIKE) {
 553           *p =  TAG_CLOSURE(tag,
 554                             (StgClosure *)CHARLIKE_CLOSURE((StgChar)w)
 555                            );
 556       }
 557       if (q->header.info == Izh_con_info &&
 558           (StgInt)w >= MIN_INTLIKE && (StgInt)w <= MAX_INTLIKE) {
 559           *p = TAG_CLOSURE(tag,
 560                              (StgClosure *)INTLIKE_CLOSURE((StgInt)w)
 561                              );
 562       }
 563       else {
 564           copy_noscav_tag(p,q,sizeofW(StgHeader)+1,stp,tag);
 565       }
 566       return;
 567   }
 568
 569   case FUN_0_1:
 570   case FUN_1_0:
 571   case CONSTR_1_0:
 572       copy_tag(p,q,sizeofW(StgHeader)+1,stp,tag);
 573       return;
 574
 575   case THUNK_1_0:
 576   case THUNK_0_1:
 577       copy(p,q,sizeofW(StgThunk)+1,stp);
 578       return;
 579
 580   case THUNK_1_1:
 581   case THUNK_2_0:
 582   case THUNK_0_2:
 583 #ifdef NO_PROMOTE_THUNKS
 584     if (bd->gen_no == 0 &&
 585         bd->step->no != 0 &&
 586         bd->step->no == generations[bd->gen_no].n_steps-1) {
 587       stp = bd->step;
 588     }
 589 #endif
 590     copy(p,q,sizeofW(StgThunk)+2,stp);
 591     return;
 592
 593   case FUN_1_1:
 594   case FUN_2_0:
 595   case FUN_0_2:
 596   case CONSTR_1_1:
 597   case CONSTR_2_0:
 598       copy_tag(p,q,sizeofW(StgHeader)+2,stp,tag);
 599       return;
 600
 601   case CONSTR_0_2:
 602       copy_noscav_tag(p,q,sizeofW(StgHeader)+2,stp,tag);
 603       return;
 604
 605   case THUNK:
 606       copy(p,q,thunk_sizeW_fromITBL(info),stp);
 607       return;
 608
 609   case FUN:
 610   case IND_PERM:
 611   case IND_OLDGEN_PERM:
 612   case WEAK:
 613   case STABLE_NAME:
 614   case CONSTR:
 615       copy_tag(p,q,sizeW_fromITBL(info),stp,tag);
 616       return;
 617
 618   case BCO:
 619       copy(p,q,bco_sizeW((StgBCO *)q),stp);
 620       return;
 621
 622   case CAF_BLACKHOLE:
 623   case SE_CAF_BLACKHOLE:
 624   case SE_BLACKHOLE:
 625   case BLACKHOLE:
 626       copyPart(p,q,BLACKHOLE_sizeW(),sizeofW(StgHeader),stp);
 627       return;
 628
 629   case THUNK_SELECTOR:
 630       eval_thunk_selector(p, (StgSelector *)q, rtsTrue);
 631       return;
 632
 633   case IND:
 634   case IND_OLDGEN:
 635     // follow chains of indirections, don't evacuate them
 636     q = ((StgInd*)q)->indirectee;
 637     *p = q;
 638     goto loop;
 639
 640   case RET_BCO:
 641   case RET_SMALL:
 642   case RET_BIG:
 643   case RET_DYN:
 644   case UPDATE_FRAME:
 645   case STOP_FRAME:
 646   case CATCH_FRAME:
 647   case CATCH_STM_FRAME:
 648   case CATCH_RETRY_FRAME:
 649   case ATOMICALLY_FRAME:
 650     // shouldn't see these
 651     barf("evacuate: stack frame at %p\n", q);
 652
 653   case PAP:
 654       copy(p,q,pap_sizeW((StgPAP*)q),stp);
 655       return;
 656
 657   case AP:
 658       copy(p,q,ap_sizeW((StgAP*)q),stp);
 659       return;
 660
 661   case AP_STACK:
 662       copy(p,q,ap_stack_sizeW((StgAP_STACK*)q),stp);
 663       return;
 664
 665   case EVACUATED:
 666     /* Already evacuated, just return the forwarding address.
 667      * HOWEVER: if the requested destination generation (gct->evac_step) is
 668      * older than the actual generation (because the object was
 669      * already evacuated to a younger generation) then we have to
 670      * set the gct->failed_to_evac flag to indicate that we couldn't
 671      * manage to promote the object to the desired generation.
 672      */
 673     /*
 674      * Optimisation: the check is fairly expensive, but we can often
 675      * shortcut it if either the required generation is 0, or the
 676      * current object (the EVACUATED) is in a high enough generation.
 677      * We know that an EVACUATED always points to an object in the
 678      * same or an older generation.  stp is the lowest step that the
 679      * current object would be evacuated to, so we only do the full
 680      * check if stp is too low.
 681      */
 682   {
 683       StgClosure *e = ((StgEvacuated*)q)->evacuee;
 684       *p = e;
 685       if (stp < gct->evac_step) {  // optimisation
 686           if (HEAP_ALLOCED(e) && Bdescr((P_)e)->step < gct->evac_step) {
 687               gct->failed_to_evac = rtsTrue;
 688               TICK_GC_FAILED_PROMOTION();
 689           }
 690       }
 691       return;
 692   }
 693
 694   case ARR_WORDS:
 695       // just copy the block
 696       copy_noscav(p,q,arr_words_sizeW((StgArrWords *)q),stp);
 697       return;
 698
 699   case MUT_ARR_PTRS_CLEAN:
 700   case MUT_ARR_PTRS_DIRTY:
 701   case MUT_ARR_PTRS_FROZEN:
 702   case MUT_ARR_PTRS_FROZEN0:
 703       // just copy the block
 704       copy(p,q,mut_arr_ptrs_sizeW((StgMutArrPtrs *)q),stp);
 705       return;
 706
 707   case TSO:
 708     {
 709       StgTSO *tso = (StgTSO *)q;
 710
 711       /* Deal with redirected TSOs (a TSO that's had its stack enlarged).
 712        */
 713       if (tso->what_next == ThreadRelocated) {
 714         q = (StgClosure *)tso->link;
 715         *p = q;
 716         goto loop;
 717       }
 718
 719       /* To evacuate a small TSO, we need to relocate the update frame
 720        * list it contains.
 721        */
 722       {
 723           StgTSO *new_tso;
 724           StgPtr r, s;
 725
 726           copyPart(p,(StgClosure *)tso, tso_sizeW(tso), sizeofW(StgTSO), stp);
 727           new_tso = (StgTSO *)*p;
 728           move_TSO(tso, new_tso);
 729           for (r = tso->sp, s = new_tso->sp;
 730                r < tso->stack+tso->stack_size;) {
 731               *s++ = *r++;
 732           }
 733           return;
 734       }
 735     }
 736
 737   case TREC_HEADER:
 738       copy(p,q,sizeofW(StgTRecHeader),stp);
 739       return;
 740
 741   case TVAR_WATCH_QUEUE:
 742       copy(p,q,sizeofW(StgTVarWatchQueue),stp);
 743       return;
 744
 745   case TVAR:
 746       copy(p,q,sizeofW(StgTVar),stp);
 747       return;
 748
 749   case TREC_CHUNK:
 750       copy(p,q,sizeofW(StgTRecChunk),stp);
 751       return;
 752
 753   case ATOMIC_INVARIANT:
 754       copy(p,q,sizeofW(StgAtomicInvariant),stp);
 755       return;
 756
 757   case INVARIANT_CHECK_QUEUE:
 758       copy(p,q,sizeofW(StgInvariantCheckQueue),stp);
 759       return;
 760
 761   default:
 762     barf("evacuate: strange closure type %d", (int)(info->type));
 763   }
 764
 765   barf("evacuate");
 766 }
 767
 768 static void
 769 unchain_thunk_selectors(StgSelector *p, StgClosure *val)
 770 {
 771     StgSelector *prev;
 772
 773     prev = NULL;
 774     while (p)
 775     {
 776         ASSERT(p->header.info == &stg_BLACKHOLE_info);
 777         prev = (StgSelector*)((StgClosure *)p)->payload[0];
 778
 779         // Update the THUNK_SELECTOR with an indirection to the
 780         // EVACUATED closure now at p.  Why do this rather than
 781         // upd_evacuee(q,p)?  Because we have an invariant that an
 782         // EVACUATED closure always points to an object in the
 783         // same or an older generation (required by the short-cut
 784         // test in the EVACUATED case, below).
 785         SET_INFO(p, &stg_IND_info);
 786         ((StgInd *)p)->indirectee = val;
 787
 788         // For the purposes of LDV profiling, we have created an
 789         // indirection.
 790         LDV_RECORD_CREATE(p);
 791
 792         p = prev;
 793     }
 794 }
 795
 796 /* -----------------------------------------------------------------------------
 797    Evaluate a THUNK_SELECTOR if possible.
 798
 799    p points to a THUNK_SELECTOR that we want to evaluate.  The
 800    result of "evaluating" it will be evacuated and a pointer to the
 801    to-space closure will be returned.
 802
 803    If the THUNK_SELECTOR could not be evaluated (its selectee is still
 804    a THUNK, for example), then the THUNK_SELECTOR itself will be
 805    evacuated.
 806    -------------------------------------------------------------------------- */
 807
 808 static void
 809 eval_thunk_selector (StgClosure **q, StgSelector * p, rtsBool evac)
 810                  // NB. for legacy reasons, p & q are swapped around :(
 811 {
 812     nat field;
 813     StgInfoTable *info;
 814     const StgInfoTable *info_ptr;
 815     StgClosure *selectee;
 816     StgSelector *prev_thunk_selector;
 817     bdescr *bd;
 818     StgClosure *val;
 819
 820     prev_thunk_selector = NULL;
 821     // this is a chain of THUNK_SELECTORs that we are going to update
 822     // to point to the value of the current THUNK_SELECTOR.  Each
 823     // closure on the chain is a BLACKHOLE, and points to the next in the
 824     // chain with payload[0].
 825
 826 selector_chain:
 827
 828     // The selectee might be a constructor closure,
 829     // so we untag the pointer.
 830     selectee = UNTAG_CLOSURE(p->selectee);
 831
 832     // Save the real info pointer (NOTE: not the same as get_itbl()).
 833     info_ptr = p->header.info;
 834     field = get_itbl(p)->layout.selector_offset;
 835
 836     bd = Bdescr((StgPtr)p);
 837     if (HEAP_ALLOCED(p)) {
 838         // If the THUNK_SELECTOR is in to-space or in a generation that we
 839         // are not collecting, then bale out early.  We won't be able to
 840         // save any space in any case, and updating with an indirection is
 841         // trickier in a non-collected gen: we would have to update the
 842         // mutable list.
 843         if ((bd->gen_no > N) || (bd->flags & BF_EVACUATED)) {
 844             unchain_thunk_selectors(prev_thunk_selector, (StgClosure *)p);
 845             *q = (StgClosure *)p;
 846             return;
 847         }
 848         // we don't update THUNK_SELECTORS in the compacted
 849         // generation, because compaction does not remove the INDs
 850         // that result, this causes confusion later
 851         // (scavenge_mark_stack doesn't deal with IND).  BEWARE!  This
 852         // bit is very tricky to get right.  If you make changes
 853         // around here, test by compiling stage 3 with +RTS -c -RTS.
 854         if (bd->flags & BF_COMPACTED) {
 855             // must call evacuate() to mark this closure if evac==rtsTrue
 856             *q = (StgClosure *)p;
 857             if (evac) evacuate(q);
 858             unchain_thunk_selectors(prev_thunk_selector, (StgClosure *)p);
 859             return;
 860         }
 861     }
 862
 863     // BLACKHOLE the selector thunk, since it is now under evaluation.
 864     // This is important to stop us going into an infinite loop if
 865     // this selector thunk eventually refers to itself.
 866     SET_INFO(p,&stg_BLACKHOLE_info);
 867
 868 selector_loop:
 869     // selectee now points to the closure that we're trying to select
 870     // a field from.  It may or may not be in to-space: we try not to
 871     // end up in to-space, but it's impractical to avoid it in
 872     // general.  The compacting GC scatters to-space pointers in
 873     // from-space during marking, for example.  We rely on the property
 874     // that evacuate() doesn't mind if it gets passed a to-space pointer.
 875
 876     info = get_itbl(selectee);
 877     switch (info->type) {
 878       case CONSTR:
 879       case CONSTR_1_0:
 880       case CONSTR_0_1:
 881       case CONSTR_2_0:
 882       case CONSTR_1_1:
 883       case CONSTR_0_2:
 884       case CONSTR_STATIC:
 885       case CONSTR_NOCAF_STATIC:
 886           {
 887               // check that the size is in range
 888               ASSERT(field <  (StgWord32)(info->layout.payload.ptrs +
 889                                           info->layout.payload.nptrs));
 890
 891               // Select the right field from the constructor
 892               val = selectee->payload[field];
 893
 894 #ifdef PROFILING
 895               // For the purposes of LDV profiling, we have destroyed
 896               // the original selector thunk, p.
 897               SET_INFO(p, info_ptr);
 898               LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC((StgClosure *)p);
 899               SET_INFO(p, &stg_BLACKHOLE_info);
 900 #endif
 901
 902               // the closure in val is now the "value" of the
 903               // THUNK_SELECTOR in p.  However, val may itself be a
 904               // THUNK_SELECTOR, in which case we want to continue
 905               // evaluating until we find the real value, and then
 906               // update the whole chain to point to the value.
 907           val_loop:
 908               info = get_itbl(UNTAG_CLOSURE(val));
 909               switch (info->type) {
 910               case IND:
 911               case IND_PERM:
 912               case IND_OLDGEN:
 913               case IND_OLDGEN_PERM:
 914               case IND_STATIC:
 915                   val = ((StgInd *)val)->indirectee;
 916                   goto val_loop;
 917               case THUNK_SELECTOR:
 918                   ((StgClosure*)p)->payload[0] = (StgClosure *)prev_thunk_selector;
 919                   prev_thunk_selector = p;
 920                   p = (StgSelector*)val;
 921                   goto selector_chain;
 922               default:
 923                   ((StgClosure*)p)->payload[0] = (StgClosure *)prev_thunk_selector;
 924                   prev_thunk_selector = p;
 925
 926                   *q = val;
 927                   if (evac) evacuate(q);
 928                   val = *q;
 929                   // evacuate() cannot recurse through
 930                   // eval_thunk_selector(), because we know val is not
 931                   // a THUNK_SELECTOR.
 932                   unchain_thunk_selectors(prev_thunk_selector, val);
 933                   return;
 934               }
 935           }
 936
 937       case IND:
 938       case IND_PERM:
 939       case IND_OLDGEN:
 940       case IND_OLDGEN_PERM:
 941       case IND_STATIC:
 942           // Again, we might need to untag a constructor.
 943           selectee = UNTAG_CLOSURE( ((StgInd *)selectee)->indirectee );
 944           goto selector_loop;
 945
 946       case EVACUATED:
 947           // We don't follow pointers into to-space; the constructor
 948           // has already been evacuated, so we won't save any space
 949           // leaks by evaluating this selector thunk anyhow.
 950           goto bale_out;
 951
 952       case THUNK_SELECTOR:
 953       {
 954           StgClosure *val;
 955
 956           // recursively evaluate this selector.  We don't want to
 957           // recurse indefinitely, so we impose a depth bound.
 958           if (gct->thunk_selector_depth >= MAX_THUNK_SELECTOR_DEPTH) {
 959               goto bale_out;
 960           }
 961
 962           gct->thunk_selector_depth++;
 963           // rtsFalse says "don't evacuate the result".  It will,
 964           // however, update any THUNK_SELECTORs that are evaluated
 965           // along the way.
 966           eval_thunk_selector(&val, (StgSelector*)selectee, rtsFalse);
 967           gct->thunk_selector_depth--;
 968
 969           // did we actually manage to evaluate it?
 970           if (val == selectee) goto bale_out;
 971
 972           // Of course this pointer might be tagged...
 973           selectee = UNTAG_CLOSURE(val);
 974           goto selector_loop;
 975       }
 976
 977       case AP:
 978       case AP_STACK:
 979       case THUNK:
 980       case THUNK_1_0:
 981       case THUNK_0_1:
 982       case THUNK_2_0:
 983       case THUNK_1_1:
 984       case THUNK_0_2:
 985       case THUNK_STATIC:
 986       case CAF_BLACKHOLE:
 987       case SE_CAF_BLACKHOLE:
 988       case SE_BLACKHOLE:
 989       case BLACKHOLE:
 990           // not evaluated yet
 991           goto bale_out;
 992
 993       default:
 994         barf("eval_thunk_selector: strange selectee %d",
 995              (int)(info->type));
 996     }
 997
 998 bale_out:
 999     // We didn't manage to evaluate this thunk; restore the old info
1000     // pointer.  But don't forget: we still need to evacuate the thunk itself.
1001     SET_INFO(p, info_ptr);
1002     if (evac) {
1003         copy(&val,(StgClosure *)p,THUNK_SELECTOR_sizeW(),bd->step->to);
1004     } else {
1005         val = (StgClosure *)p;
1006     }
1007     *q = val;
1008     unchain_thunk_selectors(prev_thunk_selector, val);
1009     return;
1010 }
1011
1012 /* -----------------------------------------------------------------------------
1013    move_TSO is called to update the TSO structure after it has been
1014    moved from one place to another.
1015    -------------------------------------------------------------------------- */
1016
1017 void
1018 move_TSO (StgTSO *src, StgTSO *dest)
1019 {
1020     ptrdiff_t diff;
1021
1022     // relocate the stack pointer...
1023     diff = (StgPtr)dest - (StgPtr)src; // In *words*
1024     dest->sp = (StgPtr)dest->sp + diff;
1025 }
1026