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 #if defined(PAR)
 291   StgClosure *to;
 292 #endif
 293   bdescr *bd = NULL;
 294   step *stp;
 295   const StgInfoTable *info;
 296
 297 loop:
 298   ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
 299
 300   if (!HEAP_ALLOCED(q)) {
 301
 302       if (!major_gc) return q;
 303
 304       info = get_itbl(q);
 305       switch (info->type) {
 306
 307       case THUNK_STATIC:
 308           if (info->srt_bitmap != 0 &&
 309               *THUNK_STATIC_LINK((StgClosure *)q) == NULL) {
 310               *THUNK_STATIC_LINK((StgClosure *)q) = static_objects;
 311               static_objects = (StgClosure *)q;
 312           }
 313           return q;
 314
 315       case FUN_STATIC:
 316           if (info->srt_bitmap != 0 &&
 317               *FUN_STATIC_LINK((StgClosure *)q) == NULL) {
 318               *FUN_STATIC_LINK((StgClosure *)q) = static_objects;
 319               static_objects = (StgClosure *)q;
 320           }
 321           return q;
 322
 323       case IND_STATIC:
 324           /* If q->saved_info != NULL, then it's a revertible CAF - it'll be
 325            * on the CAF list, so don't do anything with it here (we'll
 326            * scavenge it later).
 327            */
 328           if (((StgIndStatic *)q)->saved_info == NULL
 329               && *IND_STATIC_LINK((StgClosure *)q) == NULL) {
 330               *IND_STATIC_LINK((StgClosure *)q) = static_objects;
 331               static_objects = (StgClosure *)q;
 332           }
 333           return q;
 334
 335       case CONSTR_STATIC:
 336           if (*STATIC_LINK(info,(StgClosure *)q) == NULL) {
 337               *STATIC_LINK(info,(StgClosure *)q) = static_objects;
 338               static_objects = (StgClosure *)q;
 339           }
 340           return q;
 341
 342       case CONSTR_NOCAF_STATIC:
 343           /* no need to put these on the static linked list, they don't need
 344            * to be scavenged.
 345            */
 346           return q;
 347
 348       default:
 349           barf("evacuate(static): strange closure type %d", (int)(info->type));
 350       }
 351   }
 352
 353   bd = Bdescr((P_)q);
 354
 355   if (bd->gen_no > N) {
 356       /* Can't evacuate this object, because it's in a generation
 357        * older than the ones we're collecting.  Let's hope that it's
 358        * in evac_gen or older, or we will have to arrange to track
 359        * this pointer using the mutable list.
 360        */
 361       if (bd->gen_no < evac_gen) {
 362           // nope
 363           failed_to_evac = rtsTrue;
 364           TICK_GC_FAILED_PROMOTION();
 365       }
 366       return q;
 367   }
 368
 369   if ((bd->flags & (BF_LARGE | BF_COMPACTED | BF_EVACUATED)) != 0) {
 370
 371       /* pointer into to-space: just return it.  This normally
 372        * shouldn't happen, but alllowing it makes certain things
 373        * slightly easier (eg. the mutable list can contain the same
 374        * object twice, for example).
 375        */
 376       if (bd->flags & BF_EVACUATED) {
 377           if (bd->gen_no < evac_gen) {
 378               failed_to_evac = rtsTrue;
 379               TICK_GC_FAILED_PROMOTION();
 380           }
 381           return q;
 382       }
 383
 384       /* evacuate large objects by re-linking them onto a different list.
 385        */
 386       if (bd->flags & BF_LARGE) {
 387           info = get_itbl(q);
 388           if (info->type == TSO &&
 389               ((StgTSO *)q)->what_next == ThreadRelocated) {
 390               q = (StgClosure *)((StgTSO *)q)->link;
 391               goto loop;
 392           }
 393           evacuate_large((P_)q);
 394           return q;
 395       }
 396
 397       /* If the object is in a step that we're compacting, then we
 398        * need to use an alternative evacuate procedure.
 399        */
 400       if (bd->flags & BF_COMPACTED) {
 401           if (!is_marked((P_)q,bd)) {
 402               mark((P_)q,bd);
 403               if (mark_stack_full()) {
 404                   mark_stack_overflowed = rtsTrue;
 405                   reset_mark_stack();
 406               }
 407               push_mark_stack((P_)q);
 408           }
 409           return q;
 410       }
 411   }
 412
 413   stp = bd->step->to;
 414
 415   info = get_itbl(q);
 416
 417   switch (info->type) {
 418
 419   case MUT_VAR_CLEAN:
 420   case MUT_VAR_DIRTY:
 421   case MVAR:
 422       return copy(q,sizeW_fromITBL(info),stp);
 423
 424   case CONSTR_0_1:
 425   {
 426       StgWord w = (StgWord)q->payload[0];
 427       if (q->header.info == Czh_con_info &&
 428           // unsigned, so always true:  (StgChar)w >= MIN_CHARLIKE &&
 429           (StgChar)w <= MAX_CHARLIKE) {
 430           return (StgClosure *)CHARLIKE_CLOSURE((StgChar)w);
 431       }
 432       if (q->header.info == Izh_con_info &&
 433           (StgInt)w >= MIN_INTLIKE && (StgInt)w <= MAX_INTLIKE) {
 434           return (StgClosure *)INTLIKE_CLOSURE((StgInt)w);
 435       }
 436       // else
 437       return copy_noscav(q,sizeofW(StgHeader)+1,stp);
 438   }
 439
 440   case FUN_0_1:
 441   case FUN_1_0:
 442   case CONSTR_1_0:
 443     return copy(q,sizeofW(StgHeader)+1,stp);
 444
 445   case THUNK_1_0:
 446   case THUNK_0_1:
 447     return copy(q,sizeofW(StgThunk)+1,stp);
 448
 449   case THUNK_1_1:
 450   case THUNK_2_0:
 451   case THUNK_0_2:
 452 #ifdef NO_PROMOTE_THUNKS
 453     if (bd->gen_no == 0 &&
 454         bd->step->no != 0 &&
 455         bd->step->no == generations[bd->gen_no].n_steps-1) {
 456       stp = bd->step;
 457     }
 458 #endif
 459     return copy(q,sizeofW(StgThunk)+2,stp);
 460
 461   case FUN_1_1:
 462   case FUN_2_0:
 463   case CONSTR_1_1:
 464   case CONSTR_2_0:
 465   case FUN_0_2:
 466     return copy(q,sizeofW(StgHeader)+2,stp);
 467
 468   case CONSTR_0_2:
 469     return copy_noscav(q,sizeofW(StgHeader)+2,stp);
 470
 471   case THUNK:
 472     return copy(q,thunk_sizeW_fromITBL(info),stp);
 473
 474   case FUN:
 475   case CONSTR:
 476   case IND_PERM:
 477   case IND_OLDGEN_PERM:
 478   case WEAK:
 479   case STABLE_NAME:
 480     return copy(q,sizeW_fromITBL(info),stp);
 481
 482   case BCO:
 483       return copy(q,bco_sizeW((StgBCO *)q),stp);
 484
 485   case CAF_BLACKHOLE:
 486   case SE_CAF_BLACKHOLE:
 487   case SE_BLACKHOLE:
 488   case BLACKHOLE:
 489     return copyPart(q,BLACKHOLE_sizeW(),sizeofW(StgHeader),stp);
 490
 491   case THUNK_SELECTOR:
 492     {
 493         StgClosure *p;
 494         const StgInfoTable *info_ptr;
 495
 496         if (thunk_selector_depth > MAX_THUNK_SELECTOR_DEPTH) {
 497             return copy(q,THUNK_SELECTOR_sizeW(),stp);
 498         }
 499
 500         // stashed away for LDV profiling, see below
 501         info_ptr = q->header.info;
 502
 503         p = eval_thunk_selector(info->layout.selector_offset,
 504                                 (StgSelector *)q);
 505
 506         if (p == NULL) {
 507             return copy(q,THUNK_SELECTOR_sizeW(),stp);
 508         } else {
 509             StgClosure *val;
 510             // q is still BLACKHOLE'd.
 511             thunk_selector_depth++;
 512             val = evacuate(p);
 513             thunk_selector_depth--;
 514
 515 #ifdef PROFILING
 516             // For the purposes of LDV profiling, we have destroyed
 517             // the original selector thunk.
 518             SET_INFO(q, info_ptr);
 519             LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC(q);
 520 #endif
 521
 522             // Update the THUNK_SELECTOR with an indirection to the
 523             // EVACUATED closure now at p.  Why do this rather than
 524             // upd_evacuee(q,p)?  Because we have an invariant that an
 525             // EVACUATED closure always points to an object in the
 526             // same or an older generation (required by the short-cut
 527             // test in the EVACUATED case, below).
 528             SET_INFO(q, &stg_IND_info);
 529             ((StgInd *)q)->indirectee = p;
 530
 531             // For the purposes of LDV profiling, we have created an
 532             // indirection.
 533             LDV_RECORD_CREATE(q);
 534
 535             return val;
 536         }
 537     }
 538
 539   case IND:
 540   case IND_OLDGEN:
 541     // follow chains of indirections, don't evacuate them
 542     q = ((StgInd*)q)->indirectee;
 543     goto loop;
 544
 545   case RET_BCO:
 546   case RET_SMALL:
 547   case RET_VEC_SMALL:
 548   case RET_BIG:
 549   case RET_VEC_BIG:
 550   case RET_DYN:
 551   case UPDATE_FRAME:
 552   case STOP_FRAME:
 553   case CATCH_FRAME:
 554   case CATCH_STM_FRAME:
 555   case CATCH_RETRY_FRAME:
 556   case ATOMICALLY_FRAME:
 557     // shouldn't see these
 558     barf("evacuate: stack frame at %p\n", q);
 559
 560   case PAP:
 561       return copy(q,pap_sizeW((StgPAP*)q),stp);
 562
 563   case AP:
 564       return copy(q,ap_sizeW((StgAP*)q),stp);
 565
 566   case AP_STACK:
 567       return copy(q,ap_stack_sizeW((StgAP_STACK*)q),stp);
 568
 569   case EVACUATED:
 570     /* Already evacuated, just return the forwarding address.
 571      * HOWEVER: if the requested destination generation (evac_gen) is
 572      * older than the actual generation (because the object was
 573      * already evacuated to a younger generation) then we have to
 574      * set the failed_to_evac flag to indicate that we couldn't
 575      * manage to promote the object to the desired generation.
 576      */
 577     /*
 578      * Optimisation: the check is fairly expensive, but we can often
 579      * shortcut it if either the required generation is 0, or the
 580      * current object (the EVACUATED) is in a high enough generation.
 581      * We know that an EVACUATED always points to an object in the
 582      * same or an older generation.  stp is the lowest step that the
 583      * current object would be evacuated to, so we only do the full
 584      * check if stp is too low.
 585      */
 586     if (evac_gen > 0 && stp->gen_no < evac_gen) {  // optimisation
 587       StgClosure *p = ((StgEvacuated*)q)->evacuee;
 588       if (HEAP_ALLOCED(p) && Bdescr((P_)p)->gen_no < evac_gen) {
 589         failed_to_evac = rtsTrue;
 590         TICK_GC_FAILED_PROMOTION();
 591       }
 592     }
 593     return ((StgEvacuated*)q)->evacuee;
 594
 595   case ARR_WORDS:
 596       // just copy the block
 597       return copy_noscav(q,arr_words_sizeW((StgArrWords *)q),stp);
 598
 599   case MUT_ARR_PTRS_CLEAN:
 600   case MUT_ARR_PTRS_DIRTY:
 601   case MUT_ARR_PTRS_FROZEN:
 602   case MUT_ARR_PTRS_FROZEN0:
 603       // just copy the block
 604       return copy(q,mut_arr_ptrs_sizeW((StgMutArrPtrs *)q),stp);
 605
 606   case TSO:
 607     {
 608       StgTSO *tso = (StgTSO *)q;
 609
 610       /* Deal with redirected TSOs (a TSO that's had its stack enlarged).
 611        */
 612       if (tso->what_next == ThreadRelocated) {
 613         q = (StgClosure *)tso->link;
 614         goto loop;
 615       }
 616
 617       /* To evacuate a small TSO, we need to relocate the update frame
 618        * list it contains.
 619        */
 620       {
 621           StgTSO *new_tso;
 622           StgPtr p, q;
 623
 624           new_tso = (StgTSO *)copyPart((StgClosure *)tso,
 625                                        tso_sizeW(tso),
 626                                        sizeofW(StgTSO), stp);
 627           move_TSO(tso, new_tso);
 628           for (p = tso->sp, q = new_tso->sp;
 629                p < tso->stack+tso->stack_size;) {
 630               *q++ = *p++;
 631           }
 632
 633           return (StgClosure *)new_tso;
 634       }
 635     }
 636
 637 #if defined(PAR)
 638   case RBH:
 639     {
 640       //StgInfoTable *rip = get_closure_info(q, &size, &ptrs, &nonptrs, &vhs, str);
 641       to = copy(q,BLACKHOLE_sizeW(),stp);
 642       //ToDo: derive size etc from reverted IP
 643       //to = copy(q,size,stp);
 644       debugTrace(DEBUG_gc, "evacuate: RBH %p (%s) to %p (%s)",
 645                  q, info_type(q), to, info_type(to));
 646       return to;
 647     }
 648
 649   case BLOCKED_FETCH:
 650     ASSERT(sizeofW(StgBlockedFetch) >= MIN_PAYLOD_SIZE);
 651     to = copy(q,sizeofW(StgBlockedFetch),stp);
 652     debugTrace(DEBUG_gc, "evacuate: %p (%s) to %p (%s)",
 653                q, info_type(q), to, info_type(to));
 654     return to;
 655
 656 # ifdef DIST
 657   case REMOTE_REF:
 658 # endif
 659   case FETCH_ME:
 660     ASSERT(sizeofW(StgBlockedFetch) >= MIN_PAYLOAD_SIZE);
 661     to = copy(q,sizeofW(StgFetchMe),stp);
 662     debugTrace(DEBUG_gc, "evacuate: %p (%s) to %p (%s)",
 663                q, info_type(q), to, info_type(to)));
 664     return to;
 665
 666   case FETCH_ME_BQ:
 667     ASSERT(sizeofW(StgBlockedFetch) >= MIN_PAYLOAD_SIZE);
 668     to = copy(q,sizeofW(StgFetchMeBlockingQueue),stp);
 669     debugTrace(DEBUG_gc, "evacuate: %p (%s) to %p (%s)",
 670                q, info_type(q), to, info_type(to)));
 671     return to;
 672 #endif
 673
 674   case TREC_HEADER:
 675     return copy(q,sizeofW(StgTRecHeader),stp);
 676
 677   case TVAR_WATCH_QUEUE:
 678     return copy(q,sizeofW(StgTVarWatchQueue),stp);
 679
 680   case TVAR:
 681     return copy(q,sizeofW(StgTVar),stp);
 682
 683   case TREC_CHUNK:
 684     return copy(q,sizeofW(StgTRecChunk),stp);
 685
 686   case ATOMIC_INVARIANT:
 687     return copy(q,sizeofW(StgAtomicInvariant),stp);
 688
 689   case INVARIANT_CHECK_QUEUE:
 690     return copy(q,sizeofW(StgInvariantCheckQueue),stp);
 691
 692   default:
 693     barf("evacuate: strange closure type %d", (int)(info->type));
 694   }
 695
 696   barf("evacuate");
 697 }
 698
 699 /* -----------------------------------------------------------------------------
 700    Evaluate a THUNK_SELECTOR if possible.
 701
 702    returns: NULL if we couldn't evaluate this THUNK_SELECTOR, or
 703    a closure pointer if we evaluated it and this is the result.  Note
 704    that "evaluating" the THUNK_SELECTOR doesn't necessarily mean
 705    reducing it to HNF, just that we have eliminated the selection.
 706    The result might be another thunk, or even another THUNK_SELECTOR.
 707
 708    If the return value is non-NULL, the original selector thunk has
 709    been BLACKHOLE'd, and should be updated with an indirection or a
 710    forwarding pointer.  If the return value is NULL, then the selector
 711    thunk is unchanged.
 712
 713    ***
 714    ToDo: the treatment of THUNK_SELECTORS could be improved in the
 715    following way (from a suggestion by Ian Lynagh):
 716
 717    We can have a chain like this:
 718
 719       sel_0 --> (a,b)
 720                  |
 721                  |-----> sel_0 --> (a,b)
 722                                     |
 723                                     |-----> sel_0 --> ...
 724
 725    and the depth limit means we don't go all the way to the end of the
 726    chain, which results in a space leak.  This affects the recursive
 727    call to evacuate() in the THUNK_SELECTOR case in evacuate(): *not*
 728    the recursive call to eval_thunk_selector() in
 729    eval_thunk_selector().
 730
 731    We could eliminate the depth bound in this case, in the following
 732    way:
 733
 734       - traverse the chain once to discover the *value* of the
 735         THUNK_SELECTOR.  Mark all THUNK_SELECTORS that we
 736         visit on the way as having been visited already (somehow).
 737
 738       - in a second pass, traverse the chain again updating all
 739         THUNK_SEELCTORS that we find on the way with indirections to
 740         the value.
 741
 742       - if we encounter a "marked" THUNK_SELECTOR in a normal
 743         evacuate(), we konw it can't be updated so just evac it.
 744
 745    Program that illustrates the problem:
 746
 747         foo [] = ([], [])
 748         foo (x:xs) = let (ys, zs) = foo xs
 749                      in if x >= 0 then (x:ys, zs) else (ys, x:zs)
 750
 751         main = bar [1..(100000000::Int)]
 752         bar xs = (\(ys, zs) -> print ys >> print zs) (foo xs)
 753
 754    -------------------------------------------------------------------------- */
 755
 756 static inline rtsBool
 757 is_to_space ( StgClosure *p )
 758 {
 759     bdescr *bd;
 760
 761     bd = Bdescr((StgPtr)p);
 762     if (HEAP_ALLOCED(p) &&
 763         ((bd->flags & BF_EVACUATED)
 764          || ((bd->flags & BF_COMPACTED) &&
 765              is_marked((P_)p,bd)))) {
 766         return rtsTrue;
 767     } else {
 768         return rtsFalse;
 769     }
 770 }
 771
 772 static StgClosure *
 773 eval_thunk_selector( nat field, StgSelector * p )
 774 {
 775     StgInfoTable *info;
 776     const StgInfoTable *info_ptr;
 777     StgClosure *selectee;
 778
 779     selectee = p->selectee;
 780
 781     // Save the real info pointer (NOTE: not the same as get_itbl()).
 782     info_ptr = p->header.info;
 783
 784     // If the THUNK_SELECTOR is in a generation that we are not
 785     // collecting, then bail out early.  We won't be able to save any
 786     // space in any case, and updating with an indirection is trickier
 787     // in an old gen.
 788     if (Bdescr((StgPtr)p)->gen_no > N) {
 789         return NULL;
 790     }
 791
 792     // BLACKHOLE the selector thunk, since it is now under evaluation.
 793     // This is important to stop us going into an infinite loop if
 794     // this selector thunk eventually refers to itself.
 795     SET_INFO(p,&stg_BLACKHOLE_info);
 796
 797 selector_loop:
 798
 799     // We don't want to end up in to-space, because this causes
 800     // problems when the GC later tries to evacuate the result of
 801     // eval_thunk_selector().  There are various ways this could
 802     // happen:
 803     //
 804     // 1. following an IND_STATIC
 805     //
 806     // 2. when the old generation is compacted, the mark phase updates
 807     //    from-space pointers to be to-space pointers, and we can't
 808     //    reliably tell which we're following (eg. from an IND_STATIC).
 809     //
 810     // 3. compacting GC again: if we're looking at a constructor in
 811     //    the compacted generation, it might point directly to objects
 812     //    in to-space.  We must bale out here, otherwise doing the selection
 813     //    will result in a to-space pointer being returned.
 814     //
 815     //  (1) is dealt with using a BF_EVACUATED test on the
 816     //  selectee. (2) and (3): we can tell if we're looking at an
 817     //  object in the compacted generation that might point to
 818     //  to-space objects by testing that (a) it is BF_COMPACTED, (b)
 819     //  the compacted generation is being collected, and (c) the
 820     //  object is marked.  Only a marked object may have pointers that
 821     //  point to to-space objects, because that happens when
 822     //  scavenging.
 823     //
 824     //  The to-space test is now embodied in the in_to_space() inline
 825     //  function, as it is re-used below.
 826     //
 827     if (is_to_space(selectee)) {
 828         goto bale_out;
 829     }
 830
 831     info = get_itbl(selectee);
 832     switch (info->type) {
 833       case CONSTR:
 834       case CONSTR_1_0:
 835       case CONSTR_0_1:
 836       case CONSTR_2_0:
 837       case CONSTR_1_1:
 838       case CONSTR_0_2:
 839       case CONSTR_STATIC:
 840       case CONSTR_NOCAF_STATIC:
 841           // check that the size is in range
 842           ASSERT(field <  (StgWord32)(info->layout.payload.ptrs +
 843                                       info->layout.payload.nptrs));
 844
 845           // Select the right field from the constructor, and check
 846           // that the result isn't in to-space.  It might be in
 847           // to-space if, for example, this constructor contains
 848           // pointers to younger-gen objects (and is on the mut-once
 849           // list).
 850           //
 851           {
 852               StgClosure *q;
 853               q = selectee->payload[field];
 854               if (is_to_space(q)) {
 855                   goto bale_out;
 856               } else {
 857                   return q;
 858               }
 859           }
 860
 861       case IND:
 862       case IND_PERM:
 863       case IND_OLDGEN:
 864       case IND_OLDGEN_PERM:
 865       case IND_STATIC:
 866           selectee = ((StgInd *)selectee)->indirectee;
 867           goto selector_loop;
 868
 869       case EVACUATED:
 870           // We don't follow pointers into to-space; the constructor
 871           // has already been evacuated, so we won't save any space
 872           // leaks by evaluating this selector thunk anyhow.
 873           break;
 874
 875       case THUNK_SELECTOR:
 876       {
 877           StgClosure *val;
 878
 879           // check that we don't recurse too much, re-using the
 880           // depth bound also used in evacuate().
 881           if (thunk_selector_depth >= MAX_THUNK_SELECTOR_DEPTH) {
 882               break;
 883           }
 884           thunk_selector_depth++;
 885
 886           val = eval_thunk_selector(info->layout.selector_offset,
 887                                     (StgSelector *)selectee);
 888
 889           thunk_selector_depth--;
 890
 891           if (val == NULL) {
 892               break;
 893           } else {
 894               // We evaluated this selector thunk, so update it with
 895               // an indirection.  NOTE: we don't use UPD_IND here,
 896               // because we are guaranteed that p is in a generation
 897               // that we are collecting, and we never want to put the
 898               // indirection on a mutable list.
 899 #ifdef PROFILING
 900               // For the purposes of LDV profiling, we have destroyed
 901               // the original selector thunk.
 902               SET_INFO(p, info_ptr);
 903               LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC(selectee);
 904 #endif
 905               ((StgInd *)selectee)->indirectee = val;
 906               SET_INFO(selectee,&stg_IND_info);
 907
 908               // For the purposes of LDV profiling, we have created an
 909               // indirection.
 910               LDV_RECORD_CREATE(selectee);
 911
 912               selectee = val;
 913               goto selector_loop;
 914           }
 915       }
 916
 917       case AP:
 918       case AP_STACK:
 919       case THUNK:
 920       case THUNK_1_0:
 921       case THUNK_0_1:
 922       case THUNK_2_0:
 923       case THUNK_1_1:
 924       case THUNK_0_2:
 925       case THUNK_STATIC:
 926       case CAF_BLACKHOLE:
 927       case SE_CAF_BLACKHOLE:
 928       case SE_BLACKHOLE:
 929       case BLACKHOLE:
 930 #if defined(PAR)
 931       case RBH:
 932       case BLOCKED_FETCH:
 933 # ifdef DIST
 934       case REMOTE_REF:
 935 # endif
 936       case FETCH_ME:
 937       case FETCH_ME_BQ:
 938 #endif
 939           // not evaluated yet
 940           break;
 941
 942       default:
 943         barf("eval_thunk_selector: strange selectee %d",
 944              (int)(info->type));
 945     }
 946
 947 bale_out:
 948     // We didn't manage to evaluate this thunk; restore the old info pointer
 949     SET_INFO(p, info_ptr);
 950     return NULL;
 951 }
 952
 953 /* -----------------------------------------------------------------------------
 954    move_TSO is called to update the TSO structure after it has been
 955    moved from one place to another.
 956    -------------------------------------------------------------------------- */
 957
 958 void
 959 move_TSO (StgTSO *src, StgTSO *dest)
 960 {
 961     ptrdiff_t diff;
 962
 963     // relocate the stack pointer...
 964     diff = (StgPtr)dest - (StgPtr)src; // In *words*
 965     dest->sp = (StgPtr)dest->sp + diff;
 966 }
 967