Similarly for Scav.c/Scav.c-inc.
# -O3 helps unroll some loops (especially in copy() with a constant argument).
sm/Evac_HC_OPTS += -optc-funroll-loops
+ifneq "$(findstring thr, $(way))" ""
+EXTRA_SRCS += sm/Evac_thr.c sm/Scav_thr.c
+
+sm/Evac_thr.c : sm/Evac.c
+ cp $< $@
+sm/Scav_thr.c : sm/Scav.c
+ cp $< $@
+
+sm/Evac_thr_HC_OPTS += -optc-DPARALLEL_GC
+sm/Scav_thr_HC_OPTS += -optc-DPARALLEL_GC
+else
+EXCLUDED_SRCS += sm/Evac_thr.c sm/Scav_thr.c
+endif
+
# Without this, thread_obj will not be inlined (at least on x86 with GCC 4.1.0)
sm/Compact_HC_OPTS += -optc-finline-limit=2500
#include "Prelude.h"
#include "LdvProfile.h"
-#if defined(PROF_SPIN) && defined(THREADED_RTS)
+#if defined(PROF_SPIN) && defined(THREADED_RTS) && defined(PARALLEL_GC)
StgWord64 whitehole_spin = 0;
#endif
+#if defined(THREADED_RTS) && !defined(PARALLEL_GC)
+#define evacuate(p) evacuate1(p)
+#endif
+
+#if !defined(PARALLEL_GC)
+#define copy_tag_nolock(p, info, src, size, stp, tag) \
+ copy_tag(p, info, src, size, stp, tag)
+#endif
+
/* Used to avoid long recursion due to selector thunks
*/
#define MAX_THUNK_SELECTOR_DEPTH 16
The evacuate() code
-------------------------------------------------------------------------- */
-#undef PARALLEL_GC
-#include "Evac.c-inc"
+STATIC_INLINE void
+copy_tag(StgClosure **p, const StgInfoTable *info,
+ StgClosure *src, nat size, step *stp, StgWord tag)
+{
+ StgPtr to, from;
+ nat i;
+
+ to = alloc_for_copy(size,stp);
+
+ TICK_GC_WORDS_COPIED(size);
-#ifdef THREADED_RTS
-#define PARALLEL_GC
-#include "Evac.c-inc"
+ from = (StgPtr)src;
+ to[0] = (W_)info;
+ for (i = 1; i < size; i++) { // unroll for small i
+ to[i] = from[i];
+ }
+
+// if (to+size+2 < bd->start + BLOCK_SIZE_W) {
+// __builtin_prefetch(to + size + 2, 1);
+// }
+
+#if defined(PARALLEL_GC)
+ {
+ const StgInfoTable *new_info;
+ new_info = (const StgInfoTable *)cas((StgPtr)&src->header.info, (W_)info, MK_FORWARDING_PTR(to));
+ if (new_info != info) {
+ return evacuate(p); // does the failed_to_evac stuff
+ } else {
+ *p = TAG_CLOSURE(tag,(StgClosure*)to);
+ }
+ }
+#else
+ src->header.info = (const StgInfoTable *)MK_FORWARDING_PTR(to);
+ *p = TAG_CLOSURE(tag,(StgClosure*)to);
+#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);
+#endif
+}
+
+#if defined(PARALLEL_GC)
+STATIC_INLINE void
+copy_tag_nolock(StgClosure **p, const StgInfoTable *info,
+ StgClosure *src, nat size, step *stp, 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);
+
+ from = (StgPtr)src;
+ to[0] = (W_)info;
+ for (i = 1; i < size; i++) { // unroll for small i
+ to[i] = from[i];
+ }
+
+// if (to+size+2 < bd->start + BLOCK_SIZE_W) {
+// __builtin_prefetch(to + size + 2, 1);
+// }
+
+#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);
+#endif
+}
#endif
+/* 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 void
+copyPart(StgClosure **p, StgClosure *src, nat size_to_reserve, nat size_to_copy, step *stp)
+{
+ StgPtr to, from;
+ nat i;
+ StgWord info;
+
+#if defined(PARALLEL_GC)
+spin:
+ info = xchg((StgPtr)&src->header.info, (W_)&stg_WHITEHOLE_info);
+ if (info == (W_)&stg_WHITEHOLE_info) {
+#ifdef PROF_SPIN
+ whitehole_spin++;
+#endif
+ goto spin;
+ }
+ if (IS_FORWARDING_PTR(info)) {
+ src->header.info = (const StgInfoTable *)info;
+ evacuate(p); // does the failed_to_evac stuff
+ return ;
+ }
+#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);
+
+ from = (StgPtr)src;
+ to[0] = info;
+ for (i = 1; i < size_to_copy; i++) { // unroll for small i
+ to[i] = from[i];
+ }
+
+#if defined(PARALLEL_GC)
+ write_barrier();
+#endif
+ src->header.info = (const StgInfoTable*)MK_FORWARDING_PTR(to);
+
+#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_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
+}
+
+
+/* Copy wrappers that don't tag the closure after copying */
+STATIC_INLINE void
+copy(StgClosure **p, const StgInfoTable *info,
+ StgClosure *src, nat size, step *stp)
+{
+ copy_tag(p,info,src,size,stp,0);
+}
+
+/* ----------------------------------------------------------------------------
+ Evacuate
+
+ 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
+ evacuating an object which resides in generation M when we're
+ collecting up to generation N
+
+ if M >= gct->evac_step
+ if M > N do nothing
+ else evac to step->to
+
+ if M < gct->evac_step evac to gct->evac_step, 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.
+
+
+ OPTIMISATION NOTES:
+
+ evacuate() is the single most important function performance-wise
+ in the GC. Various things have been tried to speed it up, but as
+ far as I can tell the code generated by gcc 3.2 with -O2 is about
+ as good as it's going to get. We pass the argument to evacuate()
+ in a register using the 'regparm' attribute (see the prototype for
+ evacuate() near the top of this file).
+
+ Changing evacuate() to take an (StgClosure **) rather than
+ returning the new pointer seems attractive, because we can avoid
+ writing back the pointer when it hasn't changed (eg. for a static
+ object, or an object in a generation > N). However, I tried it and
+ it doesn't help. One reason is that the (StgClosure **) pointer
+ gets spilled to the stack inside evacuate(), resulting in far more
+ extra reads/writes than we save.
+ ------------------------------------------------------------------------- */
+
+REGPARM1 void
+evacuate(StgClosure **p)
+{
+ bdescr *bd = NULL;
+ step *stp;
+ StgClosure *q;
+ const StgInfoTable *info;
+ StgWord tag;
+
+ q = *p;
+
+loop:
+ /* The tag and the pointer are split, to be merged after evacing */
+ tag = GET_CLOSURE_TAG(q);
+ q = UNTAG_CLOSURE(q);
+
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
+
+ if (!HEAP_ALLOCED(q)) {
+
+ if (!major_gc) return;
+
+ info = get_itbl(q);
+ switch (info->type) {
+
+ case THUNK_STATIC:
+ if (info->srt_bitmap != 0) {
+ if (*THUNK_STATIC_LINK((StgClosure *)q) == NULL) {
+#ifndef THREADED_RTS
+ *THUNK_STATIC_LINK((StgClosure *)q) = gct->static_objects;
+ gct->static_objects = (StgClosure *)q;
+#else
+ StgPtr link;
+ link = (StgPtr)cas((StgPtr)THUNK_STATIC_LINK((StgClosure *)q),
+ (StgWord)NULL,
+ (StgWord)gct->static_objects);
+ if (link == NULL) {
+ gct->static_objects = (StgClosure *)q;
+ }
+#endif
+ }
+ }
+ return;
+
+ case FUN_STATIC:
+ if (info->srt_bitmap != 0 &&
+ *FUN_STATIC_LINK((StgClosure *)q) == NULL) {
+#ifndef THREADED_RTS
+ *FUN_STATIC_LINK((StgClosure *)q) = gct->static_objects;
+ gct->static_objects = (StgClosure *)q;
+#else
+ StgPtr link;
+ link = (StgPtr)cas((StgPtr)FUN_STATIC_LINK((StgClosure *)q),
+ (StgWord)NULL,
+ (StgWord)gct->static_objects);
+ if (link == NULL) {
+ gct->static_objects = (StgClosure *)q;
+ }
+#endif
+ }
+ return;
+
+ case IND_STATIC:
+ /* If q->saved_info != NULL, then it's a revertible CAF - it'll be
+ * 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) {
+#ifndef THREADED_RTS
+ *IND_STATIC_LINK((StgClosure *)q) = gct->static_objects;
+ gct->static_objects = (StgClosure *)q;
+#else
+ StgPtr link;
+ link = (StgPtr)cas((StgPtr)IND_STATIC_LINK((StgClosure *)q),
+ (StgWord)NULL,
+ (StgWord)gct->static_objects);
+ if (link == NULL) {
+ gct->static_objects = (StgClosure *)q;
+ }
+#endif
+ }
+ }
+ return;
+
+ case CONSTR_STATIC:
+ if (*STATIC_LINK(info,(StgClosure *)q) == NULL) {
+#ifndef THREADED_RTS
+ *STATIC_LINK(info,(StgClosure *)q) = gct->static_objects;
+ gct->static_objects = (StgClosure *)q;
+#else
+ StgPtr link;
+ link = (StgPtr)cas((StgPtr)STATIC_LINK(info,(StgClosure *)q),
+ (StgWord)NULL,
+ (StgWord)gct->static_objects);
+ if (link == NULL) {
+ gct->static_objects = (StgClosure *)q;
+ }
+#endif
+ }
+ /* I am assuming that static_objects pointers are not
+ * written to other objects, and thus, no need to retag. */
+ return;
+
+ case CONSTR_NOCAF_STATIC:
+ /* no need to put these on the static linked list, they don't need
+ * to be scavenged.
+ */
+ return;
+
+ default:
+ barf("evacuate(static): strange closure type %d", (int)(info->type));
+ }
+ }
+
+ bd = Bdescr((P_)q);
+
+ if ((bd->flags & (BF_LARGE | BF_COMPACTED | BF_EVACUATED)) != 0) {
+
+ // pointer into to-space: just return it. It might be a pointer
+ // into a generation that we aren't collecting (> N), or it
+ // might just be a pointer into to-space. The latter doesn't
+ // happen often, but allowing it makes certain things a bit
+ // easier; e.g. scavenging an object is idempotent, so it's OK to
+ // have an object on the mutable list multiple times.
+ if (bd->flags & BF_EVACUATED) {
+ // 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) {
+ gct->failed_to_evac = rtsTrue;
+ TICK_GC_FAILED_PROMOTION();
+ }
+ return;
+ }
+
+ /* 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);
+ return;
+ }
+
+ /* If the object is in a step that we're compacting, then we
+ * need to use an alternative evacuate procedure.
+ */
+ if (bd->flags & BF_COMPACTED) {
+ if (!is_marked((P_)q,bd)) {
+ mark((P_)q,bd);
+ if (mark_stack_full()) {
+ mark_stack_overflowed = rtsTrue;
+ reset_mark_stack();
+ }
+ push_mark_stack((P_)q);
+ }
+ return;
+ }
+ }
+
+ stp = bd->step->to;
+
+ 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
+ * 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
+ * manage to promote the object to the desired generation.
+ */
+ /*
+ * Optimisation: the check is fairly expensive, but we can often
+ * 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
+ * current object would be evacuated to, so we only do the full
+ * check if stp 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) {
+ gct->failed_to_evac = rtsTrue;
+ TICK_GC_FAILED_PROMOTION();
+ }
+ }
+ return;
+ }
+
+ switch (INFO_PTR_TO_STRUCT(info)->type) {
+
+ case WHITEHOLE:
+ goto loop;
+
+ case MUT_VAR_CLEAN:
+ case MUT_VAR_DIRTY:
+ case MVAR_CLEAN:
+ case MVAR_DIRTY:
+ copy(p,info,q,sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),stp);
+ return;
+
+ case CONSTR_0_1:
+ {
+ StgWord w = (StgWord)q->payload[0];
+ if (info == Czh_con_info &&
+ // unsigned, so always true: (StgChar)w >= MIN_CHARLIKE &&
+ (StgChar)w <= MAX_CHARLIKE) {
+ *p = TAG_CLOSURE(tag,
+ (StgClosure *)CHARLIKE_CLOSURE((StgChar)w)
+ );
+ }
+ else if (info == Izh_con_info &&
+ (StgInt)w >= MIN_INTLIKE && (StgInt)w <= MAX_INTLIKE) {
+ *p = TAG_CLOSURE(tag,
+ (StgClosure *)INTLIKE_CLOSURE((StgInt)w)
+ );
+ }
+ else {
+ copy_tag_nolock(p,info,q,sizeofW(StgHeader)+1,stp,tag);
+ }
+ return;
+ }
+
+ case FUN_0_1:
+ case FUN_1_0:
+ case CONSTR_1_0:
+ copy_tag_nolock(p,info,q,sizeofW(StgHeader)+1,stp,tag);
+ return;
+
+ case THUNK_1_0:
+ case THUNK_0_1:
+ copy(p,info,q,sizeofW(StgThunk)+1,stp);
+ 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;
+ }
+#endif
+ copy(p,info,q,sizeofW(StgThunk)+2,stp);
+ return;
+
+ case FUN_1_1:
+ case FUN_2_0:
+ case FUN_0_2:
+ case CONSTR_1_1:
+ case CONSTR_2_0:
+ copy_tag_nolock(p,info,q,sizeofW(StgHeader)+2,stp,tag);
+ return;
+
+ case CONSTR_0_2:
+ copy_tag_nolock(p,info,q,sizeofW(StgHeader)+2,stp,tag);
+ return;
+
+ case THUNK:
+ copy(p,info,q,thunk_sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),stp);
+ 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);
+ return;
+
+ case WEAK:
+ case STABLE_NAME:
+ copy_tag(p,info,q,sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),stp,tag);
+ 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);
+ return;
+
+ case THUNK_SELECTOR:
+ eval_thunk_selector(p, (StgSelector *)q, rtsTrue);
+ return;
+
+ case IND:
+ case IND_OLDGEN:
+ // follow chains of indirections, don't evacuate them
+ q = ((StgInd*)q)->indirectee;
+ *p = q;
+ goto loop;
+
+ case RET_BCO:
+ case RET_SMALL:
+ case RET_BIG:
+ case RET_DYN:
+ case UPDATE_FRAME:
+ case STOP_FRAME:
+ case CATCH_FRAME:
+ case CATCH_STM_FRAME:
+ case CATCH_RETRY_FRAME:
+ case ATOMICALLY_FRAME:
+ // shouldn't see these
+ barf("evacuate: stack frame at %p\n", q);
+
+ case PAP:
+ copy(p,info,q,pap_sizeW((StgPAP*)q),stp);
+ return;
+
+ case AP:
+ copy(p,info,q,ap_sizeW((StgAP*)q),stp);
+ return;
+
+ case AP_STACK:
+ copy(p,info,q,ap_stack_sizeW((StgAP_STACK*)q),stp);
+ return;
+
+ case ARR_WORDS:
+ // just copy the block
+ copy(p,info,q,arr_words_sizeW((StgArrWords *)q),stp);
+ return;
+
+ case MUT_ARR_PTRS_CLEAN:
+ case MUT_ARR_PTRS_DIRTY:
+ 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);
+ return;
+
+ case TSO:
+ {
+ StgTSO *tso = (StgTSO *)q;
+
+ /* 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;
+ }
+
+ /* To evacuate a small TSO, we need to relocate the update frame
+ * list it contains.
+ */
+ {
+ StgTSO *new_tso;
+ 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++;
+ }
+ 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);
+ return;
+
+ default:
+ barf("evacuate: strange closure type %d", (int)(INFO_PTR_TO_STRUCT(info)->type));
+ }
+
+ barf("evacuate");
+}
+
/* -----------------------------------------------------------------------------
Evacuate a large object
unchain_thunk_selectors(prev_thunk_selector, *q);
return;
}
-
-/* -----------------------------------------------------------------------------
- move_TSO is called to update the TSO structure after it has been
- moved from one place to another.
- -------------------------------------------------------------------------- */
-
-void
-move_TSO (StgTSO *src, StgTSO *dest)
-{
- ptrdiff_t diff;
-
- // relocate the stack pointer...
- diff = (StgPtr)dest - (StgPtr)src; // In *words*
- dest->sp = (StgPtr)dest->sp + diff;
-}
-
+++ /dev/null
-/* -----------------------------------------------------------------------*-c-*-
- *
- * (c) The GHC Team 1998-2008
- *
- * Generational garbage collector: evacuation functions
- *
- * ---------------------------------------------------------------------------*/
-
-// We have two versions of evacuate(): one for minor GC, and one for
-// non-minor, parallel, GC. This file contains the code for both,
-// controllled by the CPP symbol MINOR_GC.
-
-#if defined(THREADED_RTS)
-# if !defined(PARALLEL_GC)
-# define copy(a,b,c,d,e) copy1(a,b,c,d,e)
-# define copy_tag(a,b,c,d,e,f) copy_tag1(a,b,c,d,e,f)
-# define copy_tag_nolock(a,b,c,d,e,f) copy_tag1(a,b,c,d,e,f)
-# define copyPart(a,b,c,d,e) copyPart1(a,b,c,d,e)
-# define evacuate(a) evacuate1(a)
-# endif
-#else
-# define copy_tag_nolock(a,b,c,d,e,f) copy_tag(a,b,c,d,e,f)
-#endif
-
-STATIC_INLINE void
-copy_tag(StgClosure **p, const StgInfoTable *info,
- StgClosure *src, nat size, step *stp, StgWord tag)
-{
- StgPtr to, from;
- nat i;
-
- to = alloc_for_copy(size,stp);
-
- TICK_GC_WORDS_COPIED(size);
-
- from = (StgPtr)src;
- to[0] = (W_)info;
- for (i = 1; i < size; i++) { // unroll for small i
- to[i] = from[i];
- }
-
-// if (to+size+2 < bd->start + BLOCK_SIZE_W) {
-// __builtin_prefetch(to + size + 2, 1);
-// }
-
-#if defined(PARALLEL_GC)
- {
- const StgInfoTable *new_info;
- new_info = (const StgInfoTable *)cas((StgPtr)&src->header.info, (W_)info, MK_FORWARDING_PTR(to));
- if (new_info != info) {
- return evacuate(p); // does the failed_to_evac stuff
- } else {
- *p = TAG_CLOSURE(tag,(StgClosure*)to);
- }
- }
-#else
- src->header.info = (const StgInfoTable *)MK_FORWARDING_PTR(to);
- *p = TAG_CLOSURE(tag,(StgClosure*)to);
-#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);
-#endif
-}
-
-#if defined(PARALLEL_GC)
-STATIC_INLINE void
-copy_tag_nolock(StgClosure **p, const StgInfoTable *info,
- StgClosure *src, nat size, step *stp, 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);
-
- from = (StgPtr)src;
- to[0] = (W_)info;
- for (i = 1; i < size; i++) { // unroll for small i
- to[i] = from[i];
- }
-
-// if (to+size+2 < bd->start + BLOCK_SIZE_W) {
-// __builtin_prefetch(to + size + 2, 1);
-// }
-
-#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);
-#endif
-}
-#endif
-
-/* 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 void
-copyPart(StgClosure **p, StgClosure *src, nat size_to_reserve, nat size_to_copy, step *stp)
-{
- StgPtr to, from;
- nat i;
- StgWord info;
-
-#if defined(PARALLEL_GC)
-spin:
- info = xchg((StgPtr)&src->header.info, (W_)&stg_WHITEHOLE_info);
- if (info == (W_)&stg_WHITEHOLE_info) {
-#ifdef PROF_SPIN
- whitehole_spin++;
-#endif
- goto spin;
- }
- if (IS_FORWARDING_PTR(info)) {
- src->header.info = (const StgInfoTable *)info;
- evacuate(p); // does the failed_to_evac stuff
- return ;
- }
-#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);
-
- from = (StgPtr)src;
- to[0] = info;
- for (i = 1; i < size_to_copy; i++) { // unroll for small i
- to[i] = from[i];
- }
-
-#if defined(PARALLEL_GC)
- write_barrier();
-#endif
- src->header.info = (const StgInfoTable*)MK_FORWARDING_PTR(to);
-
-#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_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
-}
-
-
-/* Copy wrappers that don't tag the closure after copying */
-STATIC_INLINE void
-copy(StgClosure **p, const StgInfoTable *info,
- StgClosure *src, nat size, step *stp)
-{
- copy_tag(p,info,src,size,stp,0);
-}
-
-/* ----------------------------------------------------------------------------
- Evacuate
-
- 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
- evacuating an object which resides in generation M when we're
- collecting up to generation N
-
- if M >= gct->evac_step
- if M > N do nothing
- else evac to step->to
-
- if M < gct->evac_step evac to gct->evac_step, 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.
-
-
- OPTIMISATION NOTES:
-
- evacuate() is the single most important function performance-wise
- in the GC. Various things have been tried to speed it up, but as
- far as I can tell the code generated by gcc 3.2 with -O2 is about
- as good as it's going to get. We pass the argument to evacuate()
- in a register using the 'regparm' attribute (see the prototype for
- evacuate() near the top of this file).
-
- Changing evacuate() to take an (StgClosure **) rather than
- returning the new pointer seems attractive, because we can avoid
- writing back the pointer when it hasn't changed (eg. for a static
- object, or an object in a generation > N). However, I tried it and
- it doesn't help. One reason is that the (StgClosure **) pointer
- gets spilled to the stack inside evacuate(), resulting in far more
- extra reads/writes than we save.
- ------------------------------------------------------------------------- */
-
-REGPARM1 void
-evacuate(StgClosure **p)
-{
- bdescr *bd = NULL;
- step *stp;
- StgClosure *q;
- const StgInfoTable *info;
- StgWord tag;
-
- q = *p;
-
-loop:
- /* The tag and the pointer are split, to be merged after evacing */
- tag = GET_CLOSURE_TAG(q);
- q = UNTAG_CLOSURE(q);
-
- ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
-
- if (!HEAP_ALLOCED(q)) {
-
- if (!major_gc) return;
-
- info = get_itbl(q);
- switch (info->type) {
-
- case THUNK_STATIC:
- if (info->srt_bitmap != 0) {
- if (*THUNK_STATIC_LINK((StgClosure *)q) == NULL) {
-#ifndef THREADED_RTS
- *THUNK_STATIC_LINK((StgClosure *)q) = gct->static_objects;
- gct->static_objects = (StgClosure *)q;
-#else
- StgPtr link;
- link = (StgPtr)cas((StgPtr)THUNK_STATIC_LINK((StgClosure *)q),
- (StgWord)NULL,
- (StgWord)gct->static_objects);
- if (link == NULL) {
- gct->static_objects = (StgClosure *)q;
- }
-#endif
- }
- }
- return;
-
- case FUN_STATIC:
- if (info->srt_bitmap != 0 &&
- *FUN_STATIC_LINK((StgClosure *)q) == NULL) {
-#ifndef THREADED_RTS
- *FUN_STATIC_LINK((StgClosure *)q) = gct->static_objects;
- gct->static_objects = (StgClosure *)q;
-#else
- StgPtr link;
- link = (StgPtr)cas((StgPtr)FUN_STATIC_LINK((StgClosure *)q),
- (StgWord)NULL,
- (StgWord)gct->static_objects);
- if (link == NULL) {
- gct->static_objects = (StgClosure *)q;
- }
-#endif
- }
- return;
-
- case IND_STATIC:
- /* If q->saved_info != NULL, then it's a revertible CAF - it'll be
- * 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) {
-#ifndef THREADED_RTS
- *IND_STATIC_LINK((StgClosure *)q) = gct->static_objects;
- gct->static_objects = (StgClosure *)q;
-#else
- StgPtr link;
- link = (StgPtr)cas((StgPtr)IND_STATIC_LINK((StgClosure *)q),
- (StgWord)NULL,
- (StgWord)gct->static_objects);
- if (link == NULL) {
- gct->static_objects = (StgClosure *)q;
- }
-#endif
- }
- }
- return;
-
- case CONSTR_STATIC:
- if (*STATIC_LINK(info,(StgClosure *)q) == NULL) {
-#ifndef THREADED_RTS
- *STATIC_LINK(info,(StgClosure *)q) = gct->static_objects;
- gct->static_objects = (StgClosure *)q;
-#else
- StgPtr link;
- link = (StgPtr)cas((StgPtr)STATIC_LINK(info,(StgClosure *)q),
- (StgWord)NULL,
- (StgWord)gct->static_objects);
- if (link == NULL) {
- gct->static_objects = (StgClosure *)q;
- }
-#endif
- }
- /* I am assuming that static_objects pointers are not
- * written to other objects, and thus, no need to retag. */
- return;
-
- case CONSTR_NOCAF_STATIC:
- /* no need to put these on the static linked list, they don't need
- * to be scavenged.
- */
- return;
-
- default:
- barf("evacuate(static): strange closure type %d", (int)(info->type));
- }
- }
-
- bd = Bdescr((P_)q);
-
- if ((bd->flags & (BF_LARGE | BF_COMPACTED | BF_EVACUATED)) != 0) {
-
- // pointer into to-space: just return it. It might be a pointer
- // into a generation that we aren't collecting (> N), or it
- // might just be a pointer into to-space. The latter doesn't
- // happen often, but allowing it makes certain things a bit
- // easier; e.g. scavenging an object is idempotent, so it's OK to
- // have an object on the mutable list multiple times.
- if (bd->flags & BF_EVACUATED) {
- // 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) {
- gct->failed_to_evac = rtsTrue;
- TICK_GC_FAILED_PROMOTION();
- }
- return;
- }
-
- /* 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);
- return;
- }
-
- /* If the object is in a step that we're compacting, then we
- * need to use an alternative evacuate procedure.
- */
- if (bd->flags & BF_COMPACTED) {
- if (!is_marked((P_)q,bd)) {
- mark((P_)q,bd);
- if (mark_stack_full()) {
- mark_stack_overflowed = rtsTrue;
- reset_mark_stack();
- }
- push_mark_stack((P_)q);
- }
- return;
- }
- }
-
- stp = bd->step->to;
-
- 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
- * 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
- * manage to promote the object to the desired generation.
- */
- /*
- * Optimisation: the check is fairly expensive, but we can often
- * 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
- * current object would be evacuated to, so we only do the full
- * check if stp 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) {
- gct->failed_to_evac = rtsTrue;
- TICK_GC_FAILED_PROMOTION();
- }
- }
- return;
- }
-
- switch (INFO_PTR_TO_STRUCT(info)->type) {
-
- case WHITEHOLE:
- goto loop;
-
- case MUT_VAR_CLEAN:
- case MUT_VAR_DIRTY:
- case MVAR_CLEAN:
- case MVAR_DIRTY:
- copy(p,info,q,sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),stp);
- return;
-
- case CONSTR_0_1:
- {
- StgWord w = (StgWord)q->payload[0];
- if (info == Czh_con_info &&
- // unsigned, so always true: (StgChar)w >= MIN_CHARLIKE &&
- (StgChar)w <= MAX_CHARLIKE) {
- *p = TAG_CLOSURE(tag,
- (StgClosure *)CHARLIKE_CLOSURE((StgChar)w)
- );
- }
- else if (info == Izh_con_info &&
- (StgInt)w >= MIN_INTLIKE && (StgInt)w <= MAX_INTLIKE) {
- *p = TAG_CLOSURE(tag,
- (StgClosure *)INTLIKE_CLOSURE((StgInt)w)
- );
- }
- else {
- copy_tag_nolock(p,info,q,sizeofW(StgHeader)+1,stp,tag);
- }
- return;
- }
-
- case FUN_0_1:
- case FUN_1_0:
- case CONSTR_1_0:
- copy_tag_nolock(p,info,q,sizeofW(StgHeader)+1,stp,tag);
- return;
-
- case THUNK_1_0:
- case THUNK_0_1:
- copy(p,info,q,sizeofW(StgThunk)+1,stp);
- 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;
- }
-#endif
- copy(p,info,q,sizeofW(StgThunk)+2,stp);
- return;
-
- case FUN_1_1:
- case FUN_2_0:
- case FUN_0_2:
- case CONSTR_1_1:
- case CONSTR_2_0:
- copy_tag_nolock(p,info,q,sizeofW(StgHeader)+2,stp,tag);
- return;
-
- case CONSTR_0_2:
- copy_tag_nolock(p,info,q,sizeofW(StgHeader)+2,stp,tag);
- return;
-
- case THUNK:
- copy(p,info,q,thunk_sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),stp);
- 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);
- return;
-
- case WEAK:
- case STABLE_NAME:
- copy_tag(p,info,q,sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),stp,tag);
- 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);
- return;
-
- case THUNK_SELECTOR:
- eval_thunk_selector(p, (StgSelector *)q, rtsTrue);
- return;
-
- case IND:
- case IND_OLDGEN:
- // follow chains of indirections, don't evacuate them
- q = ((StgInd*)q)->indirectee;
- *p = q;
- goto loop;
-
- case RET_BCO:
- case RET_SMALL:
- case RET_BIG:
- case RET_DYN:
- case UPDATE_FRAME:
- case STOP_FRAME:
- case CATCH_FRAME:
- case CATCH_STM_FRAME:
- case CATCH_RETRY_FRAME:
- case ATOMICALLY_FRAME:
- // shouldn't see these
- barf("evacuate: stack frame at %p\n", q);
-
- case PAP:
- copy(p,info,q,pap_sizeW((StgPAP*)q),stp);
- return;
-
- case AP:
- copy(p,info,q,ap_sizeW((StgAP*)q),stp);
- return;
-
- case AP_STACK:
- copy(p,info,q,ap_stack_sizeW((StgAP_STACK*)q),stp);
- return;
-
- case ARR_WORDS:
- // just copy the block
- copy(p,info,q,arr_words_sizeW((StgArrWords *)q),stp);
- return;
-
- case MUT_ARR_PTRS_CLEAN:
- case MUT_ARR_PTRS_DIRTY:
- 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);
- return;
-
- case TSO:
- {
- StgTSO *tso = (StgTSO *)q;
-
- /* 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;
- }
-
- /* To evacuate a small TSO, we need to relocate the update frame
- * list it contains.
- */
- {
- StgTSO *new_tso;
- 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++;
- }
- 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);
- return;
-
- default:
- barf("evacuate: strange closure type %d", (int)(INFO_PTR_TO_STRUCT(info)->type));
- }
-
- barf("evacuate");
-}
-
-#undef copy
-#undef copy_tag
-#undef copy_tag_nolock
-#undef copyPart
-#undef evacuate
return n_running;
}
+static rtsBool
+any_work (void)
+{
+ int s;
+ step_workspace *ws;
+
+ gct->any_work++;
+
+ write_barrier();
+
+ // scavenge objects in compacted generation
+ if (mark_stack_overflowed || oldgen_scan_bd != NULL ||
+ (mark_stack_bdescr != NULL && !mark_stack_empty())) {
+ return rtsTrue;
+ }
+
+ // Check for global work in any step. We don't need to check for
+ // local work, because we have already exited scavenge_loop(),
+ // which means there is no local work for this thread.
+ for (s = total_steps-1; s >= 0; s--) {
+ if (s == 0 && RtsFlags.GcFlags.generations > 1) {
+ continue;
+ }
+ ws = &gct->steps[s];
+ if (ws->todo_large_objects) return rtsTrue;
+ if (ws->step->todos) return rtsTrue;
+ }
+
+ gct->no_work++;
+
+ return rtsFalse;
+}
+
static void
scavenge_until_all_done (void)
{
debugTrace(DEBUG_gc, "GC thread %d working", gct->thread_index);
loop:
+#if defined(THREADED_RTS)
+ if (n_gc_threads > 1) {
+ scavenge_loop();
+ } else {
+ scavenge_loop1();
+ }
+#else
scavenge_loop();
+#endif
+
// scavenge_loop() only exits when there's no work to do
r = dec_running();
StgLargeBitmap *large_bitmap,
nat size );
-
-/* Similar to scavenge_large_bitmap(), but we don't write back the
- * pointers we get back from evacuate().
- */
-static void
-scavenge_large_srt_bitmap( StgLargeSRT *large_srt )
-{
- nat i, b, size;
- StgWord bitmap;
- StgClosure **p;
-
- b = 0;
- bitmap = large_srt->l.bitmap[b];
- size = (nat)large_srt->l.size;
- p = (StgClosure **)large_srt->srt;
- for (i = 0; i < size; ) {
- if ((bitmap & 1) != 0) {
- evacuate(p);
- }
- i++;
- p++;
- if (i % BITS_IN(W_) == 0) {
- b++;
- bitmap = large_srt->l.bitmap[b];
- } else {
- bitmap = bitmap >> 1;
- }
- }
-}
-
-/* evacuate the SRT. If srt_bitmap is zero, then there isn't an
- * srt field in the info table. That's ok, because we'll
- * never dereference it.
- */
-STATIC_INLINE void
-scavenge_srt (StgClosure **srt, nat srt_bitmap)
-{
- nat bitmap;
- StgClosure **p;
-
- bitmap = srt_bitmap;
- p = srt;
-
- if (bitmap == (StgHalfWord)(-1)) {
- scavenge_large_srt_bitmap( (StgLargeSRT *)srt );
- return;
- }
-
- while (bitmap != 0) {
- if ((bitmap & 1) != 0) {
-#if defined(__PIC__) && defined(mingw32_TARGET_OS)
- // Special-case to handle references to closures hiding out in DLLs, since
- // double indirections required to get at those. The code generator knows
- // which is which when generating the SRT, so it stores the (indirect)
- // reference to the DLL closure in the table by first adding one to it.
- // We check for this here, and undo the addition before evacuating it.
- //
- // If the SRT entry hasn't got bit 0 set, the SRT entry points to a
- // closure that's fixed at link-time, and no extra magic is required.
- if ( (unsigned long)(*srt) & 0x1 ) {
- evacuate(stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)));
- } else {
- evacuate(p);
- }
-#else
- evacuate(p);
+#if defined(THREADED_RTS) && !defined(PARALLEL_GC)
+# define evacuate(a) evacuate1(a)
+# define recordMutableGen_GC(a,b) recordMutableGen(a,b)
+# define scavenge_loop(a) scavenge_loop1(a)
+# define scavenge_mutable_list(g) scavenge_mutable_list1(g)
#endif
- }
- p++;
- bitmap = bitmap >> 1;
- }
-}
-
-
-STATIC_INLINE void
-scavenge_thunk_srt(const StgInfoTable *info)
-{
- StgThunkInfoTable *thunk_info;
-
- if (!major_gc) return;
-
- thunk_info = itbl_to_thunk_itbl(info);
- scavenge_srt((StgClosure **)GET_SRT(thunk_info), thunk_info->i.srt_bitmap);
-}
-
-STATIC_INLINE void
-scavenge_fun_srt(const StgInfoTable *info)
-{
- StgFunInfoTable *fun_info;
-
- if (!major_gc) return;
-
- fun_info = itbl_to_fun_itbl(info);
- scavenge_srt((StgClosure **)GET_FUN_SRT(fun_info), fun_info->i.srt_bitmap);
-}
/* -----------------------------------------------------------------------------
Scavenge a TSO.
}
/* -----------------------------------------------------------------------------
+ Scavenge SRTs
+ -------------------------------------------------------------------------- */
+
+/* Similar to scavenge_large_bitmap(), but we don't write back the
+ * pointers we get back from evacuate().
+ */
+static void
+scavenge_large_srt_bitmap( StgLargeSRT *large_srt )
+{
+ nat i, b, size;
+ StgWord bitmap;
+ StgClosure **p;
+
+ b = 0;
+ bitmap = large_srt->l.bitmap[b];
+ size = (nat)large_srt->l.size;
+ p = (StgClosure **)large_srt->srt;
+ for (i = 0; i < size; ) {
+ if ((bitmap & 1) != 0) {
+ evacuate(p);
+ }
+ i++;
+ p++;
+ if (i % BITS_IN(W_) == 0) {
+ b++;
+ bitmap = large_srt->l.bitmap[b];
+ } else {
+ bitmap = bitmap >> 1;
+ }
+ }
+}
+
+/* evacuate the SRT. If srt_bitmap is zero, then there isn't an
+ * srt field in the info table. That's ok, because we'll
+ * never dereference it.
+ */
+STATIC_INLINE void
+scavenge_srt (StgClosure **srt, nat srt_bitmap)
+{
+ nat bitmap;
+ StgClosure **p;
+
+ bitmap = srt_bitmap;
+ p = srt;
+
+ if (bitmap == (StgHalfWord)(-1)) {
+ scavenge_large_srt_bitmap( (StgLargeSRT *)srt );
+ return;
+ }
+
+ while (bitmap != 0) {
+ if ((bitmap & 1) != 0) {
+#if defined(__PIC__) && defined(mingw32_TARGET_OS)
+ // Special-case to handle references to closures hiding out in DLLs, since
+ // double indirections required to get at those. The code generator knows
+ // which is which when generating the SRT, so it stores the (indirect)
+ // reference to the DLL closure in the table by first adding one to it.
+ // We check for this here, and undo the addition before evacuating it.
+ //
+ // If the SRT entry hasn't got bit 0 set, the SRT entry points to a
+ // closure that's fixed at link-time, and no extra magic is required.
+ if ( (unsigned long)(*srt) & 0x1 ) {
+ evacuate(stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)));
+ } else {
+ evacuate(p);
+ }
+#else
+ evacuate(p);
+#endif
+ }
+ p++;
+ bitmap = bitmap >> 1;
+ }
+}
+
+
+STATIC_INLINE void
+scavenge_thunk_srt(const StgInfoTable *info)
+{
+ StgThunkInfoTable *thunk_info;
+
+ if (!major_gc) return;
+
+ thunk_info = itbl_to_thunk_itbl(info);
+ scavenge_srt((StgClosure **)GET_SRT(thunk_info), thunk_info->i.srt_bitmap);
+}
+
+STATIC_INLINE void
+scavenge_fun_srt(const StgInfoTable *info)
+{
+ StgFunInfoTable *fun_info;
+
+ if (!major_gc) return;
+
+ fun_info = itbl_to_fun_itbl(info);
+ scavenge_srt((StgClosure **)GET_FUN_SRT(fun_info), fun_info->i.srt_bitmap);
+}
+
+/* -----------------------------------------------------------------------------
+ Scavenge a block from the given scan pointer up to bd->free.
+
+ evac_step is set by the caller to be either zero (for a step in a
+ generation < N) or G where G is the generation of the step being
+ scavenged.
+
+ We sometimes temporarily change evac_step back to zero if we're
+ scavenging a mutable object where eager promotion isn't such a good
+ idea.
+ -------------------------------------------------------------------------- */
+
+static void
+scavenge_block (bdescr *bd)
+{
+ StgPtr p, q;
+ StgInfoTable *info;
+ step *saved_evac_step;
+ rtsBool saved_eager_promotion;
+ step_workspace *ws;
+
+ debugTrace(DEBUG_gc, "scavenging block %p (gen %d, step %d) @ %p",
+ bd->start, bd->gen_no, bd->step->no, bd->u.scan);
+
+ gct->scan_bd = bd;
+ gct->evac_step = bd->step;
+ saved_evac_step = gct->evac_step;
+ saved_eager_promotion = gct->eager_promotion;
+ gct->failed_to_evac = rtsFalse;
+
+ ws = &gct->steps[bd->step->abs_no];
+
+ p = bd->u.scan;
+
+ // we might be evacuating into the very object that we're
+ // scavenging, so we have to check the real bd->free pointer each
+ // time around the loop.
+ while (p < bd->free || (bd == ws->todo_bd && p < ws->todo_free)) {
+
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
+ info = get_itbl((StgClosure *)p);
+
+ ASSERT(gct->thunk_selector_depth == 0);
+
+ q = p;
+ switch (info->type) {
+
+ case MVAR_CLEAN:
+ case MVAR_DIRTY:
+ {
+ StgMVar *mvar = ((StgMVar *)p);
+ gct->eager_promotion = rtsFalse;
+ evacuate((StgClosure **)&mvar->head);
+ evacuate((StgClosure **)&mvar->tail);
+ evacuate((StgClosure **)&mvar->value);
+ gct->eager_promotion = saved_eager_promotion;
+
+ if (gct->failed_to_evac) {
+ mvar->header.info = &stg_MVAR_DIRTY_info;
+ } else {
+ mvar->header.info = &stg_MVAR_CLEAN_info;
+ }
+ p += sizeofW(StgMVar);
+ break;
+ }
+
+ case FUN_2_0:
+ scavenge_fun_srt(info);
+ evacuate(&((StgClosure *)p)->payload[1]);
+ evacuate(&((StgClosure *)p)->payload[0]);
+ p += sizeofW(StgHeader) + 2;
+ break;
+
+ case THUNK_2_0:
+ scavenge_thunk_srt(info);
+ evacuate(&((StgThunk *)p)->payload[1]);
+ evacuate(&((StgThunk *)p)->payload[0]);
+ p += sizeofW(StgThunk) + 2;
+ break;
+
+ case CONSTR_2_0:
+ evacuate(&((StgClosure *)p)->payload[1]);
+ evacuate(&((StgClosure *)p)->payload[0]);
+ p += sizeofW(StgHeader) + 2;
+ break;
+
+ case THUNK_1_0:
+ scavenge_thunk_srt(info);
+ evacuate(&((StgThunk *)p)->payload[0]);
+ p += sizeofW(StgThunk) + 1;
+ break;
+
+ case FUN_1_0:
+ scavenge_fun_srt(info);
+ case CONSTR_1_0:
+ evacuate(&((StgClosure *)p)->payload[0]);
+ p += sizeofW(StgHeader) + 1;
+ break;
+
+ case THUNK_0_1:
+ scavenge_thunk_srt(info);
+ p += sizeofW(StgThunk) + 1;
+ break;
+
+ case FUN_0_1:
+ scavenge_fun_srt(info);
+ case CONSTR_0_1:
+ p += sizeofW(StgHeader) + 1;
+ break;
+
+ case THUNK_0_2:
+ scavenge_thunk_srt(info);
+ p += sizeofW(StgThunk) + 2;
+ break;
+
+ case FUN_0_2:
+ scavenge_fun_srt(info);
+ case CONSTR_0_2:
+ p += sizeofW(StgHeader) + 2;
+ break;
+
+ case THUNK_1_1:
+ scavenge_thunk_srt(info);
+ evacuate(&((StgThunk *)p)->payload[0]);
+ p += sizeofW(StgThunk) + 2;
+ break;
+
+ case FUN_1_1:
+ scavenge_fun_srt(info);
+ case CONSTR_1_1:
+ evacuate(&((StgClosure *)p)->payload[0]);
+ p += sizeofW(StgHeader) + 2;
+ break;
+
+ case FUN:
+ scavenge_fun_srt(info);
+ goto gen_obj;
+
+ case THUNK:
+ {
+ StgPtr end;
+
+ scavenge_thunk_srt(info);
+ end = (P_)((StgThunk *)p)->payload + info->layout.payload.ptrs;
+ for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
+ evacuate((StgClosure **)p);
+ }
+ p += info->layout.payload.nptrs;
+ break;
+ }
+
+ gen_obj:
+ case CONSTR:
+ case WEAK:
+ case STABLE_NAME:
+ {
+ StgPtr end;
+
+ end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
+ for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
+ evacuate((StgClosure **)p);
+ }
+ p += info->layout.payload.nptrs;
+ break;
+ }
+
+ case BCO: {
+ StgBCO *bco = (StgBCO *)p;
+ evacuate((StgClosure **)&bco->instrs);
+ evacuate((StgClosure **)&bco->literals);
+ evacuate((StgClosure **)&bco->ptrs);
+ p += bco_sizeW(bco);
+ break;
+ }
+
+ case IND_PERM:
+ if (bd->gen_no != 0) {
+#ifdef PROFILING
+ // @LDV profiling
+ // No need to call LDV_recordDead_FILL_SLOP_DYNAMIC() because an
+ // IND_OLDGEN_PERM closure is larger than an IND_PERM closure.
+ LDV_recordDead((StgClosure *)p, sizeofW(StgInd));
+#endif
+ //
+ // Todo: maybe use SET_HDR() and remove LDV_RECORD_CREATE()?
+ //
+ SET_INFO(((StgClosure *)p), &stg_IND_OLDGEN_PERM_info);
+
+ // We pretend that p has just been created.
+ LDV_RECORD_CREATE((StgClosure *)p);
+ }
+ // fall through
+ case IND_OLDGEN_PERM:
+ evacuate(&((StgInd *)p)->indirectee);
+ p += sizeofW(StgInd);
+ break;
+
+ case MUT_VAR_CLEAN:
+ case MUT_VAR_DIRTY:
+ gct->eager_promotion = rtsFalse;
+ evacuate(&((StgMutVar *)p)->var);
+ gct->eager_promotion = saved_eager_promotion;
+
+ if (gct->failed_to_evac) {
+ ((StgClosure *)q)->header.info = &stg_MUT_VAR_DIRTY_info;
+ } else {
+ ((StgClosure *)q)->header.info = &stg_MUT_VAR_CLEAN_info;
+ }
+ p += sizeofW(StgMutVar);
+ break;
+
+ case CAF_BLACKHOLE:
+ case SE_CAF_BLACKHOLE:
+ case SE_BLACKHOLE:
+ case BLACKHOLE:
+ p += BLACKHOLE_sizeW();
+ break;
+
+ case THUNK_SELECTOR:
+ {
+ StgSelector *s = (StgSelector *)p;
+ evacuate(&s->selectee);
+ p += THUNK_SELECTOR_sizeW();
+ break;
+ }
+
+ // A chunk of stack saved in a heap object
+ case AP_STACK:
+ {
+ StgAP_STACK *ap = (StgAP_STACK *)p;
+
+ evacuate(&ap->fun);
+ scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
+ p = (StgPtr)ap->payload + ap->size;
+ break;
+ }
+
+ case PAP:
+ p = scavenge_PAP((StgPAP *)p);
+ break;
+
+ case AP:
+ p = scavenge_AP((StgAP *)p);
+ break;
+
+ case ARR_WORDS:
+ // nothing to follow
+ p += arr_words_sizeW((StgArrWords *)p);
+ break;
+
+ case MUT_ARR_PTRS_CLEAN:
+ case MUT_ARR_PTRS_DIRTY:
+ // follow everything
+ {
+ StgPtr next;
+
+ // We don't eagerly promote objects pointed to by a mutable
+ // array, but if we find the array only points to objects in
+ // the same or an older generation, we mark it "clean" and
+ // avoid traversing it during minor GCs.
+ gct->eager_promotion = rtsFalse;
+ next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
+ for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
+ evacuate((StgClosure **)p);
+ }
+ gct->eager_promotion = saved_eager_promotion;
+
+ if (gct->failed_to_evac) {
+ ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_DIRTY_info;
+ } else {
+ ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_CLEAN_info;
+ }
+
+ gct->failed_to_evac = rtsTrue; // always put it on the mutable list.
+ break;
+ }
+
+ case MUT_ARR_PTRS_FROZEN:
+ case MUT_ARR_PTRS_FROZEN0:
+ // follow everything
+ {
+ StgPtr next;
+
+ next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
+ for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
+ evacuate((StgClosure **)p);
+ }
+
+ // If we're going to put this object on the mutable list, then
+ // set its info ptr to MUT_ARR_PTRS_FROZEN0 to indicate that.
+ if (gct->failed_to_evac) {
+ ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN0_info;
+ } else {
+ ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN_info;
+ }
+ break;
+ }
+
+ case TSO:
+ {
+ StgTSO *tso = (StgTSO *)p;
+ scavengeTSO(tso);
+ p += tso_sizeW(tso);
+ break;
+ }
+
+ case TVAR_WATCH_QUEUE:
+ {
+ StgTVarWatchQueue *wq = ((StgTVarWatchQueue *) p);
+ gct->evac_step = 0;
+ evacuate((StgClosure **)&wq->closure);
+ evacuate((StgClosure **)&wq->next_queue_entry);
+ evacuate((StgClosure **)&wq->prev_queue_entry);
+ gct->evac_step = saved_evac_step;
+ gct->failed_to_evac = rtsTrue; // mutable
+ p += sizeofW(StgTVarWatchQueue);
+ break;
+ }
+
+ case TVAR:
+ {
+ StgTVar *tvar = ((StgTVar *) p);
+ gct->evac_step = 0;
+ evacuate((StgClosure **)&tvar->current_value);
+ evacuate((StgClosure **)&tvar->first_watch_queue_entry);
+ gct->evac_step = saved_evac_step;
+ gct->failed_to_evac = rtsTrue; // mutable
+ p += sizeofW(StgTVar);
+ break;
+ }
+
+ case TREC_HEADER:
+ {
+ StgTRecHeader *trec = ((StgTRecHeader *) p);
+ gct->evac_step = 0;
+ evacuate((StgClosure **)&trec->enclosing_trec);
+ evacuate((StgClosure **)&trec->current_chunk);
+ evacuate((StgClosure **)&trec->invariants_to_check);
+ gct->evac_step = saved_evac_step;
+ gct->failed_to_evac = rtsTrue; // mutable
+ p += sizeofW(StgTRecHeader);
+ break;
+ }
+
+ case TREC_CHUNK:
+ {
+ StgWord i;
+ StgTRecChunk *tc = ((StgTRecChunk *) p);
+ TRecEntry *e = &(tc -> entries[0]);
+ gct->evac_step = 0;
+ evacuate((StgClosure **)&tc->prev_chunk);
+ for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
+ evacuate((StgClosure **)&e->tvar);
+ evacuate((StgClosure **)&e->expected_value);
+ evacuate((StgClosure **)&e->new_value);
+ }
+ gct->evac_step = saved_evac_step;
+ gct->failed_to_evac = rtsTrue; // mutable
+ p += sizeofW(StgTRecChunk);
+ break;
+ }
+
+ case ATOMIC_INVARIANT:
+ {
+ StgAtomicInvariant *invariant = ((StgAtomicInvariant *) p);
+ gct->evac_step = 0;
+ evacuate(&invariant->code);
+ evacuate((StgClosure **)&invariant->last_execution);
+ gct->evac_step = saved_evac_step;
+ gct->failed_to_evac = rtsTrue; // mutable
+ p += sizeofW(StgAtomicInvariant);
+ break;
+ }
+
+ case INVARIANT_CHECK_QUEUE:
+ {
+ StgInvariantCheckQueue *queue = ((StgInvariantCheckQueue *) p);
+ gct->evac_step = 0;
+ evacuate((StgClosure **)&queue->invariant);
+ evacuate((StgClosure **)&queue->my_execution);
+ evacuate((StgClosure **)&queue->next_queue_entry);
+ gct->evac_step = saved_evac_step;
+ gct->failed_to_evac = rtsTrue; // mutable
+ p += sizeofW(StgInvariantCheckQueue);
+ break;
+ }
+
+ default:
+ barf("scavenge: unimplemented/strange closure type %d @ %p",
+ info->type, p);
+ }
+
+ /*
+ * We need to record the current object on the mutable list if
+ * (a) It is actually mutable, or
+ * (b) It contains pointers to a younger generation.
+ * Case (b) arises if we didn't manage to promote everything that
+ * the current object points to into the current generation.
+ */
+ if (gct->failed_to_evac) {
+ gct->failed_to_evac = rtsFalse;
+ if (bd->gen_no > 0) {
+ recordMutableGen_GC((StgClosure *)q, &generations[bd->gen_no]);
+ }
+ }
+ }
+
+ if (p > bd->free) {
+ gct->copied += ws->todo_free - bd->free;
+ bd->free = p;
+ }
+
+ debugTrace(DEBUG_gc, " scavenged %ld bytes",
+ (unsigned long)((bd->free - bd->u.scan) * sizeof(W_)));
+
+ // update stats: this is a block that has been scavenged
+ gct->scanned += bd->free - bd->u.scan;
+ bd->u.scan = bd->free;
+
+ if (bd != ws->todo_bd) {
+ // we're not going to evac any more objects into
+ // this block, so push it now.
+ push_scanned_block(bd, ws);
+ }
+
+ gct->scan_bd = NULL;
+}
+/* -----------------------------------------------------------------------------
Scavenge everything on the mark stack.
This is slightly different from scavenge():
}
/* ----------------------------------------------------------------------------
- Scavenge a block
- ------------------------------------------------------------------------- */
-
-#undef PARALLEL_GC
-#include "Scav.c-inc"
-
-#ifdef THREADED_RTS
-#define PARALLEL_GC
-#include "Scav.c-inc"
-#endif
-
-/* ----------------------------------------------------------------------------
Look for work to do.
We look for the oldest step that has either a todo block that can
// scavenge everything up to the free pointer.
if (ws->todo_bd->u.scan < ws->todo_free)
{
- if (n_gc_threads == 1) {
- scavenge_block1(ws->todo_bd);
- } else {
- scavenge_block(ws->todo_bd);
- }
+ scavenge_block(ws->todo_bd);
did_something = rtsTrue;
break;
}
}
if ((bd = grab_todo_block(ws)) != NULL) {
- if (n_gc_threads == 1) {
- scavenge_block1(bd);
- } else {
- scavenge_block(bd);
- }
+ scavenge_block(bd);
did_something = rtsTrue;
break;
}
if (work_to_do) goto loop;
}
-rtsBool
-any_work (void)
-{
- int s;
- step_workspace *ws;
-
- gct->any_work++;
-
- write_barrier();
-
- // scavenge objects in compacted generation
- if (mark_stack_overflowed || oldgen_scan_bd != NULL ||
- (mark_stack_bdescr != NULL && !mark_stack_empty())) {
- return rtsTrue;
- }
-
- // Check for global work in any step. We don't need to check for
- // local work, because we have already exited scavenge_loop(),
- // which means there is no local work for this thread.
- for (s = total_steps-1; s >= 0; s--) {
- if (s == 0 && RtsFlags.GcFlags.generations > 1) {
- continue;
- }
- ws = &gct->steps[s];
- if (ws->todo_large_objects) return rtsTrue;
- if (ws->step->todos) return rtsTrue;
- }
-
- gct->no_work++;
-
- return rtsFalse;
-}
+++ /dev/null
-/* -----------------------------------------------------------------------*-c-*-
- *
- * (c) The GHC Team 1998-2008
- *
- * Generational garbage collector: scavenging functions
- *
- * Documentation on the architecture of the Garbage Collector can be
- * found in the online commentary:
- *
- * http://hackage.haskell.org/trac/ghc/wiki/Commentary/Rts/Storage/GC
- *
- * ---------------------------------------------------------------------------*/
-
-// This file is #included into Scav.c, twice: firstly with PARALLEL_GC
-// defined, the second time without.
-
-#if defined(THREADED_RTS) && !defined(PARALLEL_GC)
-# define scavenge_block(a) scavenge_block1(a)
-# define evacuate(a) evacuate1(a)
-# define recordMutableGen_GC(a,b) recordMutableGen(a,b)
-#else
-# undef scavenge_block
-# undef evacuate
-# undef recordMutableGen_GC
-# if !defined(THREADED_RTS)
-# define scavenge_block1(a) scavenge_block(a)
-# endif
-#endif
-
-
-static void scavenge_block (bdescr *bd);
-
-/* -----------------------------------------------------------------------------
- Scavenge a block from the given scan pointer up to bd->free.
-
- evac_step is set by the caller to be either zero (for a step in a
- generation < N) or G where G is the generation of the step being
- scavenged.
-
- We sometimes temporarily change evac_step back to zero if we're
- scavenging a mutable object where eager promotion isn't such a good
- idea.
- -------------------------------------------------------------------------- */
-
-static void
-scavenge_block (bdescr *bd)
-{
- StgPtr p, q;
- StgInfoTable *info;
- step *saved_evac_step;
- rtsBool saved_eager_promotion;
- step_workspace *ws;
-
- debugTrace(DEBUG_gc, "scavenging block %p (gen %d, step %d) @ %p",
- bd->start, bd->gen_no, bd->step->no, bd->u.scan);
-
- gct->scan_bd = bd;
- gct->evac_step = bd->step;
- saved_evac_step = gct->evac_step;
- saved_eager_promotion = gct->eager_promotion;
- gct->failed_to_evac = rtsFalse;
-
- ws = &gct->steps[bd->step->abs_no];
-
- p = bd->u.scan;
-
- // we might be evacuating into the very object that we're
- // scavenging, so we have to check the real bd->free pointer each
- // time around the loop.
- while (p < bd->free || (bd == ws->todo_bd && p < ws->todo_free)) {
-
- ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
- info = get_itbl((StgClosure *)p);
-
- ASSERT(gct->thunk_selector_depth == 0);
-
- q = p;
- switch (info->type) {
-
- case MVAR_CLEAN:
- case MVAR_DIRTY:
- {
- StgMVar *mvar = ((StgMVar *)p);
- gct->eager_promotion = rtsFalse;
- evacuate((StgClosure **)&mvar->head);
- evacuate((StgClosure **)&mvar->tail);
- evacuate((StgClosure **)&mvar->value);
- gct->eager_promotion = saved_eager_promotion;
-
- if (gct->failed_to_evac) {
- mvar->header.info = &stg_MVAR_DIRTY_info;
- } else {
- mvar->header.info = &stg_MVAR_CLEAN_info;
- }
- p += sizeofW(StgMVar);
- break;
- }
-
- case FUN_2_0:
- scavenge_fun_srt(info);
- evacuate(&((StgClosure *)p)->payload[1]);
- evacuate(&((StgClosure *)p)->payload[0]);
- p += sizeofW(StgHeader) + 2;
- break;
-
- case THUNK_2_0:
- scavenge_thunk_srt(info);
- evacuate(&((StgThunk *)p)->payload[1]);
- evacuate(&((StgThunk *)p)->payload[0]);
- p += sizeofW(StgThunk) + 2;
- break;
-
- case CONSTR_2_0:
- evacuate(&((StgClosure *)p)->payload[1]);
- evacuate(&((StgClosure *)p)->payload[0]);
- p += sizeofW(StgHeader) + 2;
- break;
-
- case THUNK_1_0:
- scavenge_thunk_srt(info);
- evacuate(&((StgThunk *)p)->payload[0]);
- p += sizeofW(StgThunk) + 1;
- break;
-
- case FUN_1_0:
- scavenge_fun_srt(info);
- case CONSTR_1_0:
- evacuate(&((StgClosure *)p)->payload[0]);
- p += sizeofW(StgHeader) + 1;
- break;
-
- case THUNK_0_1:
- scavenge_thunk_srt(info);
- p += sizeofW(StgThunk) + 1;
- break;
-
- case FUN_0_1:
- scavenge_fun_srt(info);
- case CONSTR_0_1:
- p += sizeofW(StgHeader) + 1;
- break;
-
- case THUNK_0_2:
- scavenge_thunk_srt(info);
- p += sizeofW(StgThunk) + 2;
- break;
-
- case FUN_0_2:
- scavenge_fun_srt(info);
- case CONSTR_0_2:
- p += sizeofW(StgHeader) + 2;
- break;
-
- case THUNK_1_1:
- scavenge_thunk_srt(info);
- evacuate(&((StgThunk *)p)->payload[0]);
- p += sizeofW(StgThunk) + 2;
- break;
-
- case FUN_1_1:
- scavenge_fun_srt(info);
- case CONSTR_1_1:
- evacuate(&((StgClosure *)p)->payload[0]);
- p += sizeofW(StgHeader) + 2;
- break;
-
- case FUN:
- scavenge_fun_srt(info);
- goto gen_obj;
-
- case THUNK:
- {
- StgPtr end;
-
- scavenge_thunk_srt(info);
- end = (P_)((StgThunk *)p)->payload + info->layout.payload.ptrs;
- for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
- evacuate((StgClosure **)p);
- }
- p += info->layout.payload.nptrs;
- break;
- }
-
- gen_obj:
- case CONSTR:
- case WEAK:
- case STABLE_NAME:
- {
- StgPtr end;
-
- end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
- for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
- evacuate((StgClosure **)p);
- }
- p += info->layout.payload.nptrs;
- break;
- }
-
- case BCO: {
- StgBCO *bco = (StgBCO *)p;
- evacuate((StgClosure **)&bco->instrs);
- evacuate((StgClosure **)&bco->literals);
- evacuate((StgClosure **)&bco->ptrs);
- p += bco_sizeW(bco);
- break;
- }
-
- case IND_PERM:
- if (bd->gen_no != 0) {
-#ifdef PROFILING
- // @LDV profiling
- // No need to call LDV_recordDead_FILL_SLOP_DYNAMIC() because an
- // IND_OLDGEN_PERM closure is larger than an IND_PERM closure.
- LDV_recordDead((StgClosure *)p, sizeofW(StgInd));
-#endif
- //
- // Todo: maybe use SET_HDR() and remove LDV_RECORD_CREATE()?
- //
- SET_INFO(((StgClosure *)p), &stg_IND_OLDGEN_PERM_info);
-
- // We pretend that p has just been created.
- LDV_RECORD_CREATE((StgClosure *)p);
- }
- // fall through
- case IND_OLDGEN_PERM:
- evacuate(&((StgInd *)p)->indirectee);
- p += sizeofW(StgInd);
- break;
-
- case MUT_VAR_CLEAN:
- case MUT_VAR_DIRTY:
- gct->eager_promotion = rtsFalse;
- evacuate(&((StgMutVar *)p)->var);
- gct->eager_promotion = saved_eager_promotion;
-
- if (gct->failed_to_evac) {
- ((StgClosure *)q)->header.info = &stg_MUT_VAR_DIRTY_info;
- } else {
- ((StgClosure *)q)->header.info = &stg_MUT_VAR_CLEAN_info;
- }
- p += sizeofW(StgMutVar);
- break;
-
- case CAF_BLACKHOLE:
- case SE_CAF_BLACKHOLE:
- case SE_BLACKHOLE:
- case BLACKHOLE:
- p += BLACKHOLE_sizeW();
- break;
-
- case THUNK_SELECTOR:
- {
- StgSelector *s = (StgSelector *)p;
- evacuate(&s->selectee);
- p += THUNK_SELECTOR_sizeW();
- break;
- }
-
- // A chunk of stack saved in a heap object
- case AP_STACK:
- {
- StgAP_STACK *ap = (StgAP_STACK *)p;
-
- evacuate(&ap->fun);
- scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
- p = (StgPtr)ap->payload + ap->size;
- break;
- }
-
- case PAP:
- p = scavenge_PAP((StgPAP *)p);
- break;
-
- case AP:
- p = scavenge_AP((StgAP *)p);
- break;
-
- case ARR_WORDS:
- // nothing to follow
- p += arr_words_sizeW((StgArrWords *)p);
- break;
-
- case MUT_ARR_PTRS_CLEAN:
- case MUT_ARR_PTRS_DIRTY:
- // follow everything
- {
- StgPtr next;
-
- // We don't eagerly promote objects pointed to by a mutable
- // array, but if we find the array only points to objects in
- // the same or an older generation, we mark it "clean" and
- // avoid traversing it during minor GCs.
- gct->eager_promotion = rtsFalse;
- next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
- for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
- evacuate((StgClosure **)p);
- }
- gct->eager_promotion = saved_eager_promotion;
-
- if (gct->failed_to_evac) {
- ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_DIRTY_info;
- } else {
- ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_CLEAN_info;
- }
-
- gct->failed_to_evac = rtsTrue; // always put it on the mutable list.
- break;
- }
-
- case MUT_ARR_PTRS_FROZEN:
- case MUT_ARR_PTRS_FROZEN0:
- // follow everything
- {
- StgPtr next;
-
- next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
- for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
- evacuate((StgClosure **)p);
- }
-
- // If we're going to put this object on the mutable list, then
- // set its info ptr to MUT_ARR_PTRS_FROZEN0 to indicate that.
- if (gct->failed_to_evac) {
- ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN0_info;
- } else {
- ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN_info;
- }
- break;
- }
-
- case TSO:
- {
- StgTSO *tso = (StgTSO *)p;
- scavengeTSO(tso);
- p += tso_sizeW(tso);
- break;
- }
-
- case TVAR_WATCH_QUEUE:
- {
- StgTVarWatchQueue *wq = ((StgTVarWatchQueue *) p);
- gct->evac_step = 0;
- evacuate((StgClosure **)&wq->closure);
- evacuate((StgClosure **)&wq->next_queue_entry);
- evacuate((StgClosure **)&wq->prev_queue_entry);
- gct->evac_step = saved_evac_step;
- gct->failed_to_evac = rtsTrue; // mutable
- p += sizeofW(StgTVarWatchQueue);
- break;
- }
-
- case TVAR:
- {
- StgTVar *tvar = ((StgTVar *) p);
- gct->evac_step = 0;
- evacuate((StgClosure **)&tvar->current_value);
- evacuate((StgClosure **)&tvar->first_watch_queue_entry);
- gct->evac_step = saved_evac_step;
- gct->failed_to_evac = rtsTrue; // mutable
- p += sizeofW(StgTVar);
- break;
- }
-
- case TREC_HEADER:
- {
- StgTRecHeader *trec = ((StgTRecHeader *) p);
- gct->evac_step = 0;
- evacuate((StgClosure **)&trec->enclosing_trec);
- evacuate((StgClosure **)&trec->current_chunk);
- evacuate((StgClosure **)&trec->invariants_to_check);
- gct->evac_step = saved_evac_step;
- gct->failed_to_evac = rtsTrue; // mutable
- p += sizeofW(StgTRecHeader);
- break;
- }
-
- case TREC_CHUNK:
- {
- StgWord i;
- StgTRecChunk *tc = ((StgTRecChunk *) p);
- TRecEntry *e = &(tc -> entries[0]);
- gct->evac_step = 0;
- evacuate((StgClosure **)&tc->prev_chunk);
- for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
- evacuate((StgClosure **)&e->tvar);
- evacuate((StgClosure **)&e->expected_value);
- evacuate((StgClosure **)&e->new_value);
- }
- gct->evac_step = saved_evac_step;
- gct->failed_to_evac = rtsTrue; // mutable
- p += sizeofW(StgTRecChunk);
- break;
- }
-
- case ATOMIC_INVARIANT:
- {
- StgAtomicInvariant *invariant = ((StgAtomicInvariant *) p);
- gct->evac_step = 0;
- evacuate(&invariant->code);
- evacuate((StgClosure **)&invariant->last_execution);
- gct->evac_step = saved_evac_step;
- gct->failed_to_evac = rtsTrue; // mutable
- p += sizeofW(StgAtomicInvariant);
- break;
- }
-
- case INVARIANT_CHECK_QUEUE:
- {
- StgInvariantCheckQueue *queue = ((StgInvariantCheckQueue *) p);
- gct->evac_step = 0;
- evacuate((StgClosure **)&queue->invariant);
- evacuate((StgClosure **)&queue->my_execution);
- evacuate((StgClosure **)&queue->next_queue_entry);
- gct->evac_step = saved_evac_step;
- gct->failed_to_evac = rtsTrue; // mutable
- p += sizeofW(StgInvariantCheckQueue);
- break;
- }
-
- default:
- barf("scavenge: unimplemented/strange closure type %d @ %p",
- info->type, p);
- }
-
- /*
- * We need to record the current object on the mutable list if
- * (a) It is actually mutable, or
- * (b) It contains pointers to a younger generation.
- * Case (b) arises if we didn't manage to promote everything that
- * the current object points to into the current generation.
- */
- if (gct->failed_to_evac) {
- gct->failed_to_evac = rtsFalse;
- if (bd->gen_no > 0) {
- recordMutableGen_GC((StgClosure *)q, &generations[bd->gen_no]);
- }
- }
- }
-
- if (p > bd->free) {
- gct->copied += ws->todo_free - bd->free;
- bd->free = p;
- }
-
- debugTrace(DEBUG_gc, " scavenged %ld bytes",
- (unsigned long)((bd->free - bd->u.scan) * sizeof(W_)));
-
- // update stats: this is a block that has been scavenged
- gct->scanned += bd->free - bd->u.scan;
- bd->u.scan = bd->free;
-
- if (bd != ws->todo_bd) {
- // we're not going to evac any more objects into
- // this block, so push it now.
- push_scanned_block(bd, ws);
- }
-
- gct->scan_bd = NULL;
-}
-
-#undef scavenge_block
-#undef evacuate
-#undef recordMutableGen_GC
* ---------------------------------------------------------------------------*/
void scavenge_loop (void);
-rtsBool any_work (void);
void scavenge_mutable_list (generation *g);
+
+#ifdef THREADED_RTS
+void scavenge_loop1 (void);
+void scavenge_mutable_list1 (generation *g);
+#endif
resizeNurseriesFixed(blocks / n_nurseries);
}
+
+/* -----------------------------------------------------------------------------
+ move_TSO is called to update the TSO structure after it has been
+ moved from one place to another.
+ -------------------------------------------------------------------------- */
+
+void
+move_TSO (StgTSO *src, StgTSO *dest)
+{
+ ptrdiff_t diff;
+
+ // relocate the stack pointer...
+ diff = (StgPtr)dest - (StgPtr)src; // In *words*
+ dest->sp = (StgPtr)dest->sp + diff;
+}
+
/* -----------------------------------------------------------------------------
The allocate() interface
projects / ghc-hetmet.git / commitdiff