X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=rts%2Fsm%2FEvac.c;h=fdb5477a3801d5996222256784f82e9fe9f405ac;hp=3b68c6201637aae679b9db8839896a5b5aa8acfc;hb=1fb38442d3a55ac92795aa6c5ed4df82011df724;hpb=74ee9df9f9e79e7110e9d8541b84010f35c464c5 diff --git a/rts/sm/Evac.c b/rts/sm/Evac.c index 3b68c62..fdb5477 100644 --- a/rts/sm/Evac.c +++ b/rts/sm/Evac.c @@ -11,17 +11,20 @@ * * ---------------------------------------------------------------------------*/ +#include "PosixSource.h" #include "Rts.h" -#include "Storage.h" -#include "MBlock.h" + #include "Evac.h" +#include "Storage.h" #include "GC.h" #include "GCThread.h" +#include "GCTDecl.h" #include "GCUtils.h" #include "Compact.h" +#include "MarkStack.h" #include "Prelude.h" -#include "LdvProfile.h" #include "Trace.h" +#include "LdvProfile.h" #if defined(PROF_SPIN) && defined(THREADED_RTS) && defined(PARALLEL_GC) StgWord64 whitehole_spin = 0; @@ -29,6 +32,7 @@ StgWord64 whitehole_spin = 0; #if defined(THREADED_RTS) && !defined(PARALLEL_GC) #define evacuate(p) evacuate1(p) +#define HEAP_ALLOCED_GC(p) HEAP_ALLOCED(p) #endif #if !defined(PARALLEL_GC) @@ -48,35 +52,34 @@ STATIC_INLINE void evacuate_large(StgPtr p); -------------------------------------------------------------------------- */ STATIC_INLINE StgPtr -alloc_for_copy (nat size, step *stp) +alloc_for_copy (nat size, nat gen_no) { StgPtr to; - step_workspace *ws; + gen_workspace *ws; /* 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 + * the gen 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 < gct->evac_step) { + if (gen_no < gct->evac_gen_no) { if (gct->eager_promotion) { - stp = gct->evac_step; + gen_no = gct->evac_gen_no; } else { gct->failed_to_evac = rtsTrue; } } - ws = &gct->steps[stp->abs_no]; - // this compiles to a single mem access to stp->abs_no only - - /* chain a new block onto the to-space for the destination step if + ws = &gct->gens[gen_no]; // zero memory references here + + /* chain a new block onto the to-space for the destination gen if * necessary. */ to = ws->todo_free; - if (to + size > ws->todo_lim) { + ws->todo_free += size; + if (ws->todo_free > ws->todo_lim) { to = todo_block_full(size, ws); } - ws->todo_free = to + size; ASSERT(ws->todo_free >= ws->todo_bd->free && ws->todo_free <= ws->todo_lim); return to; @@ -86,17 +89,15 @@ alloc_for_copy (nat size, step *stp) The evacuate() code -------------------------------------------------------------------------- */ -STATIC_INLINE void +STATIC_INLINE GNUC_ATTR_HOT void copy_tag(StgClosure **p, const StgInfoTable *info, - StgClosure *src, nat size, step *stp, StgWord tag) + StgClosure *src, nat size, nat gen_no, StgWord tag) { StgPtr to, from; nat i; - to = alloc_for_copy(size,stp); + to = alloc_for_copy(size,gen_no); - TICK_GC_WORDS_COPIED(size); - from = (StgPtr)src; to[0] = (W_)info; for (i = 1; i < size; i++) { // unroll for small i @@ -132,16 +133,12 @@ copy_tag(StgClosure **p, const StgInfoTable *info, #if defined(PARALLEL_GC) STATIC_INLINE void copy_tag_nolock(StgClosure **p, const StgInfoTable *info, - StgClosure *src, nat size, step *stp, StgWord tag) + StgClosure *src, nat size, nat gen_no, StgWord tag) { StgPtr to, from; nat i; - to = alloc_for_copy(size,stp); - *p = TAG_CLOSURE(tag,(StgClosure*)to); - src->header.info = (const StgInfoTable *)MK_FORWARDING_PTR(to); - - TICK_GC_WORDS_COPIED(size); + to = alloc_for_copy(size,gen_no); from = (StgPtr)src; to[0] = (W_)info; @@ -149,6 +146,12 @@ copy_tag_nolock(StgClosure **p, const StgInfoTable *info, to[i] = from[i]; } + // if somebody else reads the forwarding pointer, we better make + // sure there's a closure at the end of it. + write_barrier(); + *p = TAG_CLOSURE(tag,(StgClosure*)to); + src->header.info = (const StgInfoTable *)MK_FORWARDING_PTR(to); + // if (to+size+2 < bd->start + BLOCK_SIZE_W) { // __builtin_prefetch(to + size + 2, 1); // } @@ -163,10 +166,11 @@ copy_tag_nolock(StgClosure **p, const StgInfoTable *info, /* 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. + * used to optimise evacuation of TSOs. */ -static void -copyPart(StgClosure **p, StgClosure *src, nat size_to_reserve, nat size_to_copy, step *stp) +static rtsBool +copyPart(StgClosure **p, StgClosure *src, nat size_to_reserve, + nat size_to_copy, nat gen_no) { StgPtr to, from; nat i; @@ -184,16 +188,13 @@ spin: if (IS_FORWARDING_PTR(info)) { src->header.info = (const StgInfoTable *)info; evacuate(p); // does the failed_to_evac stuff - return ; + return rtsFalse; } #else info = (W_)src->header.info; #endif - to = alloc_for_copy(size_to_reserve, stp); - *p = (StgClosure *)to; - - TICK_GC_WORDS_COPIED(size_to_copy); + to = alloc_for_copy(size_to_reserve, gen_no); from = (StgPtr)src; to[0] = info; @@ -201,10 +202,9 @@ spin: to[i] = from[i]; } -#if defined(PARALLEL_GC) write_barrier(); -#endif src->header.info = (const StgInfoTable*)MK_FORWARDING_PTR(to); + *p = (StgClosure *)to; #ifdef PROFILING // We store the size of the just evacuated object in the LDV word so that @@ -212,17 +212,102 @@ spin: 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)); + LDV_FILL_SLOP(to + size_to_copy, (int)(size_to_reserve - size_to_copy)); #endif + + return rtsTrue; } /* Copy wrappers that don't tag the closure after copying */ -STATIC_INLINE void +STATIC_INLINE GNUC_ATTR_HOT void copy(StgClosure **p, const StgInfoTable *info, - StgClosure *src, nat size, step *stp) + StgClosure *src, nat size, nat gen_no) +{ + copy_tag(p,info,src,size,gen_no,0); +} + +/* ----------------------------------------------------------------------------- + Evacuate a large object + + This just consists of removing the object from the (doubly-linked) + gen->large_objects list, and linking it on to the (singly-linked) + gen->new_large_objects list, from where it will be scavenged later. + + Convention: bd->flags has BF_EVACUATED set for a large object + that has been evacuated, or unset otherwise. + -------------------------------------------------------------------------- */ + +STATIC_INLINE void +evacuate_large(StgPtr p) { - copy_tag(p,info,src,size,stp,0); + bdescr *bd; + generation *gen, *new_gen; + nat gen_no, new_gen_no; + gen_workspace *ws; + + bd = Bdescr(p); + gen = bd->gen; + gen_no = bd->gen_no; + ACQUIRE_SPIN_LOCK(&gen->sync); + + // already evacuated? + if (bd->flags & BF_EVACUATED) { + /* Don't forget to set the gct->failed_to_evac flag if we didn't get + * the desired destination (see comments in evacuate()). + */ + if (gen_no < gct->evac_gen_no) { + gct->failed_to_evac = rtsTrue; + TICK_GC_FAILED_PROMOTION(); + } + RELEASE_SPIN_LOCK(&gen->sync); + return; + } + + // remove from large_object list + if (bd->u.back) { + bd->u.back->link = bd->link; + } else { // first object in the list + gen->large_objects = bd->link; + } + if (bd->link) { + bd->link->u.back = bd->u.back; + } + + /* link it on to the evacuated large object list of the destination gen + */ + new_gen_no = bd->dest_no; + + if (new_gen_no < gct->evac_gen_no) { + if (gct->eager_promotion) { + new_gen_no = gct->evac_gen_no; + } else { + gct->failed_to_evac = rtsTrue; + } + } + + ws = &gct->gens[new_gen_no]; + new_gen = &generations[new_gen_no]; + + bd->flags |= BF_EVACUATED; + initBdescr(bd, new_gen, new_gen->to); + + // If this is a block of pinned objects, we don't have to scan + // these objects, because they aren't allowed to contain any + // pointers. For these blocks, we skip the scavenge stage and put + // them straight on the scavenged_large_objects list. + if (bd->flags & BF_PINNED) { + ASSERT(get_itbl((StgClosure *)p)->type == ARR_WORDS); + if (new_gen != gen) { ACQUIRE_SPIN_LOCK(&new_gen->sync); } + dbl_link_onto(bd, &new_gen->scavenged_large_objects); + new_gen->n_scavenged_large_blocks += bd->blocks; + if (new_gen != gen) { RELEASE_SPIN_LOCK(&new_gen->sync); } + } else { + bd->link = ws->todo_large_objects; + ws->todo_large_objects = bd; + } + + RELEASE_SPIN_LOCK(&gen->sync); } /* ---------------------------------------------------------------------------- @@ -231,22 +316,22 @@ copy(StgClosure **p, const StgInfoTable *info, This is called (eventually) for every live object in the system. The caller to evacuate specifies a desired generation in the - gct->evac_step thread-local variable. The following conditions apply to + gct->evac_gen thread-local 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_step + if M >= gct->evac_gen if M > N do nothing - else evac to step->to + else evac to gen->to - if M < gct->evac_step evac to gct->evac_step, step 0 + 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_step do nothing - if M < gct->evac_step set gct->failed_to_evac flag to indicate that we - didn't manage to evacuate this object into gct->evac_step. + 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: @@ -267,11 +352,11 @@ copy(StgClosure **p, const StgInfoTable *info, extra reads/writes than we save. ------------------------------------------------------------------------- */ -REGPARM1 void +REGPARM1 GNUC_ATTR_HOT void evacuate(StgClosure **p) { bdescr *bd = NULL; - step *stp; + nat gen_no; StgClosure *q; const StgInfoTable *info; StgWord tag; @@ -283,9 +368,9 @@ loop: tag = GET_CLOSURE_TAG(q); q = UNTAG_CLOSURE(q); - ASSERT(LOOKS_LIKE_CLOSURE_PTR(q)); + ASSERTM(LOOKS_LIKE_CLOSURE_PTR(q), "invalid closure, info=%p", q->header.info); - if (!HEAP_ALLOCED(q)) { + if (!HEAP_ALLOCED_GC(q)) { if (!major_gc) return; @@ -334,8 +419,7 @@ loop: * on the CAF list, so don't do anything with it here (we'll * scavenge it later). */ - if (((StgIndStatic *)q)->saved_info == NULL) { - if (*IND_STATIC_LINK((StgClosure *)q) == NULL) { + if (*IND_STATIC_LINK((StgClosure *)q) == NULL) { #ifndef THREADED_RTS *IND_STATIC_LINK((StgClosure *)q) = gct->static_objects; gct->static_objects = (StgClosure *)q; @@ -348,7 +432,6 @@ loop: gct->static_objects = (StgClosure *)q; } #endif - } } return; @@ -396,7 +479,7 @@ loop: // We aren't copying this object, so we have to check // whether it is already in the target generation. (this is // the write barrier). - if (bd->step < gct->evac_step) { + if (bd->gen_no < gct->evac_gen_no) { gct->failed_to_evac = rtsTrue; TICK_GC_FAILED_PROMOTION(); } @@ -406,39 +489,27 @@ loop: /* 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; - *p = q; - goto loop; - } - evacuate_large((P_)q); + evacuate_large((P_)q); return; } - /* If the object is in a step that we're compacting, then we + /* If the object is in a gen that we're compacting, then we * need to use an alternative evacuate procedure. */ if (!is_marked((P_)q,bd)) { mark((P_)q,bd); - if (mark_stack_full()) { - debugTrace(DEBUG_gc,"mark stack overflowed"); - mark_stack_overflowed = rtsTrue; - reset_mark_stack(); - } push_mark_stack((P_)q); } return; } - stp = bd->step->to; + gen_no = bd->dest_no; info = q->header.info; if (IS_FORWARDING_PTR(info)) { /* Already evacuated, just return the forwarding address. - * HOWEVER: if the requested destination generation (gct->evac_step) is + * 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 @@ -449,14 +520,14 @@ loop: * 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 + * same or an older generation. gen is the lowest generation that the * current object would be evacuated to, so we only do the full - * check if stp is too low. + * check if gen is too low. */ StgClosure *e = (StgClosure*)UN_FORWARDING_PTR(info); *p = TAG_CLOSURE(tag,e); - if (stp < gct->evac_step) { // optimisation - if (Bdescr((P_)e)->step < gct->evac_step) { + if (gen_no < gct->evac_gen_no) { // optimisation + if (Bdescr((P_)e)->gen_no < gct->evac_gen_no) { gct->failed_to_evac = rtsTrue; TICK_GC_FAILED_PROMOTION(); } @@ -473,11 +544,20 @@ loop: case MUT_VAR_DIRTY: case MVAR_CLEAN: case MVAR_DIRTY: - copy(p,info,q,sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),stp); + copy(p,info,q,sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),gen_no); return; + // For ints and chars of low value, save space by replacing references to + // these with closures with references to common, shared ones in the RTS. + // + // * Except when compiling into Windows DLLs which don't support cross-package + // data references very well. + // case CONSTR_0_1: - { + { +#if defined(__PIC__) && defined(mingw32_HOST_OS) + copy_tag_nolock(p,info,q,sizeofW(StgHeader)+1,gen_no,tag); +#else StgWord w = (StgWord)q->payload[0]; if (info == Czh_con_info && // unsigned, so always true: (StgChar)w >= MIN_CHARLIKE && @@ -493,33 +573,30 @@ loop: ); } else { - copy_tag_nolock(p,info,q,sizeofW(StgHeader)+1,stp,tag); + copy_tag_nolock(p,info,q,sizeofW(StgHeader)+1,gen_no,tag); } +#endif return; } case FUN_0_1: case FUN_1_0: case CONSTR_1_0: - copy_tag_nolock(p,info,q,sizeofW(StgHeader)+1,stp,tag); + copy_tag_nolock(p,info,q,sizeofW(StgHeader)+1,gen_no,tag); return; case THUNK_1_0: case THUNK_0_1: - copy(p,info,q,sizeofW(StgThunk)+1,stp); + copy(p,info,q,sizeofW(StgThunk)+1,gen_no); return; 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; - } +#error bitrotted #endif - copy(p,info,q,sizeofW(StgThunk)+2,stp); + copy(p,info,q,sizeofW(StgThunk)+2,gen_no); return; case FUN_1_1: @@ -527,38 +604,57 @@ loop: case FUN_0_2: case CONSTR_1_1: case CONSTR_2_0: - copy_tag_nolock(p,info,q,sizeofW(StgHeader)+2,stp,tag); + copy_tag_nolock(p,info,q,sizeofW(StgHeader)+2,gen_no,tag); return; case CONSTR_0_2: - copy_tag_nolock(p,info,q,sizeofW(StgHeader)+2,stp,tag); + copy_tag_nolock(p,info,q,sizeofW(StgHeader)+2,gen_no,tag); return; case THUNK: - copy(p,info,q,thunk_sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),stp); + copy(p,info,q,thunk_sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),gen_no); return; case FUN: case IND_PERM: - case IND_OLDGEN_PERM: case CONSTR: - copy_tag_nolock(p,info,q,sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),stp,tag); + copy_tag_nolock(p,info,q,sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),gen_no,tag); return; + case BLACKHOLE: + { + StgClosure *r; + const StgInfoTable *i; + r = ((StgInd*)q)->indirectee; + if (GET_CLOSURE_TAG(r) == 0) { + i = r->header.info; + if (IS_FORWARDING_PTR(i)) { + r = (StgClosure *)UN_FORWARDING_PTR(i); + i = r->header.info; + } + if (i == &stg_TSO_info + || i == &stg_WHITEHOLE_info + || i == &stg_BLOCKING_QUEUE_CLEAN_info + || i == &stg_BLOCKING_QUEUE_DIRTY_info) { + copy(p,info,q,sizeofW(StgInd),gen_no); + return; + } + ASSERT(i != &stg_IND_info); + } + q = r; + *p = r; + goto loop; + } + + case BLOCKING_QUEUE: case WEAK: - case STABLE_NAME: - copy_tag(p,info,q,sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),stp,tag); + case PRIM: + case MUT_PRIM: + copy(p,info,q,sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),gen_no); return; case BCO: - copy(p,info,q,bco_sizeW((StgBCO *)q),stp); - return; - - case CAF_BLACKHOLE: - case SE_CAF_BLACKHOLE: - case SE_BLACKHOLE: - case BLACKHOLE: - copyPart(p,q,BLACKHOLE_sizeW(),sizeofW(StgHeader),stp); + copy(p,info,q,bco_sizeW((StgBCO *)q),gen_no); return; case THUNK_SELECTOR: @@ -566,7 +662,6 @@ loop: return; case IND: - case IND_OLDGEN: // follow chains of indirections, don't evacuate them q = ((StgInd*)q)->indirectee; *p = q; @@ -577,6 +672,7 @@ loop: case RET_BIG: case RET_DYN: case UPDATE_FRAME: + case UNDERFLOW_FRAME: case STOP_FRAME: case CATCH_FRAME: case CATCH_STM_FRAME: @@ -586,20 +682,20 @@ loop: barf("evacuate: stack frame at %p\n", q); case PAP: - copy(p,info,q,pap_sizeW((StgPAP*)q),stp); + copy(p,info,q,pap_sizeW((StgPAP*)q),gen_no); return; case AP: - copy(p,info,q,ap_sizeW((StgAP*)q),stp); + copy(p,info,q,ap_sizeW((StgAP*)q),gen_no); return; case AP_STACK: - copy(p,info,q,ap_stack_sizeW((StgAP_STACK*)q),stp); + copy(p,info,q,ap_stack_sizeW((StgAP_STACK*)q),gen_no); return; case ARR_WORDS: // just copy the block - copy(p,info,q,arr_words_sizeW((StgArrWords *)q),stp); + copy(p,info,q,arr_words_sizeW((StgArrWords *)q),gen_no); return; case MUT_ARR_PTRS_CLEAN: @@ -607,61 +703,40 @@ loop: case MUT_ARR_PTRS_FROZEN: case MUT_ARR_PTRS_FROZEN0: // just copy the block - copy(p,info,q,mut_arr_ptrs_sizeW((StgMutArrPtrs *)q),stp); + copy(p,info,q,mut_arr_ptrs_sizeW((StgMutArrPtrs *)q),gen_no); return; case TSO: - { - StgTSO *tso = (StgTSO *)q; + copy(p,info,q,sizeofW(StgTSO),gen_no); + return; - /* Deal with redirected TSOs (a TSO that's had its stack enlarged). - */ - if (tso->what_next == ThreadRelocated) { - q = (StgClosure *)tso->_link; - *p = q; - goto loop; - } + case STACK: + { + StgStack *stack = (StgStack *)q; - /* To evacuate a small TSO, we need to relocate the update frame - * list it contains. + /* To evacuate a small STACK, we need to adjust the stack pointer */ { - StgTSO *new_tso; + StgStack *new_stack; StgPtr r, s; - - copyPart(p,(StgClosure *)tso, tso_sizeW(tso), sizeofW(StgTSO), stp); - new_tso = (StgTSO *)*p; - move_TSO(tso, new_tso); - for (r = tso->sp, s = new_tso->sp; - r < tso->stack+tso->stack_size;) { - *s++ = *r++; - } + rtsBool mine; + + mine = copyPart(p,(StgClosure *)stack, stack_sizeW(stack), + sizeofW(StgStack), gen_no); + if (mine) { + new_stack = (StgStack *)*p; + move_STACK(stack, new_stack); + for (r = stack->sp, s = new_stack->sp; + r < stack->stack + stack->stack_size;) { + *s++ = *r++; + } + } return; } } - case TREC_HEADER: - copy(p,info,q,sizeofW(StgTRecHeader),stp); - return; - - case TVAR_WATCH_QUEUE: - copy(p,info,q,sizeofW(StgTVarWatchQueue),stp); - return; - - case TVAR: - copy(p,info,q,sizeofW(StgTVar),stp); - return; - case TREC_CHUNK: - copy(p,info,q,sizeofW(StgTRecChunk),stp); - return; - - case ATOMIC_INVARIANT: - copy(p,info,q,sizeofW(StgAtomicInvariant),stp); - return; - - case INVARIANT_CHECK_QUEUE: - copy(p,info,q,sizeofW(StgInvariantCheckQueue),stp); + copy(p,info,q,sizeofW(StgTRecChunk),gen_no); return; default: @@ -672,75 +747,6 @@ loop: } /* ----------------------------------------------------------------------------- - Evacuate a large object - - This just consists of removing the object from the (doubly-linked) - step->large_objects list, and linking it on to the (singly-linked) - step->new_large_objects list, from where it will be scavenged later. - - Convention: bd->flags has BF_EVACUATED set for a large object - that has been evacuated, or unset otherwise. - -------------------------------------------------------------------------- */ - -STATIC_INLINE void -evacuate_large(StgPtr p) -{ - bdescr *bd = Bdescr(p); - step *stp, *new_stp; - step_workspace *ws; - - stp = bd->step; - ACQUIRE_SPIN_LOCK(&stp->sync_large_objects); - - // object must be at the beginning of the block (or be a ByteArray) - ASSERT(get_itbl((StgClosure *)p)->type == ARR_WORDS || - (((W_)p & BLOCK_MASK) == 0)); - - // already evacuated? - if (bd->flags & BF_EVACUATED) { - /* Don't forget to set the gct->failed_to_evac flag if we didn't get - * the desired destination (see comments in evacuate()). - */ - if (stp < gct->evac_step) { - gct->failed_to_evac = rtsTrue; - TICK_GC_FAILED_PROMOTION(); - } - RELEASE_SPIN_LOCK(&stp->sync_large_objects); - return; - } - - // remove from large_object list - if (bd->u.back) { - bd->u.back->link = bd->link; - } else { // first object in the list - stp->large_objects = bd->link; - } - if (bd->link) { - bd->link->u.back = bd->u.back; - } - - /* link it on to the evacuated large object list of the destination step - */ - new_stp = stp->to; - if (new_stp < gct->evac_step) { - if (gct->eager_promotion) { - new_stp = gct->evac_step; - } else { - gct->failed_to_evac = rtsTrue; - } - } - - ws = &gct->steps[new_stp->abs_no]; - bd->flags |= BF_EVACUATED; - bd->step = new_stp; - bd->gen_no = new_stp->gen_no; - bd->link = ws->todo_large_objects; - ws->todo_large_objects = bd; - - RELEASE_SPIN_LOCK(&stp->sync_large_objects); -} - -/* ----------------------------------------------------------------------------- Evaluate a THUNK_SELECTOR if possible. p points to a THUNK_SELECTOR that we want to evaluate. The @@ -759,28 +765,41 @@ unchain_thunk_selectors(StgSelector *p, StgClosure *val) prev = NULL; while (p) { -#ifdef THREADED_RTS ASSERT(p->header.info == &stg_WHITEHOLE_info); -#else - ASSERT(p->header.info == &stg_BLACKHOLE_info); -#endif // val must be in to-space. Not always: when we recursively // invoke eval_thunk_selector(), the recursive calls will not // evacuate the value (because we want to select on the value, // not evacuate it), so in this case val is in from-space. - // ASSERT(!HEAP_ALLOCED(val) || Bdescr((P_)val)->gen_no > N || (Bdescr((P_)val)->flags & BF_EVACUATED)); + // ASSERT(!HEAP_ALLOCED_GC(val) || Bdescr((P_)val)->gen_no > N || (Bdescr((P_)val)->flags & BF_EVACUATED)); prev = (StgSelector*)((StgClosure *)p)->payload[0]; // Update the THUNK_SELECTOR with an indirection to the - // EVACUATED closure now at p. Why do this rather than - // upd_evacuee(q,p)? Because we have an invariant that an - // EVACUATED closure always points to an object in the - // same or an older generation (required by the short-cut - // test in the EVACUATED case, below). - ((StgInd *)p)->indirectee = val; - write_barrier(); - SET_INFO(p, &stg_IND_info); + // value. The value is still in from-space at this stage. + // + // (old note: Why not do upd_evacuee(q,p)? Because we have an + // invariant that an EVACUATED closure always points to an + // object in the same or an older generation (required by + // the short-cut test in the EVACUATED case, below). + if ((StgClosure *)p == val) { + // must be a loop; just leave a BLACKHOLE in place. This + // can happen when we have a chain of selectors that + // eventually loops back on itself. We can't leave an + // indirection pointing to itself, and we want the program + // to deadlock if it ever enters this closure, so + // BLACKHOLE is correct. + + // XXX we do not have BLACKHOLEs any more; replace with + // a THUNK_SELECTOR again. This will go into a loop if it is + // entered, and should result in a NonTermination exception. + ((StgThunk *)p)->payload[0] = val; + write_barrier(); + SET_INFO(p, &stg_sel_0_upd_info); + } else { + ((StgInd *)p)->indirectee = val; + write_barrier(); + SET_INFO(p, &stg_IND_info); + } // For the purposes of LDV profiling, we have created an // indirection. @@ -805,13 +824,13 @@ eval_thunk_selector (StgClosure **q, StgSelector * p, rtsBool evac) prev_thunk_selector = NULL; // this is a chain of THUNK_SELECTORs that we are going to update // to point to the value of the current THUNK_SELECTOR. Each - // closure on the chain is a BLACKHOLE, and points to the next in the + // closure on the chain is a WHITEHOLE, and points to the next in the // chain with payload[0]. selector_chain: bd = Bdescr((StgPtr)p); - if (HEAP_ALLOCED(p)) { + if (HEAP_ALLOCED_GC(p)) { // If the THUNK_SELECTOR is in to-space or in a generation that we // are not collecting, then bale out early. We won't be able to // save any space in any case, and updating with an indirection is @@ -820,6 +839,11 @@ selector_chain: if (bd->flags & BF_EVACUATED) { unchain_thunk_selectors(prev_thunk_selector, (StgClosure *)p); *q = (StgClosure *)p; + // shortcut, behave as for: if (evac) evacuate(q); + if (evac && bd->gen_no < gct->evac_gen_no) { + gct->failed_to_evac = rtsTrue; + TICK_GC_FAILED_PROMOTION(); + } return; } // we don't update THUNK_SELECTORS in the compacted @@ -838,7 +862,7 @@ selector_chain: } - // BLACKHOLE the selector thunk, since it is now under evaluation. + // WHITEHOLE 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) @@ -850,7 +874,7 @@ selector_chain: } while (info_ptr == (W_)&stg_WHITEHOLE_info); // make sure someone else didn't get here first... - if (IS_FORWARDING_PTR(p) || + if (IS_FORWARDING_PTR(info_ptr) || INFO_PTR_TO_STRUCT(info_ptr)->type != THUNK_SELECTOR) { // v. tricky now. The THUNK_SELECTOR has been evacuated // by another thread, and is now either a forwarding ptr or IND. @@ -871,7 +895,7 @@ selector_chain: #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); + SET_INFO(p,&stg_WHITEHOLE_info); #endif field = INFO_PTR_TO_STRUCT(info_ptr)->layout.selector_offset; @@ -922,8 +946,8 @@ selector_loop: // For the purposes of LDV profiling, we have destroyed // the original selector thunk, p. SET_INFO(p, (StgInfoTable *)info_ptr); - LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC((StgClosure *)p); - SET_INFO(p, &stg_BLACKHOLE_info); + OVERWRITING_CLOSURE((StgClosure*)p); + SET_INFO(p, &stg_WHITEHOLE_info); #endif // the closure in val is now the "value" of the @@ -939,8 +963,6 @@ selector_loop: switch (info->type) { case IND: case IND_PERM: - case IND_OLDGEN: - case IND_OLDGEN_PERM: case IND_STATIC: val = ((StgInd *)val)->indirectee; goto val_loop; @@ -957,24 +979,55 @@ selector_loop: prev_thunk_selector = p; *q = val; - if (evac) evacuate(q); - val = *q; + + // update the other selectors in the chain *before* + // evacuating the value. This is necessary in the case + // where the value turns out to be one of the selectors + // in the chain (i.e. we have a loop), and evacuating it + // would corrupt the chain. + unchain_thunk_selectors(prev_thunk_selector, val); + // evacuate() cannot recurse through // eval_thunk_selector(), because we know val is not // a THUNK_SELECTOR. - unchain_thunk_selectors(prev_thunk_selector, val); + if (evac) evacuate(q); return; } case IND: case IND_PERM: - case IND_OLDGEN: - case IND_OLDGEN_PERM: case IND_STATIC: // Again, we might need to untag a constructor. selectee = UNTAG_CLOSURE( ((StgInd *)selectee)->indirectee ); goto selector_loop; + case BLACKHOLE: + { + StgClosure *r; + const StgInfoTable *i; + r = ((StgInd*)selectee)->indirectee; + + // establish whether this BH has been updated, and is now an + // indirection, as in evacuate(). + if (GET_CLOSURE_TAG(r) == 0) { + i = r->header.info; + if (IS_FORWARDING_PTR(i)) { + r = (StgClosure *)UN_FORWARDING_PTR(i); + i = r->header.info; + } + if (i == &stg_TSO_info + || i == &stg_WHITEHOLE_info + || i == &stg_BLOCKING_QUEUE_CLEAN_info + || i == &stg_BLOCKING_QUEUE_DIRTY_info) { + goto bale_out; + } + ASSERT(i != &stg_IND_info); + } + + selectee = UNTAG_CLOSURE( ((StgInd *)selectee)->indirectee ); + goto selector_loop; + } + case THUNK_SELECTOR: { StgClosure *val; @@ -1009,10 +1062,6 @@ selector_loop: case THUNK_1_1: case THUNK_0_2: case THUNK_STATIC: - case CAF_BLACKHOLE: - case SE_CAF_BLACKHOLE: - case SE_BLACKHOLE: - case BLACKHOLE: // not evaluated yet goto bale_out; @@ -1030,7 +1079,7 @@ bale_out: // check whether it was updated in the meantime. *q = (StgClosure *)p; if (evac) { - copy(q,(const StgInfoTable *)info_ptr,(StgClosure *)p,THUNK_SELECTOR_sizeW(),bd->step->to); + copy(q,(const StgInfoTable *)info_ptr,(StgClosure *)p,THUNK_SELECTOR_sizeW(),bd->dest_no); } unchain_thunk_selectors(prev_thunk_selector, *q); return;