X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=rts%2Fsm%2FEvac.c;h=fc344f90fd3d4528c6ec340d27012cbe142bce9d;hb=f7de2e9478d6f43090c8a0b38a4bdb282b001c8f;hp=fb9f4c49b2decb7a3e1833d1d12ae357a4ce2857;hpb=698364afaf2f346227910c0cf8d4f1929cdc56ef;p=ghc-hetmet.git diff --git a/rts/sm/Evac.c b/rts/sm/Evac.c index fb9f4c4..fc344f9 100644 --- a/rts/sm/Evac.c +++ b/rts/sm/Evac.c @@ -25,7 +25,12 @@ */ #define MAX_THUNK_SELECTOR_DEPTH 16 -static StgClosure * eval_thunk_selector (StgSelector * p, rtsBool); +static void eval_thunk_selector (StgClosure **q, StgSelector * p, rtsBool); +STATIC_INLINE void evacuate_large(StgPtr p); + +/* ----------------------------------------------------------------------------- + Allocate some space in which to copy an object. + -------------------------------------------------------------------------- */ STATIC_INLINE StgPtr alloc_for_copy (nat size, step *stp) @@ -39,9 +44,9 @@ alloc_for_copy (nat size, step *stp) * evacuate to an older generation, adjust it here (see comment * by evacuate()). */ - if (stp->gen_no < gct->evac_gen) { + if (stp < gct->evac_step) { if (gct->eager_promotion) { - stp = &generations[gct->evac_gen].steps[0]; + stp = gct->evac_step; } else { gct->failed_to_evac = rtsTrue; } @@ -63,210 +68,15 @@ alloc_for_copy (nat size, step *stp) return to; } -STATIC_INLINE StgPtr -alloc_for_copy_noscav (nat size, step *stp) -{ - StgPtr to; - step_workspace *ws; - bdescr *bd; - - /* Find out where we're going, using the handy "to" pointer in - * the step of the source object. If it turns out we need to - * evacuate to an older generation, adjust it here (see comment - * by evacuate()). - */ - if (stp->gen_no < gct->evac_gen) { - if (gct->eager_promotion) { - stp = &generations[gct->evac_gen].steps[0]; - } else { - gct->failed_to_evac = rtsTrue; - } - } - - ws = &gct->steps[stp->gen_no][stp->no]; - - /* chain a new block onto the to-space for the destination step if - * necessary. - */ - bd = ws->scavd_list; - to = bd->free; - if (to + size >= bd->start + BLOCK_SIZE_W) { - bd = gc_alloc_scavd_block(ws); - to = bd->free; - } - bd->free = to + size; - - return to; -} - -STATIC_INLINE StgClosure * -copy_tag(StgClosure *src, nat size, step *stp,StgWord tag) -{ - StgPtr to, from; - nat i; - StgWord info; - -#ifdef THREADED_RTS - do { - info = xchg((StgPtr)&src->header.info, (W_)&stg_WHITEHOLE_info); - // so.. what is it? - } while (info == (W_)&stg_WHITEHOLE_info); - if (info == (W_)&stg_EVACUATED_info) { - src->header.info = (const StgInfoTable *)info; - return evacuate(src); // does the failed_to_evac stuff - } -#else - info = (W_)src->header.info; - src->header.info = &stg_EVACUATED_info; -#endif - - to = alloc_for_copy(size,stp); - - TICK_GC_WORDS_COPIED(size); - - from = (StgPtr)src; - to[0] = info; - for (i = 1; i < size; i++) { // unroll for small i - to[i] = from[i]; - } - - // retag pointer before updating EVACUATE closure and returning - to = (StgPtr)TAG_CLOSURE(tag,(StgClosure*)to); - -// if (to+size+2 < bd->start + BLOCK_SIZE_W) { -// __builtin_prefetch(to + size + 2, 1); -// } - - ((StgEvacuated*)from)->evacuee = (StgClosure *)to; -#ifdef THREADED_RTS - write_barrier(); - ((StgEvacuated*)from)->header.info = &stg_EVACUATED_info; -#endif - -#ifdef PROFILING - // We store the size of the just evacuated object in the LDV word so that - // the profiler can guess the position of the next object later. - SET_EVACUAEE_FOR_LDV(from, size); -#endif - return (StgClosure *)to; -} - - -// Same as copy() above, except the object will be allocated in memory -// that will not be scavenged. Used for object that have no pointer -// fields. -STATIC_INLINE StgClosure * -copy_noscav_tag(StgClosure *src, nat size, step *stp, StgWord tag) -{ - StgPtr to, from; - nat i; - StgWord info; - -#ifdef THREADED_RTS - do { - info = xchg((StgPtr)&src->header.info, (W_)&stg_WHITEHOLE_info); - } while (info == (W_)&stg_WHITEHOLE_info); - if (info == (W_)&stg_EVACUATED_info) { - src->header.info = (const StgInfoTable *)info; - return evacuate(src); // does the failed_to_evac stuff - } -#else - info = (W_)src->header.info; - src->header.info = &stg_EVACUATED_info; -#endif - - to = alloc_for_copy_noscav(size,stp); - - TICK_GC_WORDS_COPIED(size); - - from = (StgPtr)src; - to[0] = info; - for (i = 1; i < size; i++) { // unroll for small i - to[i] = from[i]; - } - - // retag pointer before updating EVACUATE closure and returning - to = (StgPtr)TAG_CLOSURE(tag,(StgClosure*)to); - - ((StgEvacuated*)from)->evacuee = (StgClosure *)to; -#ifdef THREADED_RTS - write_barrier(); - ((StgEvacuated*)from)->header.info = &stg_EVACUATED_info; -#endif - -#ifdef PROFILING - // We store the size of the just evacuated object in the LDV word so that - // the profiler can guess the position of the next object later. - SET_EVACUAEE_FOR_LDV(from, size); -#endif - return (StgClosure *)to; -} - - -/* Special version of copy() for when we only want to copy the info - * pointer of an object, but reserve some padding after it. This is - * used to optimise evacuation of BLACKHOLEs. - */ -static StgClosure * -copyPart(StgClosure *src, nat size_to_reserve, nat size_to_copy, step *stp) -{ - StgPtr to, from; - nat i; - StgWord info; - -#ifdef THREADED_RTS - do { - info = xchg((StgPtr)&src->header.info, (W_)&stg_WHITEHOLE_info); - } while (info == (W_)&stg_WHITEHOLE_info); - if (info == (W_)&stg_EVACUATED_info) { - src->header.info = (const StgInfoTable *)info; - return evacuate(src); // does the failed_to_evac stuff - } -#else - info = (W_)src->header.info; - src->header.info = &stg_EVACUATED_info; -#endif - - to = alloc_for_copy(size_to_reserve, stp); - - TICK_GC_WORDS_COPIED(size_to_copy); - - from = (StgPtr)src; - to[0] = info; - for (i = 1; i < size_to_copy; i++) { // unroll for small i - to[i] = from[i]; - } - - ((StgEvacuated*)from)->evacuee = (StgClosure *)to; -#ifdef THREADED_RTS - write_barrier(); - ((StgEvacuated*)from)->header.info = &stg_EVACUATED_info; -#endif - -#ifdef PROFILING - // We store the size of the just evacuated object in the LDV word so that - // the profiler can guess the position of the next object later. - SET_EVACUAEE_FOR_LDV(from, size_to_reserve); - // fill the slop - if (size_to_reserve - size_to_copy > 0) - LDV_FILL_SLOP(to + size_to_copy - 1, (int)(size_to_reserve - size_to_copy)); -#endif - return (StgClosure *)to; -} - +/* ----------------------------------------------------------------------------- + The evacuate() code + -------------------------------------------------------------------------- */ -/* Copy wrappers that don't tag the closure after copying */ -STATIC_INLINE StgClosure * -copy(StgClosure *src, nat size, step *stp) -{ - return copy_tag(src,size,stp,0); -} +#define MINOR_GC +#include "Evac.c-inc" -STATIC_INLINE StgClosure * -copy_noscav(StgClosure *src, nat size, step *stp) -{ - return copy_noscav_tag(src,size,stp,0); -} +#undef MINOR_GC +#include "Evac.c-inc" /* ----------------------------------------------------------------------------- Evacuate a large object @@ -279,7 +89,6 @@ copy_noscav(StgClosure *src, nat size, step *stp) that has been evacuated, or unset otherwise. -------------------------------------------------------------------------- */ - STATIC_INLINE void evacuate_large(StgPtr p) { @@ -296,7 +105,7 @@ evacuate_large(StgPtr p) /* Don't forget to set the gct->failed_to_evac flag if we didn't get * the desired destination (see comments in evacuate()). */ - if (bd->gen_no < gct->evac_gen) { + if (bd->step < gct->evac_step) { gct->failed_to_evac = rtsTrue; TICK_GC_FAILED_PROMOTION(); } @@ -320,9 +129,9 @@ evacuate_large(StgPtr p) /* link it on to the evacuated large object list of the destination step */ stp = bd->step->to; - if (stp->gen_no < gct->evac_gen) { + if (stp < gct->evac_step) { if (gct->eager_promotion) { - stp = &generations[gct->evac_gen].steps[0]; + stp = gct->evac_step; } else { gct->failed_to_evac = rtsTrue; } @@ -337,403 +146,16 @@ evacuate_large(StgPtr p) } /* ----------------------------------------------------------------------------- - Evacuate - - This is called (eventually) for every live object in the system. - - The caller to evacuate specifies a desired generation in the - gct->evac_gen thread-lock variable. The following conditions apply to - evacuating an object which resides in generation M when we're - collecting up to generation N - - if M >= gct->evac_gen - if M > N do nothing - else evac to step->to - - if M < gct->evac_gen evac to gct->evac_gen, step 0 - - if the object is already evacuated, then we check which generation - it now resides in. - - if M >= gct->evac_gen do nothing - if M < gct->evac_gen set gct->failed_to_evac flag to indicate that we - didn't manage to evacuate this object into gct->evac_gen. - - - OPTIMISATION NOTES: + Evaluate a THUNK_SELECTOR if possible. - evacuate() is the single most important function performance-wise - in the GC. Various things have been tried to speed it up, but as - far as I can tell the code generated by gcc 3.2 with -O2 is about - as good as it's going to get. We pass the argument to evacuate() - in a register using the 'regparm' attribute (see the prototype for - evacuate() near the top of this file). + p points to a THUNK_SELECTOR that we want to evaluate. The + result of "evaluating" it will be evacuated and a pointer to the + to-space closure will be returned. - Changing evacuate() to take an (StgClosure **) rather than - returning the new pointer seems attractive, because we can avoid - writing back the pointer when it hasn't changed (eg. for a static - object, or an object in a generation > N). However, I tried it and - it doesn't help. One reason is that the (StgClosure **) pointer - gets spilled to the stack inside evacuate(), resulting in far more - extra reads/writes than we save. + If the THUNK_SELECTOR could not be evaluated (its selectee is still + a THUNK, for example), then the THUNK_SELECTOR itself will be + evacuated. -------------------------------------------------------------------------- */ - -REGPARM1 StgClosure * -evacuate(StgClosure *q) -{ - bdescr *bd = NULL; - step *stp; - const StgInfoTable *info; - StgWord tag; - -loop: - /* The tag and the pointer are split, to be merged after evacing */ - tag = GET_CLOSURE_TAG(q); - q = UNTAG_CLOSURE(q); - - ASSERT(LOOKS_LIKE_CLOSURE_PTR(q)); - - if (!HEAP_ALLOCED(q)) { - - if (!major_gc) return TAG_CLOSURE(tag,q); - - info = get_itbl(q); - switch (info->type) { - - case THUNK_STATIC: - if (info->srt_bitmap != 0 && - *THUNK_STATIC_LINK((StgClosure *)q) == NULL) { - ACQUIRE_SPIN_LOCK(&static_objects_sync); - if (*THUNK_STATIC_LINK((StgClosure *)q) == NULL) { - *THUNK_STATIC_LINK((StgClosure *)q) = static_objects; - static_objects = (StgClosure *)q; - } - RELEASE_SPIN_LOCK(&static_objects_sync); - } - return q; - - case FUN_STATIC: - if (info->srt_bitmap != 0 && - *FUN_STATIC_LINK((StgClosure *)q) == NULL) { - ACQUIRE_SPIN_LOCK(&static_objects_sync); - if (*FUN_STATIC_LINK((StgClosure *)q) == NULL) { - *FUN_STATIC_LINK((StgClosure *)q) = static_objects; - static_objects = (StgClosure *)q; - } - RELEASE_SPIN_LOCK(&static_objects_sync); - } - return q; - - case IND_STATIC: - /* If q->saved_info != NULL, then it's a revertible CAF - it'll be - * on the CAF list, so don't do anything with it here (we'll - * scavenge it later). - */ - if (((StgIndStatic *)q)->saved_info == NULL) { - ACQUIRE_SPIN_LOCK(&static_objects_sync); - if (*IND_STATIC_LINK((StgClosure *)q) == NULL) { - *IND_STATIC_LINK((StgClosure *)q) = static_objects; - static_objects = (StgClosure *)q; - } - RELEASE_SPIN_LOCK(&static_objects_sync); - } - return q; - - case CONSTR_STATIC: - if (*STATIC_LINK(info,(StgClosure *)q) == NULL) { - ACQUIRE_SPIN_LOCK(&static_objects_sync); - // re-test, after acquiring lock - if (*STATIC_LINK(info,(StgClosure *)q) == NULL) { - *STATIC_LINK(info,(StgClosure *)q) = static_objects; - static_objects = (StgClosure *)q; - } - RELEASE_SPIN_LOCK(&static_objects_sync); - /* I am assuming that static_objects pointers are not - * written to other objects, and thus, no need to retag. */ - } - return TAG_CLOSURE(tag,q); - - case CONSTR_NOCAF_STATIC: - /* no need to put these on the static linked list, they don't need - * to be scavenged. - */ - return TAG_CLOSURE(tag,q); - - default: - barf("evacuate(static): strange closure type %d", (int)(info->type)); - } - } - - bd = Bdescr((P_)q); - - if (bd->gen_no > N) { - /* Can't evacuate this object, because it's in a generation - * older than the ones we're collecting. Let's hope that it's - * in gct->evac_gen or older, or we will have to arrange to track - * this pointer using the mutable list. - */ - if (bd->gen_no < gct->evac_gen) { - // nope - gct->failed_to_evac = rtsTrue; - TICK_GC_FAILED_PROMOTION(); - } - return TAG_CLOSURE(tag,q); - } - - if ((bd->flags & (BF_LARGE | BF_COMPACTED | BF_EVACUATED)) != 0) { - - /* pointer into to-space: just return it. This normally - * shouldn't happen, but alllowing it makes certain things - * slightly easier (eg. the mutable list can contain the same - * object twice, for example). - */ - if (bd->flags & BF_EVACUATED) { - if (bd->gen_no < gct->evac_gen) { - gct->failed_to_evac = rtsTrue; - TICK_GC_FAILED_PROMOTION(); - } - return TAG_CLOSURE(tag,q); - } - - /* evacuate large objects by re-linking them onto a different list. - */ - if (bd->flags & BF_LARGE) { - info = get_itbl(q); - if (info->type == TSO && - ((StgTSO *)q)->what_next == ThreadRelocated) { - q = (StgClosure *)((StgTSO *)q)->link; - goto loop; - } - evacuate_large((P_)q); - return TAG_CLOSURE(tag,q); - } - - /* If the object is in a step that we're compacting, then we - * need to use an alternative evacuate procedure. - */ - if (bd->flags & BF_COMPACTED) { - if (!is_marked((P_)q,bd)) { - mark((P_)q,bd); - if (mark_stack_full()) { - mark_stack_overflowed = rtsTrue; - reset_mark_stack(); - } - push_mark_stack((P_)q); - } - return TAG_CLOSURE(tag,q); - } - } - - stp = bd->step->to; - - info = get_itbl(q); - - switch (info->type) { - - case WHITEHOLE: - goto loop; - - case MUT_VAR_CLEAN: - case MUT_VAR_DIRTY: - case MVAR_CLEAN: - case MVAR_DIRTY: - return copy(q,sizeW_fromITBL(info),stp); - - case CONSTR_0_1: - { - StgWord w = (StgWord)q->payload[0]; - if (q->header.info == Czh_con_info && - // unsigned, so always true: (StgChar)w >= MIN_CHARLIKE && - (StgChar)w <= MAX_CHARLIKE) { - return TAG_CLOSURE(tag, - (StgClosure *)CHARLIKE_CLOSURE((StgChar)w) - ); - } - if (q->header.info == Izh_con_info && - (StgInt)w >= MIN_INTLIKE && (StgInt)w <= MAX_INTLIKE) { - return TAG_CLOSURE(tag, - (StgClosure *)INTLIKE_CLOSURE((StgInt)w) - ); - } - // else - return copy_noscav_tag(q,sizeofW(StgHeader)+1,stp,tag); - } - - case FUN_0_1: - case FUN_1_0: - case CONSTR_1_0: - return copy_tag(q,sizeofW(StgHeader)+1,stp,tag); - - case THUNK_1_0: - case THUNK_0_1: - return copy(q,sizeofW(StgThunk)+1,stp); - - case THUNK_1_1: - case THUNK_2_0: - case THUNK_0_2: -#ifdef NO_PROMOTE_THUNKS - if (bd->gen_no == 0 && - bd->step->no != 0 && - bd->step->no == generations[bd->gen_no].n_steps-1) { - stp = bd->step; - } -#endif - return copy(q,sizeofW(StgThunk)+2,stp); - - case FUN_1_1: - case FUN_2_0: - case FUN_0_2: - case CONSTR_1_1: - case CONSTR_2_0: - return copy_tag(q,sizeofW(StgHeader)+2,stp,tag); - - case CONSTR_0_2: - return copy_noscav_tag(q,sizeofW(StgHeader)+2,stp,tag); - - case THUNK: - return copy(q,thunk_sizeW_fromITBL(info),stp); - - case FUN: - case IND_PERM: - case IND_OLDGEN_PERM: - case WEAK: - case STABLE_NAME: - case CONSTR: - return copy_tag(q,sizeW_fromITBL(info),stp,tag); - - case BCO: - return copy(q,bco_sizeW((StgBCO *)q),stp); - - case CAF_BLACKHOLE: - case SE_CAF_BLACKHOLE: - case SE_BLACKHOLE: - case BLACKHOLE: - return copyPart(q,BLACKHOLE_sizeW(),sizeofW(StgHeader),stp); - - case THUNK_SELECTOR: - return eval_thunk_selector((StgSelector *)q, rtsTrue); - - case IND: - case IND_OLDGEN: - // follow chains of indirections, don't evacuate them - q = ((StgInd*)q)->indirectee; - goto loop; - - case RET_BCO: - case RET_SMALL: - case RET_BIG: - case RET_DYN: - case UPDATE_FRAME: - case STOP_FRAME: - case CATCH_FRAME: - case CATCH_STM_FRAME: - case CATCH_RETRY_FRAME: - case ATOMICALLY_FRAME: - // shouldn't see these - barf("evacuate: stack frame at %p\n", q); - - case PAP: - return copy(q,pap_sizeW((StgPAP*)q),stp); - - case AP: - return copy(q,ap_sizeW((StgAP*)q),stp); - - case AP_STACK: - return copy(q,ap_stack_sizeW((StgAP_STACK*)q),stp); - - case EVACUATED: - /* Already evacuated, just return the forwarding address. - * HOWEVER: if the requested destination generation (gct->evac_gen) is - * older than the actual generation (because the object was - * already evacuated to a younger generation) then we have to - * set the gct->failed_to_evac flag to indicate that we couldn't - * manage to promote the object to the desired generation. - */ - /* - * Optimisation: the check is fairly expensive, but we can often - * shortcut it if either the required generation is 0, or the - * current object (the EVACUATED) is in a high enough generation. - * We know that an EVACUATED always points to an object in the - * same or an older generation. stp is the lowest step that the - * current object would be evacuated to, so we only do the full - * check if stp is too low. - */ - if (gct->evac_gen > 0 && stp->gen_no < gct->evac_gen) { // optimisation - StgClosure *p = ((StgEvacuated*)q)->evacuee; - if (HEAP_ALLOCED(p) && Bdescr((P_)p)->gen_no < gct->evac_gen) { - gct->failed_to_evac = rtsTrue; - TICK_GC_FAILED_PROMOTION(); - } - } - return ((StgEvacuated*)q)->evacuee; - - case ARR_WORDS: - // just copy the block - return copy_noscav(q,arr_words_sizeW((StgArrWords *)q),stp); - - case MUT_ARR_PTRS_CLEAN: - case MUT_ARR_PTRS_DIRTY: - case MUT_ARR_PTRS_FROZEN: - case MUT_ARR_PTRS_FROZEN0: - // just copy the block - return copy(q,mut_arr_ptrs_sizeW((StgMutArrPtrs *)q),stp); - - case TSO: - { - StgTSO *tso = (StgTSO *)q; - - /* Deal with redirected TSOs (a TSO that's had its stack enlarged). - */ - if (tso->what_next == ThreadRelocated) { - q = (StgClosure *)tso->link; - goto loop; - } - - /* To evacuate a small TSO, we need to relocate the update frame - * list it contains. - */ - { - StgTSO *new_tso; - StgPtr p, q; - - new_tso = (StgTSO *)copyPart((StgClosure *)tso, - tso_sizeW(tso), - sizeofW(StgTSO), stp); - move_TSO(tso, new_tso); - for (p = tso->sp, q = new_tso->sp; - p < tso->stack+tso->stack_size;) { - *q++ = *p++; - } - - return (StgClosure *)new_tso; - } - } - - case TREC_HEADER: - return copy(q,sizeofW(StgTRecHeader),stp); - - case TVAR_WATCH_QUEUE: - return copy(q,sizeofW(StgTVarWatchQueue),stp); - - case TVAR: - return copy(q,sizeofW(StgTVar),stp); - - case TREC_CHUNK: - return copy(q,sizeofW(StgTRecChunk),stp); - - case ATOMIC_INVARIANT: - return copy(q,sizeofW(StgAtomicInvariant),stp); - - case INVARIANT_CHECK_QUEUE: - return copy(q,sizeofW(StgInvariantCheckQueue),stp); - - default: - barf("evacuate: strange closure type %d", (int)(info->type)); - } - - barf("evacuate"); -} - static void unchain_thunk_selectors(StgSelector *p, StgClosure *val) { @@ -762,24 +184,13 @@ unchain_thunk_selectors(StgSelector *p, StgClosure *val) } } -/* ----------------------------------------------------------------------------- - Evaluate a THUNK_SELECTOR if possible. - - p points to a THUNK_SELECTOR that we want to evaluate. The - result of "evaluating" it will be evacuated and a pointer to the - to-space closure will be returned. - - If the THUNK_SELECTOR could not be evaluated (its selectee is still - a THUNK, for example), then the THUNK_SELECTOR itself will be - evacuated. - -------------------------------------------------------------------------- */ - -static StgClosure * -eval_thunk_selector (StgSelector * p, rtsBool evac) +static void +eval_thunk_selector (StgClosure **q, StgSelector * p, rtsBool evac) + // NB. for legacy reasons, p & q are swapped around :( { nat field; StgInfoTable *info; - const StgInfoTable *info_ptr; + StgWord info_ptr; StgClosure *selectee; StgSelector *prev_thunk_selector; bdescr *bd; @@ -793,14 +204,6 @@ eval_thunk_selector (StgSelector * p, rtsBool evac) selector_chain: - // The selectee might be a constructor closure, - // so we untag the pointer. - selectee = UNTAG_CLOSURE(p->selectee); - - // Save the real info pointer (NOTE: not the same as get_itbl()). - info_ptr = p->header.info; - field = get_itbl(p)->layout.selector_offset; - bd = Bdescr((StgPtr)p); if (HEAP_ALLOCED(p)) { // If the THUNK_SELECTOR is in to-space or in a generation that we @@ -810,7 +213,8 @@ selector_chain: // mutable list. if ((bd->gen_no > N) || (bd->flags & BF_EVACUATED)) { unchain_thunk_selectors(prev_thunk_selector, (StgClosure *)p); - return (StgClosure *)p; + *q = (StgClosure *)p; + return; } // we don't update THUNK_SELECTORS in the compacted // generation, because compaction does not remove the INDs @@ -820,16 +224,44 @@ selector_chain: // around here, test by compiling stage 3 with +RTS -c -RTS. if (bd->flags & BF_COMPACTED) { // must call evacuate() to mark this closure if evac==rtsTrue - if (evac) p = (StgSelector *)evacuate((StgClosure *)p); + *q = (StgClosure *)p; + if (evac) evacuate(q); unchain_thunk_selectors(prev_thunk_selector, (StgClosure *)p); - return (StgClosure *)p; + return; } } + // BLACKHOLE the selector thunk, since it is now under evaluation. // This is important to stop us going into an infinite loop if // this selector thunk eventually refers to itself. +#if defined(THREADED_RTS) + // In threaded mode, we'll use WHITEHOLE to lock the selector + // thunk while we evaluate it. + { + info_ptr = xchg((StgPtr)&p->header.info, (W_)&stg_WHITEHOLE_info); + if (info_ptr == (W_)&stg_WHITEHOLE_info) { + do { + info_ptr = xchg((StgPtr)&p->header.info, (W_)&stg_WHITEHOLE_info); + } while (info_ptr == (W_)&stg_WHITEHOLE_info); + goto bale_out; + } + // make sure someone else didn't get here first + if (INFO_PTR_TO_STRUCT(info_ptr)->type != THUNK_SELECTOR) { + goto bale_out; + } + } +#else + // Save the real info pointer (NOTE: not the same as get_itbl()). + info_ptr = (StgWord)p->header.info; SET_INFO(p,&stg_BLACKHOLE_info); +#endif + + field = INFO_PTR_TO_STRUCT(info_ptr)->layout.selector_offset; + + // The selectee might be a constructor closure, + // so we untag the pointer. + selectee = UNTAG_CLOSURE(p->selectee); selector_loop: // selectee now points to the closure that we're trying to select @@ -841,6 +273,9 @@ selector_loop: info = get_itbl(selectee); switch (info->type) { + case WHITEHOLE: + goto bale_out; // about to be evacuated by another thread (or a loop). + case CONSTR: case CONSTR_1_0: case CONSTR_0_1: @@ -860,7 +295,7 @@ selector_loop: #ifdef PROFILING // For the purposes of LDV profiling, we have destroyed // the original selector thunk, p. - SET_INFO(p, info_ptr); + SET_INFO(p, (StgInfoTable *)info_ptr); LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC((StgClosure *)p); SET_INFO(p, &stg_BLACKHOLE_info); #endif @@ -889,12 +324,14 @@ selector_loop: ((StgClosure*)p)->payload[0] = (StgClosure *)prev_thunk_selector; prev_thunk_selector = p; - if (evac) val = evacuate(val); + *q = val; + if (evac) evacuate(q); + val = *q; // evacuate() cannot recurse through // eval_thunk_selector(), because we know val is not // a THUNK_SELECTOR. unchain_thunk_selectors(prev_thunk_selector, val); - return val; + return; } } @@ -927,7 +364,7 @@ selector_loop: // rtsFalse says "don't evacuate the result". It will, // however, update any THUNK_SELECTORs that are evaluated // along the way. - val = eval_thunk_selector((StgSelector *)selectee, rtsFalse); + eval_thunk_selector(&val, (StgSelector*)selectee, rtsFalse); gct->thunk_selector_depth--; // did we actually manage to evaluate it? @@ -962,14 +399,15 @@ selector_loop: bale_out: // We didn't manage to evaluate this thunk; restore the old info // pointer. But don't forget: we still need to evacuate the thunk itself. - SET_INFO(p, info_ptr); + SET_INFO(p, (const StgInfoTable *)info_ptr); if (evac) { - val = copy((StgClosure *)p,THUNK_SELECTOR_sizeW(),bd->step->to); + copy(&val,(StgClosure *)p,THUNK_SELECTOR_sizeW(),bd->step->to); } else { val = (StgClosure *)p; } + *q = val; unchain_thunk_selectors(prev_thunk_selector, val); - return val; + return; } /* -----------------------------------------------------------------------------