X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=rts%2Fsm%2FEvac.c;h=fb9f4c49b2decb7a3e1833d1d12ae357a4ce2857;hb=698364afaf2f346227910c0cf8d4f1929cdc56ef;hp=ad577af0c9edb8ae555ac59d007eafe581a16fe3;hpb=2018c430c8eb41cc323616536fffb5830a1e3a65;p=ghc-hetmet.git diff --git a/rts/sm/Evac.c b/rts/sm/Evac.c index ad577af..fb9f4c4 100644 --- a/rts/sm/Evac.c +++ b/rts/sm/Evac.c @@ -23,71 +23,134 @@ /* Used to avoid long recursion due to selector thunks */ -lnat thunk_selector_depth = 0; #define MAX_THUNK_SELECTOR_DEPTH 16 static StgClosure * eval_thunk_selector (StgSelector * p, rtsBool); -STATIC_INLINE void -upd_evacuee(StgClosure *p, StgClosure *dest) +STATIC_INLINE StgPtr +alloc_for_copy (nat size, step *stp) { - // not true: (ToDo: perhaps it should be) - // ASSERT(Bdescr((P_)dest)->flags & BF_EVACUATED); - SET_INFO(p, &stg_EVACUATED_info); - ((StgEvacuated *)p)->evacuee = dest; + 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->todo_bd; + to = bd->free; + if (to + size >= bd->start + BLOCK_SIZE_W) { + bd = gc_alloc_todo_block(ws); + to = bd->free; + } + bd->free = to + size; + + 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; -#ifdef PROFILING - // @LDV profiling - nat size_org = size; + 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 - TICK_GC_WORDS_COPIED(size); - /* 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 < evac_gen) { - if (eager_promotion) { - stp = &generations[evac_gen].steps[0]; - } else { - failed_to_evac = rtsTrue; - } - } - - /* chain a new block onto the to-space for the destination step if - * necessary. - */ - if (stp->hp + size >= stp->hpLim) { - gc_alloc_block(stp); - } + to = alloc_for_copy(size,stp); + + TICK_GC_WORDS_COPIED(size); - to = stp->hp; - from = (StgPtr)src; - stp->hp = to + size; - for (i = 0; i < size; i++) { // unroll for small i - to[i] = from[i]; - } + 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); - /* 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); +// } - upd_evacuee((StgClosure *)from,(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_org); + // 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; + 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 @@ -95,100 +158,100 @@ copy_tag(StgClosure *src, nat size, step *stp,StgWord tag) STATIC_INLINE StgClosure * copy_noscav_tag(StgClosure *src, nat size, step *stp, StgWord tag) { - StgPtr to, from; - nat i; -#ifdef PROFILING - // @LDV profiling - nat size_org = size; + 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); - /* 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 < evac_gen) { - if (eager_promotion) { - stp = &generations[evac_gen].steps[0]; - } else { - failed_to_evac = rtsTrue; - } - } - - /* chain a new block onto the to-space for the destination step if - * necessary. - */ - if (stp->scavd_hp + size >= stp->scavd_hpLim) { - gc_alloc_scavd_block(stp); - } - - to = stp->scavd_hp; - from = (StgPtr)src; - stp->scavd_hp = to + size; - for (i = 0; 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); + 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]; + } - upd_evacuee((StgClosure *)from,(StgClosure *)to); + // 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_org); + // 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; + 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) { - P_ dest, to, from; -#ifdef PROFILING - // @LDV profiling - nat size_to_copy_org = size_to_copy; + 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); - if (stp->gen_no < evac_gen) { - if (eager_promotion) { - stp = &generations[evac_gen].steps[0]; - } else { - failed_to_evac = rtsTrue; - } - } - - if (stp->hp + size_to_reserve >= stp->hpLim) { - gc_alloc_block(stp); - } + TICK_GC_WORDS_COPIED(size_to_copy); - for(to = stp->hp, from = (P_)src; size_to_copy>0; --size_to_copy) { - *to++ = *from++; - } - - dest = stp->hp; - stp->hp += size_to_reserve; - upd_evacuee(src,(StgClosure *)dest); + 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. - // size_to_copy_org is wrong because the closure already occupies size_to_reserve - // words. - SET_EVACUAEE_FOR_LDV(src, size_to_reserve); - // fill the slop - if (size_to_reserve - size_to_copy_org > 0) - LDV_FILL_SLOP(stp->hp - 1, (int)(size_to_reserve - size_to_copy_org)); + // 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 *)dest; + return (StgClosure *)to; } @@ -222,6 +285,7 @@ evacuate_large(StgPtr p) { bdescr *bd = Bdescr(p); step *stp; + step_workspace *ws; // object must be at the beginning of the block (or be a ByteArray) ASSERT(get_itbl((StgClosure *)p)->type == ARR_WORDS || @@ -229,17 +293,19 @@ evacuate_large(StgPtr p) // already evacuated? if (bd->flags & BF_EVACUATED) { - /* Don't forget to set the failed_to_evac flag if we didn't get + /* 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 < evac_gen) { - failed_to_evac = rtsTrue; + if (bd->gen_no < gct->evac_gen) { + gct->failed_to_evac = rtsTrue; TICK_GC_FAILED_PROMOTION(); } return; } stp = bd->step; + + ACQUIRE_SPIN_LOCK(&stp->sync_large_objects); // remove from large_object list if (bd->u.back) { bd->u.back->link = bd->link; @@ -249,22 +315,24 @@ evacuate_large(StgPtr p) if (bd->link) { bd->link->u.back = bd->u.back; } + RELEASE_SPIN_LOCK(&stp->sync_large_objects); /* link it on to the evacuated large object list of the destination step */ stp = bd->step->to; - if (stp->gen_no < evac_gen) { - if (eager_promotion) { - stp = &generations[evac_gen].steps[0]; + if (stp->gen_no < gct->evac_gen) { + if (gct->eager_promotion) { + stp = &generations[gct->evac_gen].steps[0]; } else { - failed_to_evac = rtsTrue; + gct->failed_to_evac = rtsTrue; } } + ws = &gct->steps[stp->gen_no][stp->no]; bd->step = stp; bd->gen_no = stp->gen_no; - bd->link = stp->new_large_objects; - stp->new_large_objects = bd; + bd->link = ws->todo_large_objects; + ws->todo_large_objects = bd; bd->flags |= BF_EVACUATED; } @@ -274,22 +342,22 @@ evacuate_large(StgPtr p) This is called (eventually) for every live object in the system. The caller to evacuate specifies a desired generation in the - evac_gen global variable. The following conditions apply to + 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 >= evac_gen + if M >= gct->evac_gen if M > N do nothing else evac to step->to - if M < evac_gen evac to evac_gen, 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 >= evac_gen do nothing - if M < evac_gen set failed_to_evac flag to indicate that we - didn't manage to evacuate this object into evac_gen. + 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: @@ -333,18 +401,26 @@ loop: switch (info->type) { case THUNK_STATIC: - if (info->srt_bitmap != 0 && + if (info->srt_bitmap != 0 && *THUNK_STATIC_LINK((StgClosure *)q) == NULL) { - *THUNK_STATIC_LINK((StgClosure *)q) = static_objects; - static_objects = (StgClosure *)q; + 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 && + if (info->srt_bitmap != 0 && *FUN_STATIC_LINK((StgClosure *)q) == NULL) { - *FUN_STATIC_LINK((StgClosure *)q) = static_objects; - static_objects = (StgClosure *)q; + 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; @@ -353,17 +429,25 @@ loop: * on the CAF list, so don't do anything with it here (we'll * scavenge it later). */ - if (((StgIndStatic *)q)->saved_info == NULL - && *IND_STATIC_LINK((StgClosure *)q) == NULL) { - *IND_STATIC_LINK((StgClosure *)q) = static_objects; - static_objects = (StgClosure *)q; + 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) { - *STATIC_LINK(info,(StgClosure *)q) = static_objects; - static_objects = (StgClosure *)q; + 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. */ } @@ -385,12 +469,12 @@ loop: 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 evac_gen or older, or we will have to arrange to track + * in gct->evac_gen or older, or we will have to arrange to track * this pointer using the mutable list. */ - if (bd->gen_no < evac_gen) { + if (bd->gen_no < gct->evac_gen) { // nope - failed_to_evac = rtsTrue; + gct->failed_to_evac = rtsTrue; TICK_GC_FAILED_PROMOTION(); } return TAG_CLOSURE(tag,q); @@ -404,8 +488,8 @@ loop: * object twice, for example). */ if (bd->flags & BF_EVACUATED) { - if (bd->gen_no < evac_gen) { - failed_to_evac = rtsTrue; + if (bd->gen_no < gct->evac_gen) { + gct->failed_to_evac = rtsTrue; TICK_GC_FAILED_PROMOTION(); } return TAG_CLOSURE(tag,q); @@ -446,9 +530,13 @@ loop: switch (info->type) { + case WHITEHOLE: + goto loop; + case MUT_VAR_CLEAN: case MUT_VAR_DIRTY: - case MVAR: + case MVAR_CLEAN: + case MVAR_DIRTY: return copy(q,sizeW_fromITBL(info),stp); case CONSTR_0_1: @@ -555,10 +643,10 @@ loop: case EVACUATED: /* Already evacuated, just return the forwarding address. - * HOWEVER: if the requested destination generation (evac_gen) 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 failed_to_evac flag to indicate that we couldn't + * set the gct->failed_to_evac flag to indicate that we couldn't * manage to promote the object to the desired generation. */ /* @@ -570,10 +658,10 @@ loop: * current object would be evacuated to, so we only do the full * check if stp is too low. */ - if (evac_gen > 0 && stp->gen_no < evac_gen) { // optimisation + 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 < evac_gen) { - failed_to_evac = rtsTrue; + if (HEAP_ALLOCED(p) && Bdescr((P_)p)->gen_no < gct->evac_gen) { + gct->failed_to_evac = rtsTrue; TICK_GC_FAILED_PROMOTION(); } } @@ -713,18 +801,29 @@ selector_chain: info_ptr = p->header.info; field = get_itbl(p)->layout.selector_offset; - // If the THUNK_SELECTOR is in to-space or in a generation that we - // are not collecting, then bail out early. We won't be able to - // save any space in any case, and updating with an indirection is - // trickier in an old gen. bd = Bdescr((StgPtr)p); - if (HEAP_ALLOCED(p) && - ((bd->gen_no > N) - || (bd->flags & BF_EVACUATED) - || ((bd->flags & BF_COMPACTED) && - is_marked((P_)p,bd)))) { - unchain_thunk_selectors(prev_thunk_selector, (StgClosure *)p); - return (StgClosure *)p; + if (HEAP_ALLOCED(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 + // trickier in a non-collected gen: we would have to update the + // mutable list. + if ((bd->gen_no > N) || (bd->flags & BF_EVACUATED)) { + unchain_thunk_selectors(prev_thunk_selector, (StgClosure *)p); + return (StgClosure *)p; + } + // we don't update THUNK_SELECTORS in the compacted + // generation, because compaction does not remove the INDs + // that result, this causes confusion later + // (scavenge_mark_stack doesn't deal with IND). BEWARE! This + // bit is very tricky to get right. If you make changes + // 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); + unchain_thunk_selectors(prev_thunk_selector, (StgClosure *)p); + return (StgClosure *)p; + } } // BLACKHOLE the selector thunk, since it is now under evaluation. @@ -818,26 +917,18 @@ selector_loop: { StgClosure *val; - // we don't update THUNK_SELECTORS in the compacted - // generation, because compaction does not remove the INDs - // that result, this causes confusion later - // (scavenge_mark_stack doesn't deal with IND). - if (Bdescr((P_)selectee)->flags && BF_COMPACTED) { - goto bale_out; - } - // recursively evaluate this selector. We don't want to // recurse indefinitely, so we impose a depth bound. - if (thunk_selector_depth >= MAX_THUNK_SELECTOR_DEPTH) { + if (gct->thunk_selector_depth >= MAX_THUNK_SELECTOR_DEPTH) { goto bale_out; } - thunk_selector_depth++; + gct->thunk_selector_depth++; // 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); - thunk_selector_depth--; + gct->thunk_selector_depth--; // did we actually manage to evaluate it? if (val == selectee) goto bale_out;