X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FGC.c;h=9d25926ecd4866587c5f51d631ced7270ff1be0e;hb=6458c2c59780ea01a79f3c31b9b2545a0241606d;hp=6fa541605173d84e7b71846e380666c4bddbde10;hpb=d50842411449b90985be6b265fb19e38e0619045;p=ghc-hetmet.git diff --git a/ghc/rts/GC.c b/ghc/rts/GC.c index 6fa5416..9d25926 100644 --- a/ghc/rts/GC.c +++ b/ghc/rts/GC.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: GC.c,v 1.164 2003/11/26 12:14:26 simonmar Exp $ + * $Id: GC.c,v 1.169 2004/09/03 15:28:20 simonmar Exp $ * * (c) The GHC Team 1998-2003 * @@ -13,7 +13,8 @@ #include "RtsUtils.h" #include "Apply.h" #include "Storage.h" -#include "StoragePriv.h" +#include "LdvProfile.h" +#include "Updates.h" #include "Stats.h" #include "Schedule.h" #include "SchedAPI.h" // for ReverCAFs prototype @@ -23,7 +24,6 @@ #include "ProfHeap.h" #include "SchedAPI.h" #include "Weak.h" -#include "StablePriv.h" #include "Prelude.h" #include "ParTicky.h" // ToDo: move into Rts.h #include "GCCompact.h" @@ -44,7 +44,6 @@ #endif #include "RetainerProfile.h" -#include "LdvProfile.h" #include @@ -142,11 +141,13 @@ static void mark_root ( StgClosure **root ); // Use a register argument for evacuate, if available. #if __GNUC__ >= 2 -static StgClosure * evacuate (StgClosure *q) __attribute__((regparm(1))); +#define REGPARM1 __attribute__((regparm(1))) #else -static StgClosure * evacuate (StgClosure *q); +#define REGPARM1 #endif +REGPARM1 static StgClosure * evacuate (StgClosure *q); + static void zero_static_object_list ( StgClosure* first_static ); static void zero_mutable_list ( StgMutClosure *first ); @@ -306,7 +307,7 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc ) #endif #if defined(DEBUG) && defined(GRAN) - IF_DEBUG(gc, belch("@@ Starting garbage collection at %ld (%lx)\n", + IF_DEBUG(gc, debugBelch("@@ Starting garbage collection at %ld (%lx)\n", Now, Now)); #endif @@ -439,17 +440,24 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc ) stp->bitmap = bitmap_bdescr; bitmap = bitmap_bdescr->start; - IF_DEBUG(gc, belch("bitmap_size: %d, bitmap: %p", + IF_DEBUG(gc, debugBelch("bitmap_size: %d, bitmap: %p", bitmap_size, bitmap);); // don't forget to fill it with zeros! memset(bitmap, 0, bitmap_size); - // for each block in this step, point to its bitmap from the + // For each block in this step, point to its bitmap from the // block descriptor. for (bd=stp->blocks; bd != NULL; bd = bd->link) { bd->u.bitmap = bitmap; bitmap += BLOCK_SIZE_W / (sizeof(W_)*BITS_PER_BYTE); + + // Also at this point we set the BF_COMPACTED flag + // for this block. The invariant is that + // BF_COMPACTED is always unset, except during GC + // when it is set on those blocks which will be + // compacted. + bd->flags |= BF_COMPACTED; } } } @@ -576,17 +584,6 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc ) */ markStablePtrTable(mark_root); -#ifdef INTERPRETER - { - /* ToDo: To fix the caf leak, we need to make the commented out - * parts of this code do something sensible - as described in - * the CAF document. - */ - extern void markHugsObjects(void); - markHugsObjects(); - } -#endif - /* ------------------------------------------------------------------------- * Repeatedly scavenge all the areas we know about until there's no * more scavenging to be done. @@ -751,8 +748,7 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc ) // for a compacted step, just shift the new to-space // onto the front of the now-compacted existing blocks. for (bd = stp->to_blocks; bd != NULL; bd = bd->link) { - bd->flags &= ~BF_EVACUATED; // now from-space - bd->flags |= BF_COMPACTED; // compacted next time + bd->flags &= ~BF_EVACUATED; // now from-space } // tack the new blocks on the end of the existing blocks if (stp->blocks == NULL) { @@ -763,6 +759,11 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc ) if (next == NULL) { bd->link = stp->to_blocks; } + // NB. this step might not be compacted next + // time, so reset the BF_COMPACTED flags. + // They are set before GC if we're going to + // compact. (search for BF_COMPACTED above). + bd->flags &= ~BF_COMPACTED; } } // add the new blocks to the block tally @@ -772,7 +773,7 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc ) stp->blocks = stp->to_blocks; stp->n_blocks = stp->n_to_blocks; for (bd = stp->blocks; bd != NULL; bd = bd->link) { - bd->flags &= ~BF_EVACUATED; // now from-space + bd->flags &= ~BF_EVACUATED; // now from-space } } stp->to_blocks = NULL; @@ -850,10 +851,10 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc ) oldest_gen->steps[0].n_blocks > (RtsFlags.GcFlags.compactThreshold * max) / 100))) { oldest_gen->steps[0].is_compacted = 1; -// fprintf(stderr,"compaction: on\n", live); +// debugBelch("compaction: on\n", live); } else { oldest_gen->steps[0].is_compacted = 0; -// fprintf(stderr,"compaction: off\n", live); +// debugBelch("compaction: off\n", live); } // if we're going to go over the maximum heap size, reduce the @@ -885,7 +886,7 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc ) } #if 0 - fprintf(stderr,"live: %d, min_alloc: %d, size : %d, max = %d\n", live, + debugBelch("live: %d, min_alloc: %d, size : %d, max = %d\n", live, min_alloc, size, max); #endif @@ -967,7 +968,7 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc ) int pc_free; adjusted_blocks = (RtsFlags.GcFlags.maxHeapSize - 2 * blocks); - IF_DEBUG(gc, belch("@@ Near maximum heap size of 0x%x blocks, blocks = %d, adjusted to %ld", RtsFlags.GcFlags.maxHeapSize, blocks, adjusted_blocks)); + IF_DEBUG(gc, debugBelch("@@ Near maximum heap size of 0x%x blocks, blocks = %d, adjusted to %ld", RtsFlags.GcFlags.maxHeapSize, blocks, adjusted_blocks)); pc_free = adjusted_blocks * 100 / RtsFlags.GcFlags.maxHeapSize; if (pc_free < RtsFlags.GcFlags.pcFreeHeap) /* might even be < 0 */ { heapOverflow(); @@ -1195,7 +1196,7 @@ traverse_weak_ptr_list(void) w->link = weak_ptr_list; weak_ptr_list = w; flag = rtsTrue; - IF_DEBUG(weak, belch("Weak pointer still alive at %p -> %p", + IF_DEBUG(weak, debugBelch("Weak pointer still alive at %p -> %p", w, w->key)); continue; } @@ -1422,7 +1423,7 @@ upd_evacuee(StgClosure *p, StgClosure *dest) ASSERT((Bdescr((P_)p)->flags & BF_EVACUATED) == 0); // not true: (ToDo: perhaps it should be) // ASSERT(Bdescr((P_)dest)->flags & BF_EVACUATED); - p->header.info = &stg_EVACUATED_info; + SET_INFO(p, &stg_EVACUATED_info); ((StgEvacuated *)p)->evacuee = dest; } @@ -1659,7 +1660,7 @@ mkMutCons(StgClosure *ptr, generation *gen) extra reads/writes than we save. -------------------------------------------------------------------------- */ -static StgClosure * +REGPARM1 static StgClosure * evacuate(StgClosure *q) { StgClosure *to; @@ -1957,7 +1958,7 @@ loop: //ToDo: derive size etc from reverted IP //to = copy(q,size,stp); IF_DEBUG(gc, - belch("@@ evacuate: RBH %p (%s) to %p (%s)", + debugBelch("@@ evacuate: RBH %p (%s) to %p (%s)", q, info_type(q), to, info_type(to))); return to; } @@ -1966,7 +1967,7 @@ loop: ASSERT(sizeofW(StgBlockedFetch) >= MIN_NONUPD_SIZE); to = copy(q,sizeofW(StgBlockedFetch),stp); IF_DEBUG(gc, - belch("@@ evacuate: %p (%s) to %p (%s)", + debugBelch("@@ evacuate: %p (%s) to %p (%s)", q, info_type(q), to, info_type(to))); return to; @@ -1977,7 +1978,7 @@ loop: ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE); to = copy(q,sizeofW(StgFetchMe),stp); IF_DEBUG(gc, - belch("@@ evacuate: %p (%s) to %p (%s)", + debugBelch("@@ evacuate: %p (%s) to %p (%s)", q, info_type(q), to, info_type(to))); return to; @@ -1985,7 +1986,7 @@ loop: ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE); to = copy(q,sizeofW(StgFetchMeBlockingQueue),stp); IF_DEBUG(gc, - belch("@@ evacuate: %p (%s) to %p (%s)", + debugBelch("@@ evacuate: %p (%s) to %p (%s)", q, info_type(q), to, info_type(to))); return to; #endif @@ -2012,13 +2013,28 @@ loop: thunk is unchanged. -------------------------------------------------------------------------- */ +static inline rtsBool +is_to_space ( StgClosure *p ) +{ + bdescr *bd; + + bd = Bdescr((StgPtr)p); + if (HEAP_ALLOCED(p) && + ((bd->flags & BF_EVACUATED) + || ((bd->flags & BF_COMPACTED) && + is_marked((P_)p,bd)))) { + return rtsTrue; + } else { + return rtsFalse; + } +} + static StgClosure * eval_thunk_selector( nat field, StgSelector * p ) { StgInfoTable *info; const StgInfoTable *info_ptr; StgClosure *selectee; - bdescr *bd; selectee = p->selectee; @@ -2065,12 +2081,10 @@ selector_loop: // point to to-space objects, because that happens when // scavenging. // - bd = Bdescr((StgPtr)selectee); - if (HEAP_ALLOCED(selectee) && - ((bd->flags & BF_EVACUATED) - || ((bd->flags & BF_COMPACTED) && - bd->gen_no <= N && - is_marked((P_)selectee,bd)))) { + // The to-space test is now embodied in the in_to_space() inline + // function, as it is re-used below. + // + if (is_to_space(selectee)) { goto bale_out; } @@ -2088,9 +2102,21 @@ selector_loop: ASSERT(field < (StgWord32)(info->layout.payload.ptrs + info->layout.payload.nptrs)); - // ToDo: shouldn't we test whether this pointer is in - // to-space? - return selectee->payload[field]; + // Select the right field from the constructor, and check + // that the result isn't in to-space. It might be in + // to-space if, for example, this constructor contains + // pointers to younger-gen objects (and is on the mut-once + // list). + // + { + StgClosure *q; + q = selectee->payload[field]; + if (is_to_space(q)) { + goto bale_out; + } else { + return q; + } + } case IND: case IND_PERM: @@ -2134,15 +2160,15 @@ selector_loop: // For the purposes of LDV profiling, we have destroyed // the original selector thunk. SET_INFO(p, info_ptr); - LDV_recordDead_FILL_SLOP_DYNAMIC(selectee); + LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC(selectee); #endif ((StgInd *)selectee)->indirectee = val; SET_INFO(selectee,&stg_IND_info); -#ifdef PROFILING + // For the purposes of LDV profiling, we have created an // indirection. - LDV_recordCreate(selectee); -#endif + LDV_RECORD_CREATE(selectee); + selectee = val; goto selector_loop; } @@ -2288,7 +2314,7 @@ scavenge_fun_srt(const StgInfoTable *info) StgFunInfoTable *fun_info; fun_info = itbl_to_fun_itbl(info); - scavenge_srt((StgClosure **)fun_info->srt, fun_info->i.srt_bitmap); + scavenge_srt((StgClosure **)fun_info->f.srt, fun_info->i.srt_bitmap); } STATIC_INLINE void @@ -2341,19 +2367,19 @@ scavenge_arg_block (StgFunInfoTable *fun_info, StgClosure **args) nat size; p = (StgPtr)args; - switch (fun_info->fun_type) { + switch (fun_info->f.fun_type) { case ARG_GEN: - bitmap = BITMAP_BITS(fun_info->bitmap); - size = BITMAP_SIZE(fun_info->bitmap); + bitmap = BITMAP_BITS(fun_info->f.bitmap); + size = BITMAP_SIZE(fun_info->f.bitmap); goto small_bitmap; case ARG_GEN_BIG: - size = ((StgLargeBitmap *)fun_info->bitmap)->size; - scavenge_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap, size); + size = ((StgLargeBitmap *)fun_info->f.bitmap)->size; + scavenge_large_bitmap(p, (StgLargeBitmap *)fun_info->f.bitmap, size); p += size; break; default: - bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]); - size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->fun_type]); + bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]); + size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]); small_bitmap: while (size > 0) { if ((bitmap & 1) == 0) { @@ -2382,12 +2408,12 @@ scavenge_PAP (StgPAP *pap) p = (StgPtr)pap->payload; size = pap->n_args; - switch (fun_info->fun_type) { + switch (fun_info->f.fun_type) { case ARG_GEN: - bitmap = BITMAP_BITS(fun_info->bitmap); + bitmap = BITMAP_BITS(fun_info->f.bitmap); goto small_bitmap; case ARG_GEN_BIG: - scavenge_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap, size); + scavenge_large_bitmap(p, (StgLargeBitmap *)fun_info->f.bitmap, size); p += size; break; case ARG_BCO: @@ -2395,7 +2421,7 @@ scavenge_PAP (StgPAP *pap) p += size; break; default: - bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]); + bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]); small_bitmap: size = pap->n_args; while (size > 0) { @@ -2581,14 +2607,12 @@ scavenge(step *stp) LDV_recordDead((StgClosure *)p, sizeofW(StgInd)); #endif // - // Todo: maybe use SET_HDR() and remove LDV_recordCreate()? + // Todo: maybe use SET_HDR() and remove LDV_RECORD_CREATE()? // SET_INFO(((StgClosure *)p), &stg_IND_OLDGEN_PERM_info); -#ifdef PROFILING - // @LDV profiling + // We pretend that p has just been created. - LDV_recordCreate((StgClosure *)p); -#endif + LDV_RECORD_CREATE((StgClosure *)p); } // fall through case IND_OLDGEN_PERM: @@ -2726,7 +2750,7 @@ scavenge(step *stp) recordMutable((StgMutClosure *)to); failed_to_evac = rtsFalse; // mutable anyhow. IF_DEBUG(gc, - belch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)", + debugBelch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)", p, info_type(p), (StgClosure *)rbh->blocking_queue)); // ToDo: use size of reverted closure here! p += BLACKHOLE_sizeW(); @@ -2747,7 +2771,7 @@ scavenge(step *stp) recordMutable((StgMutClosure *)bf); } IF_DEBUG(gc, - belch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it", + debugBelch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it", bf, info_type((StgClosure *)bf), bf->node, info_type(bf->node))); p += sizeofW(StgBlockedFetch); @@ -2771,7 +2795,7 @@ scavenge(step *stp) recordMutable((StgMutClosure *)fmbq); } IF_DEBUG(gc, - belch("@@ scavenge: %p (%s) exciting, isn't it", + debugBelch("@@ scavenge: %p (%s) exciting, isn't it", p, info_type((StgClosure *)p))); p += sizeofW(StgFetchMeBlockingQueue); break; @@ -3035,7 +3059,7 @@ linear_scan: recordMutable((StgMutClosure *)rbh); failed_to_evac = rtsFalse; // mutable anyhow. IF_DEBUG(gc, - belch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)", + debugBelch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)", p, info_type(p), (StgClosure *)rbh->blocking_queue)); break; } @@ -3054,7 +3078,7 @@ linear_scan: recordMutable((StgMutClosure *)bf); } IF_DEBUG(gc, - belch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it", + debugBelch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it", bf, info_type((StgClosure *)bf), bf->node, info_type(bf->node))); break; @@ -3076,7 +3100,7 @@ linear_scan: recordMutable((StgMutClosure *)fmbq); } IF_DEBUG(gc, - belch("@@ scavenge: %p (%s) exciting, isn't it", + debugBelch("@@ scavenge: %p (%s) exciting, isn't it", p, info_type((StgClosure *)p))); break; } @@ -3099,7 +3123,7 @@ linear_scan: // start a new linear scan if the mark stack overflowed at some point if (mark_stack_overflowed && oldgen_scan_bd == NULL) { - IF_DEBUG(gc, belch("scavenge_mark_stack: starting linear scan")); + IF_DEBUG(gc, debugBelch("scavenge_mark_stack: starting linear scan")); mark_stack_overflowed = rtsFalse; oldgen_scan_bd = oldest_gen->steps[0].blocks; oldgen_scan = oldgen_scan_bd->start; @@ -3343,7 +3367,7 @@ scavenge_mut_once_list(generation *gen) } else { size = gen->steps[0].scan - start; } - belch("evac IND_OLDGEN: %ld bytes", size * sizeof(W_)); + debugBelch("evac IND_OLDGEN: %ld bytes", size * sizeof(W_)); } #endif @@ -3719,7 +3743,7 @@ scavenge_stack(StgPtr p, StgPtr stack_end) StgWord bitmap; nat size; - //IF_DEBUG(sanity, belch(" scavenging stack between %p and %p", p, stack_end)); + //IF_DEBUG(sanity, debugBelch(" scavenging stack between %p and %p", p, stack_end)); /* * Each time around this loop, we are looking at a chunk of stack @@ -3791,16 +3815,16 @@ scavenge_stack(StgPtr p, StgPtr stack_end) dyn = ((StgRetDyn *)p)->liveness; // traverse the bitmap first - bitmap = GET_LIVENESS(dyn); + bitmap = RET_DYN_LIVENESS(dyn); p = (P_)&((StgRetDyn *)p)->payload[0]; size = RET_DYN_BITMAP_SIZE; p = scavenge_small_bitmap(p, size, bitmap); // skip over the non-ptr words - p += GET_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE; + p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE; // follow the ptr words - for (size = GET_PTRS(dyn); size > 0; size--) { + for (size = RET_DYN_PTRS(dyn); size > 0; size--) { (StgClosure *)*p = evacuate((StgClosure *)*p); p++; } @@ -3911,7 +3935,7 @@ revertCAFs( void ) for (c = (StgIndStatic *)caf_list; c != NULL; c = (StgIndStatic *)c->static_link) { - c->header.info = c->saved_info; + SET_INFO(c, c->saved_info); c->saved_info = NULL; // could, but not necessary: c->static_link = NULL; } @@ -3963,7 +3987,7 @@ gcCAFs(void) ASSERT(info->type == IND_STATIC); if (STATIC_LINK(info,p) == NULL) { - IF_DEBUG(gccafs, belch("CAF gc'd at 0x%04lx", (long)p)); + IF_DEBUG(gccafs, debugBelch("CAF gc'd at 0x%04lx", (long)p)); // black hole it SET_INFO(p,&stg_BLACKHOLE_info); p = STATIC_LINK2(info,p); @@ -3977,7 +4001,7 @@ gcCAFs(void) } - // belch("%d CAFs live", i); + // debugBelch("%d CAFs live", i); } #endif @@ -4024,7 +4048,7 @@ threadLazyBlackHole(StgTSO *tso) if (bh->header.info != &stg_BLACKHOLE_BQ_info && bh->header.info != &stg_CAF_BLACKHOLE_info) { #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG) - belch("Unexpected lazy BHing required at 0x%04x",(int)bh); + debugBelch("Unexpected lazy BHing required at 0x%04x",(int)bh); #endif #ifdef PROFILING // @LDV profiling @@ -4032,11 +4056,9 @@ threadLazyBlackHole(StgTSO *tso) LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh); #endif SET_INFO(bh,&stg_BLACKHOLE_info); -#ifdef PROFILING - // @LDV profiling + // We pretend that bh has just been created. - LDV_recordCreate(bh); -#endif + LDV_RECORD_CREATE(bh); } frame = (StgClosure *) ((StgUpdateFrame *)frame + 1); @@ -4153,7 +4175,7 @@ threadSqueezeStack(StgTSO *tso) bh->header.info != &stg_BLACKHOLE_BQ_info && bh->header.info != &stg_CAF_BLACKHOLE_info) { #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG) - belch("Unexpected lazy BHing required at 0x%04x",(int)bh); + debugBelch("Unexpected lazy BHing required at 0x%04x",(int)bh); #endif #ifdef DEBUG /* zero out the slop so that the sanity checker can tell @@ -4179,12 +4201,11 @@ threadSqueezeStack(StgTSO *tso) // We pretend that bh is now dead. LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh); #endif - // Todo: maybe use SET_HDR() and remove LDV_recordCreate()? + // Todo: maybe use SET_HDR() and remove LDV_RECORD_CREATE()? SET_INFO(bh,&stg_BLACKHOLE_info); -#ifdef PROFILING + // We pretend that bh has just been created. - LDV_recordCreate(bh); -#endif + LDV_RECORD_CREATE(bh); } prev_was_update_frame = rtsTrue; @@ -4289,12 +4310,12 @@ printMutOnceList(generation *gen) p = gen->mut_once_list; next = p->mut_link; - fprintf(stderr, "@@ Mut once list %p: ", gen->mut_once_list); + debugBelch("@@ Mut once list %p: ", gen->mut_once_list); for (; p != END_MUT_LIST; p = next, next = p->mut_link) { - fprintf(stderr, "%p (%s), ", + debugBelch("%p (%s), ", p, info_type((StgClosure *)p)); } - fputc('\n', stderr); + debugBelch("\n"); } void @@ -4305,12 +4326,12 @@ printMutableList(generation *gen) p = gen->mut_list; next = p->mut_link; - fprintf(stderr, "@@ Mutable list %p: ", gen->mut_list); + debugBelch("@@ Mutable list %p: ", gen->mut_list); for (; p != END_MUT_LIST; p = next, next = p->mut_link) { - fprintf(stderr, "%p (%s), ", + debugBelch("%p (%s), ", p, info_type((StgClosure *)p)); } - fputc('\n', stderr); + debugBelch("\n"); } STATIC_INLINE rtsBool