X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FGC.c;h=88a265d33ef9ad693c4bcbc45b3bb87b5c3e4def;hb=8435b2e4f149d969d0c19b01c9d8ca7fef392aa4;hp=80f7291665c48ce4ce1ec2d2f3a55754b6d474d8;hpb=f477a85c5ba20c12e6f229e5b870fddc7e8bacfd;p=ghc-hetmet.git diff --git a/ghc/rts/GC.c b/ghc/rts/GC.c index 80f7291..88a265d 100644 --- a/ghc/rts/GC.c +++ b/ghc/rts/GC.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: GC.c,v 1.136 2002/07/10 09:28:54 simonmar Exp $ + * $Id: GC.c,v 1.139 2002/09/05 16:26:33 simonmar Exp $ * * (c) The GHC Team 1998-1999 * @@ -45,6 +45,8 @@ #include "RetainerProfile.h" #include "LdvProfile.h" +#include + /* STATIC OBJECT LIST. * * During GC: @@ -79,8 +81,8 @@ * We build up a static object list while collecting generations 0..N, * which is then appended to the static object list of generation N+1. */ -StgClosure* static_objects; // live static objects -StgClosure* scavenged_static_objects; // static objects scavenged so far +static StgClosure* static_objects; // live static objects +StgClosure* scavenged_static_objects; // static objects scavenged so far /* N is the oldest generation being collected, where the generations * are numbered starting at 0. A major GC (indicated by the major_gc @@ -118,16 +120,16 @@ static rtsBool failed_to_evac; /* Old to-space (used for two-space collector only) */ -bdescr *old_to_blocks; +static bdescr *old_to_blocks; /* Data used for allocation area sizing. */ -lnat new_blocks; // blocks allocated during this GC -lnat g0s0_pcnt_kept = 30; // percentage of g0s0 live at last minor GC +static lnat new_blocks; // blocks allocated during this GC +static lnat g0s0_pcnt_kept = 30; // percentage of g0s0 live at last minor GC /* Used to avoid long recursion due to selector thunks */ -lnat thunk_selector_depth = 0; +static lnat thunk_selector_depth = 0; #define MAX_THUNK_SELECTOR_DEPTH 256 /* ----------------------------------------------------------------------------- @@ -1467,8 +1469,8 @@ copyPart(StgClosure *src, nat size_to_reserve, nat size_to_copy, step *stp) Evacuate a large object This just consists of removing the object from the (doubly-linked) - large_alloc_list, and linking it on to the (singly-linked) - new_large_objects list, from where it will be scavenged later. + 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. @@ -1725,6 +1727,15 @@ loop: const StgInfoTable* selectee_info; StgClosure* selectee = ((StgSelector*)q)->selectee; + // We only recurse a certain depth through selector thunks. + // NOTE: the depth is maintained manually, and we must be very + // careful to always decrement it before returning. + // + thunk_selector_depth++; + if (thunk_selector_depth > MAX_THUNK_SELECTOR_DEPTH) { + goto selector_abandon; + } + selector_loop: selectee_info = get_itbl(selectee); switch (selectee_info->type) { @@ -1744,29 +1755,30 @@ loop: (StgWord32)(selectee_info->layout.payload.ptrs + selectee_info->layout.payload.nptrs)); + // The thunk is now under evaluation, so we overwrite it + // with a BLACKHOLE. This has a beneficial effect if the + // selector thunk eventually refers to itself: we won't + // recurse indefinitely, and the object which eventually + // gets evacuated will be a BLACKHOLE (as it should be: a + // selector thunk which refers to itself can only have value + // _|_). + SET_INFO(q,&stg_BLACKHOLE_info); + // perform the selection! - q = selectee->payload[offset]; + selectee = selectee->payload[offset]; if (major_gc==rtsTrue) {TICK_GC_SEL_MAJOR();} else {TICK_GC_SEL_MINOR();} - - /* if we're already in to-space, there's no need to continue - * with the evacuation, just update the source address with - * a pointer to the (evacuated) constructor field. - */ - if (HEAP_ALLOCED(q)) { - bdescr *bd = Bdescr((P_)q); - if (bd->flags & BF_EVACUATED) { - if (bd->gen_no < evac_gen) { - failed_to_evac = rtsTrue; - TICK_GC_FAILED_PROMOTION(); - } - return q; - } - } - - /* otherwise, carry on and evacuate this constructor field, - * (but not the constructor itself) - */ - goto loop; + // Carry on and evacuate this constructor field, + // (but not the constructor itself) + // + // It is tempting to just 'goto loop;' at this point, but + // that doesn't give us a way to decrement + // thunk_selector_depth later. So we recurse (boundedly) + // into evacuate(). + // + selectee = evacuate(selectee); + upd_evacuee(q,selectee); + thunk_selector_depth--; + return selectee; } case IND: @@ -1778,34 +1790,28 @@ loop: goto selector_loop; case EVACUATED: - selectee = ((StgEvacuated *)selectee)->evacuee; - goto selector_loop; + // We could follow forwarding pointers here too, but we don't + // for two reasons: + // * If the constructor has already been evacuated, then + // we're only doing the evaluation early, not fixing a + // space leak. + // * When we finally reach the destination, we have to + // figure out whether we are in to-space or not, and this + // is somewhat awkward. + // + // selectee = ((StgEvacuated *)selectee)->evacuee; + // goto selector_loop; + break; case THUNK_SELECTOR: -# if 0 - /* Disabled 03 April 2001 by JRS; it seems to cause the GC (or - something) to go into an infinite loop when the nightly - stage2 compiles PrelTup.lhs. */ - /* we can't recurse indefinitely in evacuate(), so set a * limit on the number of times we can go around this * loop. */ - if (thunk_selector_depth < MAX_THUNK_SELECTOR_DEPTH) { - bdescr *bd; - bd = Bdescr((P_)selectee); - if (!bd->flags & BF_EVACUATED) { - thunk_selector_depth++; - selectee = evacuate(selectee); - thunk_selector_depth--; - goto selector_loop; - } - } else { - TICK_GC_SEL_ABANDONED(); - // and fall through... - } -# endif - + q = evacuate(selectee); + thunk_selector_depth--; + return q; + case AP_UPD: case THUNK: case THUNK_1_0: @@ -1819,8 +1825,8 @@ loop: case SE_BLACKHOLE: case BLACKHOLE: case BLACKHOLE_BQ: - // not evaluated yet - break; + // not evaluated yet + break; #if defined(PAR) // a copy of the top-level cases below @@ -1831,12 +1837,14 @@ loop: //ToDo: derive size etc from reverted IP //to = copy(q,size,stp); // recordMutable((StgMutClosure *)to); + thunk_selector_depth--; return to; } case BLOCKED_FETCH: ASSERT(sizeofW(StgBlockedFetch) >= MIN_NONUPD_SIZE); to = copy(q,sizeofW(StgBlockedFetch),stp); + thunk_selector_depth--; return to; # ifdef DIST @@ -1845,11 +1853,13 @@ loop: case FETCH_ME: ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE); to = copy(q,sizeofW(StgFetchMe),stp); + thunk_selector_depth--; return to; case FETCH_ME_BQ: ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE); to = copy(q,sizeofW(StgFetchMeBlockingQueue),stp); + thunk_selector_depth--; return to; #endif @@ -1858,6 +1868,8 @@ loop: (int)(selectee_info->type)); } } + selector_abandon: + thunk_selector_depth--; return copy(q,THUNK_SELECTOR_sizeW(),stp); case IND: @@ -1940,7 +1952,7 @@ loop: */ if (evac_gen > 0) { // optimisation StgClosure *p = ((StgEvacuated*)q)->evacuee; - if (Bdescr((P_)p)->gen_no < evac_gen) { + if (HEAP_ALLOCED(p) && Bdescr((P_)p)->gen_no < evac_gen) { failed_to_evac = rtsTrue; TICK_GC_FAILED_PROMOTION(); } @@ -2197,6 +2209,8 @@ scavenge(step *stp) info = get_itbl((StgClosure *)p); ASSERT(p && (LOOKS_LIKE_GHC_INFO(info) || IS_HUGS_CONSTR_INFO(info))); + ASSERT(thunk_selector_depth == 0); + q = p; switch (info->type) {