rts/sm/Evac.c

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