*
* Generational garbage collector: evacuation 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
+ *
* ---------------------------------------------------------------------------*/
#include "Rts.h"
STATIC_INLINE StgClosure *
-copy(StgClosure *src, nat size, step *stp)
+copy_tag(StgClosure *src, nat size, step *stp,StgWord tag)
{
StgPtr to, from;
nat i;
for (i = 0; i < size; i++) { // unroll for small i
to[i] = from[i];
}
+
+ /* retag pointer before updating EVACUATE closure and returning */
+ to = (StgPtr)TAG_CLOSURE(tag,(StgClosure*)to);
+
upd_evacuee((StgClosure *)from,(StgClosure *)to);
#ifdef PROFILING
// that will not be scavenged. Used for object that have no pointer
// fields.
STATIC_INLINE StgClosure *
-copy_noscav(StgClosure *src, nat size, step *stp)
+copy_noscav_tag(StgClosure *src, nat size, step *stp, StgWord tag)
{
StgPtr to, from;
nat i;
for (i = 0; i < size; i++) { // unroll for small i
to[i] = from[i];
}
+
+ /* retag pointer before updating EVACUATE closure and returning */
+ to = (StgPtr)TAG_CLOSURE(tag,(StgClosure*)to);
+
upd_evacuee((StgClosure *)from,(StgClosure *)to);
#ifdef PROFILING
}
+/* Copy wrappers that don't tag the closure after copying */
+STATIC_INLINE StgClosure *
+copy(StgClosure *src, nat size, step *stp)
+{
+ return copy_tag(src,size,stp,0);
+}
+
+STATIC_INLINE StgClosure *
+copy_noscav(StgClosure *src, nat size, step *stp)
+{
+ return copy_noscav_tag(src,size,stp,0);
+}
+
/* -----------------------------------------------------------------------------
Evacuate a large object
REGPARM1 StgClosure *
evacuate(StgClosure *q)
{
-#if defined(PAR)
- StgClosure *to;
-#endif
bdescr *bd = NULL;
step *stp;
const StgInfoTable *info;
+ StgWord tag;
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 q;
+ if (!major_gc) return TAG_CLOSURE(tag,q);
info = get_itbl(q);
switch (info->type) {
if (*STATIC_LINK(info,(StgClosure *)q) == NULL) {
*STATIC_LINK(info,(StgClosure *)q) = static_objects;
static_objects = (StgClosure *)q;
+ /* I am assuming that static_objects pointers are not
+ * written to other objects, and thus, no need to retag. */
}
- return q;
+ return TAG_CLOSURE(tag,q);
case CONSTR_NOCAF_STATIC:
/* no need to put these on the static linked list, they don't need
* to be scavenged.
*/
- return q;
+ return TAG_CLOSURE(tag,q);
default:
barf("evacuate(static): strange closure type %d", (int)(info->type));
failed_to_evac = rtsTrue;
TICK_GC_FAILED_PROMOTION();
}
- return q;
+ return TAG_CLOSURE(tag,q);
}
if ((bd->flags & (BF_LARGE | BF_COMPACTED | BF_EVACUATED)) != 0) {
failed_to_evac = rtsTrue;
TICK_GC_FAILED_PROMOTION();
}
- return q;
+ return TAG_CLOSURE(tag,q);
}
/* evacuate large objects by re-linking them onto a different list.
goto loop;
}
evacuate_large((P_)q);
- return q;
+ return TAG_CLOSURE(tag,q);
}
/* If the object is in a step that we're compacting, then we
}
push_mark_stack((P_)q);
}
- return q;
+ return TAG_CLOSURE(tag,q);
}
}
if (q->header.info == Czh_con_info &&
// unsigned, so always true: (StgChar)w >= MIN_CHARLIKE &&
(StgChar)w <= MAX_CHARLIKE) {
- return (StgClosure *)CHARLIKE_CLOSURE((StgChar)w);
+ return TAG_CLOSURE(tag,
+ (StgClosure *)CHARLIKE_CLOSURE((StgChar)w)
+ );
}
if (q->header.info == Izh_con_info &&
(StgInt)w >= MIN_INTLIKE && (StgInt)w <= MAX_INTLIKE) {
- return (StgClosure *)INTLIKE_CLOSURE((StgInt)w);
+ return TAG_CLOSURE(tag,
+ (StgClosure *)INTLIKE_CLOSURE((StgInt)w)
+ );
}
// else
- return copy_noscav(q,sizeofW(StgHeader)+1,stp);
+ return copy_noscav_tag(q,sizeofW(StgHeader)+1,stp,tag);
}
case FUN_0_1:
case FUN_1_0:
case CONSTR_1_0:
- return copy(q,sizeofW(StgHeader)+1,stp);
+ return copy_tag(q,sizeofW(StgHeader)+1,stp,tag);
case THUNK_1_0:
case THUNK_0_1:
case FUN_1_1:
case FUN_2_0:
+ case FUN_0_2:
case CONSTR_1_1:
case CONSTR_2_0:
- case FUN_0_2:
- return copy(q,sizeofW(StgHeader)+2,stp);
+ return copy_tag(q,sizeofW(StgHeader)+2,stp,tag);
case CONSTR_0_2:
- return copy_noscav(q,sizeofW(StgHeader)+2,stp);
+ return copy_noscav_tag(q,sizeofW(StgHeader)+2,stp,tag);
case THUNK:
return copy(q,thunk_sizeW_fromITBL(info),stp);
case FUN:
- case CONSTR:
case IND_PERM:
case IND_OLDGEN_PERM:
case WEAK:
case STABLE_NAME:
- return copy(q,sizeW_fromITBL(info),stp);
+ case CONSTR:
+ return copy_tag(q,sizeW_fromITBL(info),stp,tag);
case BCO:
- return copy(q,bco_sizeW((StgBCO *)q),stp);
+ return copy(q,bco_sizeW((StgBCO *)q),stp);
case CAF_BLACKHOLE:
case SE_CAF_BLACKHOLE:
case RET_BCO:
case RET_SMALL:
- case RET_VEC_SMALL:
case RET_BIG:
- case RET_VEC_BIG:
case RET_DYN:
case UPDATE_FRAME:
case STOP_FRAME:
}
}
-#if defined(PAR)
- case RBH:
- {
- //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);
- debugTrace(DEBUG_gc, "evacuate: RBH %p (%s) to %p (%s)",
- q, info_type(q), to, info_type(to));
- return to;
- }
-
- case BLOCKED_FETCH:
- ASSERT(sizeofW(StgBlockedFetch) >= MIN_PAYLOD_SIZE);
- to = copy(q,sizeofW(StgBlockedFetch),stp);
- debugTrace(DEBUG_gc, "evacuate: %p (%s) to %p (%s)",
- q, info_type(q), to, info_type(to));
- return to;
-
-# ifdef DIST
- case REMOTE_REF:
-# endif
- case FETCH_ME:
- ASSERT(sizeofW(StgBlockedFetch) >= MIN_PAYLOAD_SIZE);
- to = copy(q,sizeofW(StgFetchMe),stp);
- debugTrace(DEBUG_gc, "evacuate: %p (%s) to %p (%s)",
- q, info_type(q), to, info_type(to)));
- return to;
-
- case FETCH_ME_BQ:
- ASSERT(sizeofW(StgBlockedFetch) >= MIN_PAYLOAD_SIZE);
- to = copy(q,sizeofW(StgFetchMeBlockingQueue),stp);
- debugTrace(DEBUG_gc, "evacuate: %p (%s) to %p (%s)",
- q, info_type(q), to, info_type(to)));
- return to;
-#endif
-
case TREC_HEADER:
return copy(q,sizeofW(StgTRecHeader),stp);
const StgInfoTable *info_ptr;
StgClosure *selectee;
- selectee = p->selectee;
+ // The selectee might be a constructor closure,
+ // so we untag the pointer.
+ selectee = UNTAG_CLOSURE(p->selectee);
// Save the real info pointer (NOTE: not the same as get_itbl()).
info_ptr = p->header.info;
{
StgClosure *q;
q = selectee->payload[field];
- if (is_to_space(q)) {
+ if (is_to_space(UNTAG_CLOSURE(q))) {
goto bale_out;
} else {
return q;
case IND_OLDGEN:
case IND_OLDGEN_PERM:
case IND_STATIC:
- selectee = ((StgInd *)selectee)->indirectee;
+ // Again, we might need to untag a constructor.
+ selectee = UNTAG_CLOSURE( ((StgInd *)selectee)->indirectee );
goto selector_loop;
case EVACUATED:
if (thunk_selector_depth >= MAX_THUNK_SELECTOR_DEPTH) {
break;
}
+
+ // we don't update THUNK_SELECTORS in the compacted
+ // generation, because compaction does not remove the INDs
+ // that result, this causes confusion later.
+ if (Bdescr((P_)selectee)->flags && BF_COMPACTED) {
+ break;
+ }
+
thunk_selector_depth++;
val = eval_thunk_selector(info->layout.selector_offset,
// indirection.
LDV_RECORD_CREATE(selectee);
- selectee = val;
+ // Of course this pointer might be tagged
+ selectee = UNTAG_CLOSURE(val);
goto selector_loop;
}
}
case SE_CAF_BLACKHOLE:
case SE_BLACKHOLE:
case BLACKHOLE:
-#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;
projects / ghc-hetmet.git / blobdiff