/* -----------------------------------------------------------------------------
- * $Id: GC.c,v 1.138 2002/08/16 13:29:06 simonmar Exp $
+ * $Id: GC.c,v 1.140 2002/09/06 09:56:12 simonmar Exp $
*
* (c) The GHC Team 1998-1999
*
static rtsBool traverse_weak_ptr_list ( void );
static void mark_weak_ptr_list ( StgWeak **list );
+static StgClosure * eval_thunk_selector ( nat field, StgSelector * p );
+
static void scavenge ( step * );
static void scavenge_mark_stack ( void );
static void scavenge_stack ( StgPtr p, StgPtr stack_end );
case THUNK_SELECTOR:
{
- const StgInfoTable* selectee_info;
- StgClosure* selectee = ((StgSelector*)q)->selectee;
-
- selector_loop:
- selectee_info = get_itbl(selectee);
- switch (selectee_info->type) {
- case CONSTR:
- case CONSTR_1_0:
- case CONSTR_0_1:
- case CONSTR_2_0:
- case CONSTR_1_1:
- case CONSTR_0_2:
- case CONSTR_STATIC:
- case CONSTR_NOCAF_STATIC:
- {
- StgWord offset = info->layout.selector_offset;
-
- // check that the size is in range
- ASSERT(offset <
- (StgWord32)(selectee_info->layout.payload.ptrs +
- selectee_info->layout.payload.nptrs));
-
- // perform the selection!
- q = 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;
- }
- }
+ StgClosure *p;
- /* otherwise, carry on and evacuate this constructor field,
- * (but not the constructor itself)
- */
- goto loop;
+ if (thunk_selector_depth > MAX_THUNK_SELECTOR_DEPTH) {
+ return copy(q,THUNK_SELECTOR_sizeW(),stp);
}
- case IND:
- case IND_STATIC:
- case IND_PERM:
- case IND_OLDGEN:
- case IND_OLDGEN_PERM:
- selectee = ((StgInd *)selectee)->indirectee;
- goto selector_loop;
-
- case EVACUATED:
- selectee = ((StgEvacuated *)selectee)->evacuee;
- goto selector_loop;
-
- 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
-
- case AP_UPD:
- case THUNK:
- case THUNK_1_0:
- case THUNK_0_1:
- case THUNK_2_0:
- case THUNK_1_1:
- case THUNK_0_2:
- case THUNK_STATIC:
- case CAF_BLACKHOLE:
- case SE_CAF_BLACKHOLE:
- case SE_BLACKHOLE:
- case BLACKHOLE:
- case BLACKHOLE_BQ:
- // not evaluated yet
- break;
-
-#if defined(PAR)
- // a copy of the top-level cases below
- case RBH: // cf. BLACKHOLE_BQ
- {
- //StgInfoTable *rip = get_closure_info(q, &size, &ptrs, &nonptrs, &vhs, str);
- to = copy(q,BLACKHOLE_sizeW(),stp);
- //ToDo: derive size etc from reverted IP
- //to = copy(q,size,stp);
- // recordMutable((StgMutClosure *)to);
- return to;
- }
-
- case BLOCKED_FETCH:
- ASSERT(sizeofW(StgBlockedFetch) >= MIN_NONUPD_SIZE);
- to = copy(q,sizeofW(StgBlockedFetch),stp);
- return to;
-
-# ifdef DIST
- case REMOTE_REF:
-# endif
- case FETCH_ME:
- ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
- to = copy(q,sizeofW(StgFetchMe),stp);
- return to;
-
- case FETCH_ME_BQ:
- ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
- to = copy(q,sizeofW(StgFetchMeBlockingQueue),stp);
- return to;
-#endif
+ p = eval_thunk_selector(info->layout.selector_offset,
+ (StgSelector *)q);
- default:
- barf("evacuate: THUNK_SELECTOR: strange selectee %d",
- (int)(selectee_info->type));
- }
+ if (p == NULL) {
+ return copy(q,THUNK_SELECTOR_sizeW(),stp);
+ } else {
+ // q is still BLACKHOLE'd.
+ thunk_selector_depth++;
+ p = evacuate(p);
+ thunk_selector_depth--;
+ upd_evacuee(q,p);
+ return p;
+ }
}
- return copy(q,THUNK_SELECTOR_sizeW(),stp);
case IND:
case IND_OLDGEN:
*/
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();
}
}
/* -----------------------------------------------------------------------------
+ Evaluate a THUNK_SELECTOR if possible.
+
+ returns: NULL if we couldn't evaluate this THUNK_SELECTOR, or
+ a closure pointer if we evaluated it and this is the result
+
+ If the return value is non-NULL, the original selector thunk has
+ been BLACKHOLE'd, and should be updated with an indirection or a
+ forwarding pointer. If the return value is NULL, then the selector
+ thunk is unchanged.
+ -------------------------------------------------------------------------- */
+
+static StgClosure *
+eval_thunk_selector( nat field, StgSelector * p )
+{
+ StgInfoTable *info;
+ const StgInfoTable *info_ptr;
+ StgClosure *selectee;
+
+ selectee = p->selectee;
+
+ // Save the real info pointer (NOTE: not the same as get_itbl()).
+ info_ptr = p->header.info;
+
+ // 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.
+ SET_INFO(p,&stg_BLACKHOLE_info);
+
+selector_loop:
+ info = get_itbl(selectee);
+ switch (info->type) {
+ case CONSTR:
+ case CONSTR_1_0:
+ case CONSTR_0_1:
+ case CONSTR_2_0:
+ case CONSTR_1_1:
+ case CONSTR_0_2:
+ case CONSTR_STATIC:
+ case CONSTR_NOCAF_STATIC:
+ // check that the size is in range
+ ASSERT(field < (StgWord32)(info->layout.payload.ptrs +
+ info->layout.payload.nptrs));
+
+ return selectee->payload[field];
+
+ case IND:
+ case IND_STATIC:
+ case IND_PERM:
+ case IND_OLDGEN:
+ case IND_OLDGEN_PERM:
+ selectee = ((StgInd *)selectee)->indirectee;
+ goto selector_loop;
+
+ case EVACUATED:
+ // We don't follow pointers into to-space; the constructor
+ // has already been evacuated, so we won't save any space
+ // leaks by evaluating this selector thunk anyhow.
+ break;
+
+ case THUNK_SELECTOR:
+ {
+ StgClosure *val;
+
+ // check that we don't recurse too much, re-using the
+ // depth bound also used in evacuate().
+ thunk_selector_depth++;
+ if (thunk_selector_depth > MAX_THUNK_SELECTOR_DEPTH) {
+ break;
+ }
+
+ val = eval_thunk_selector(info->layout.selector_offset,
+ (StgSelector *)selectee);
+
+ thunk_selector_depth--;
+
+ if (val == NULL) {
+ break;
+ } else {
+ // we evaluated this selector thunk, so update it with
+ // an indirection.
+ UPD_IND_NOLOCK(selectee, val);
+ selectee = val;
+ goto selector_loop;
+ }
+ }
+
+ case AP_UPD:
+ case THUNK:
+ case THUNK_1_0:
+ case THUNK_0_1:
+ case THUNK_2_0:
+ case THUNK_1_1:
+ case THUNK_0_2:
+ case THUNK_STATIC:
+ case CAF_BLACKHOLE:
+ case SE_CAF_BLACKHOLE:
+ case SE_BLACKHOLE:
+ case BLACKHOLE:
+ case BLACKHOLE_BQ:
+#if defined(PAR)
+ case RBH:
+ case BLOCKED_FETCH:
+# ifdef DIST
+ case REMOTE_REF:
+# endif
+ case FETCH_ME:
+ case FETCH_ME_BQ:
+#endif
+ // not evaluated yet
+ break;
+
+ default:
+ barf("eval_thunk_selector: strange selectee %d",
+ (int)(info->type));
+ }
+
+ // We didn't manage to evaluate this thunk; restore the old info pointer
+ SET_INFO(p, info_ptr);
+ return NULL;
+}
+
+/* -----------------------------------------------------------------------------
move_TSO is called to update the TSO structure after it has been
moved from one place to another.
-------------------------------------------------------------------------- */
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) {