/* -----------------------------------------------------------------------------
- * $Id: GCCompact.c,v 1.1 2001/07/23 17:23:19 simonmar Exp $
+ * $Id: GCCompact.c,v 1.11 2001/12/11 12:03:23 simonmar Exp $
*
* (c) The GHC Team 2001
*
*
* ---------------------------------------------------------------------------*/
+#include "PosixSource.h"
#include "Rts.h"
#include "RtsUtils.h"
#include "RtsFlags.h"
#include "Schedule.h"
#include "StablePriv.h"
+/* -----------------------------------------------------------------------------
+ Threading / unthreading pointers.
+
+ The basic idea here is to chain together all the fields pointing at
+ a particular object, with the root of the chain in the object's
+ info table field. The original contents of the info pointer goes
+ at the end of the chain.
+
+ Adding a new field to the chain is a matter of swapping the
+ contents of the field with the contents of the object's info table
+ field.
+
+ To unthread the chain, we walk down it updating all the fields on
+ the chain with the new location of the object. We stop when we
+ reach the info pointer at the end.
+
+ We use a trick to identify the info pointer, because the
+ LOOKS_LIKE_GHC_INFO() macro involves a function call and can be
+ expensive. The trick is that when swapping pointers for threading,
+ we set the low bit of the original pointer, with the result that
+ all the pointers in the chain have their low bits set except for
+ the info pointer.
+ -------------------------------------------------------------------------- */
+
static inline void
thread( StgPtr p )
{
StgPtr q = (StgPtr)*p;
+ bdescr *bd;
+
ASSERT(!LOOKS_LIKE_GHC_INFO(q));
if (HEAP_ALLOCED(q)) {
- *p = (StgWord)*q;
- *q = (StgWord)p;
+ bd = Bdescr(q);
+ // a handy way to discover whether the ptr is into the
+ // compacted area of the old gen, is that the EVACUATED flag
+ // is zero (it's non-zero for all the other areas of live
+ // memory).
+ if ((bd->flags & BF_EVACUATED) == 0) {
+ *p = (StgWord)*q;
+ *q = (StgWord)p + 1; // set the low bit
+ }
}
}
unthread( StgPtr p, StgPtr free )
{
StgPtr q = (StgPtr)*p, r;
-
- while (!LOOKS_LIKE_GHC_INFO(q)) {
+
+ while (((StgWord)q & 1) != 0) {
+ (StgWord)q -= 1; // unset the low bit again
r = (StgPtr)*q;
*q = (StgWord)free;
q = r;
{
StgPtr q = (P_)GET_INFO((StgClosure *)p);
- while (!LOOKS_LIKE_GHC_INFO(q)) {
- q = (P_)*q;
+ while (((StgWord)q & 1) != 0) {
+ q = (P_)*((StgPtr)((StgWord)q-1));
}
return INFO_PTR_TO_STRUCT((StgInfoTable *)q);
}
case IND_STATIC:
thread((StgPtr)&((StgInd *)p)->indirectee);
- break;
+ p = IND_STATIC_LINK(p);
+ continue;
case THUNK_STATIC:
+ p = THUNK_STATIC_LINK(p);
+ continue;
case FUN_STATIC:
+ p = FUN_STATIC_LINK(p);
+ continue;
case CONSTR_STATIC:
- break;
+ p = STATIC_LINK(info,p);
+ continue;
default:
barf("thread_static: strange closure %d", (int)(info->type));
}
- p = STATIC_LINK(info,p);
}
}
{
StgPtr q;
const StgInfoTable* info;
- StgWord32 bitmap;
+ StgWord bitmap;
// highly similar to scavenge_stack, but we do pointer threading here.
p++;
continue;
- // small bitmap (< 32 entries, or 64 on a 64-bit machine)
+ // small bitmap (<= 32 entries, or 64 on a 64-bit machine)
case UPDATE_FRAME:
case STOP_FRAME:
case CATCH_FRAME:
}
continue;
- // large bitmap (> 32 entries)
+ // large bitmap (> 32 entries, or 64 on a 64-bit machine)
case RET_BIG:
case RET_VEC_BIG:
{
for (i=0; i<large_bitmap->size; i++) {
bitmap = large_bitmap->bitmap[i];
- q = p + sizeof(W_) * 8;
+ q = p + BITS_IN(W_);
while (bitmap != 0) {
if ((bitmap & 1) == 0) {
thread(p);
for (; bd != NULL; bd = bd->link) {
p = bd->start;
- unthread(p,p);
info = get_itbl((StgClosure *)p);
switch (info->type) {
{
StgTSO *tso = (StgTSO *)p;
thread_stack(tso->sp, &(tso->stack[tso->stack_size]));
+ thread((StgPtr)&tso->link);
+ thread((StgPtr)&tso->global_link);
continue;
}
// linearly scan the objects in this block
while (p < bd->free) {
- /* unthread the info ptr */
- unthread(p,p);
info = get_itbl((StgClosure *)p);
ASSERT(p && (LOOKS_LIKE_GHC_INFO(info)
break;
}
- // specialise this case, because we want to update the
- // mut_link field too.
case IND_OLDGEN:
case IND_OLDGEN_PERM:
- {
- StgIndOldGen *ind = (StgIndOldGen *)p;
- thread((StgPtr)&ind->indirectee);
- if (ind->mut_link != NULL) {
- thread((StgPtr)&ind->mut_link);
- }
+ thread((StgPtr)&((StgIndOldGen *)p)->indirectee);
+ p += sizeofW(StgIndOldGen);
break;
- }
case THUNK_SELECTOR:
{
update_fwd_compact( bdescr *blocks )
{
StgPtr p, q, free;
+#if 0
StgWord m;
+#endif
bdescr *bd, *free_bd;
StgInfoTable *info;
nat size;
case IND_OLDGEN:
case IND_OLDGEN_PERM:
- // specialise this case, because we want to update the
- // mut_link field too.
- {
- StgIndOldGen *ind = (StgIndOldGen *)p;
- thread((StgPtr)&ind->indirectee);
- if (ind->mut_link != NULL) {
- thread((StgPtr)&ind->mut_link);
- }
+ thread((StgPtr)&((StgIndOldGen *)p)->indirectee);
p += sizeofW(StgIndOldGen);
break;
- }
case THUNK_SELECTOR:
{
size = p - q;
if (free + size > free_bd->start + BLOCK_SIZE_W) {
+ // unset the next bit in the bitmap to indicate that
+ // this object needs to be pushed into the next
+ // block. This saves us having to run down the
+ // threaded info pointer list twice during the next pass.
+ unmark(q+1,bd);
free_bd = free_bd->link;
free = free_bd->start;
+ } else {
+ ASSERT(is_marked(q+1,bd));
}
unthread(q,free);
}
}
-static void
-update_bkwd( bdescr *blocks )
-{
- StgPtr p;
- bdescr *bd;
- StgInfoTable *info;
-
- bd = blocks;
-
-#if defined(PAR)
- barf("update_bkwd: ToDo");
-#endif
-
- // cycle through all the blocks in the step
- for (; bd != NULL; bd = bd->link) {
- p = bd->start;
-
- // linearly scan the objects in this block
- while (p < bd->free) {
-
- // must unthread before we look at the info ptr...
- unthread(p,p);
-
- info = get_itbl((StgClosure *)p);
- ASSERT(p && (LOOKS_LIKE_GHC_INFO(info)
- || IS_HUGS_CONSTR_INFO(info)));
-
- p += obj_sizeW((StgClosure *)p,info);
- }
- }
-}
-
static nat
update_bkwd_compact( step *stp )
{
StgPtr p, free;
+#if 0
StgWord m;
+#endif
bdescr *bd, *free_bd;
StgInfoTable *info;
nat size, free_blocks;
}
#endif
- // must unthread before we look at the info ptr...
- info = get_threaded_info(p);
-
- ASSERT(p && (LOOKS_LIKE_GHC_INFO(info)
- || IS_HUGS_CONSTR_INFO(info)));
-
- size = obj_sizeW((StgClosure *)p,info);
-
- if (free + size > free_bd->start + BLOCK_SIZE_W) {
+ if (!is_marked(p+1,bd)) {
// don't forget to update the free ptr in the block desc.
free_bd->free = free;
free_bd = free_bd->link;
}
unthread(p,free);
- move(free,p,size);
+ info = get_itbl((StgClosure *)p);
+ size = obj_sizeW((StgClosure *)p,info);
+
+ ASSERT(p && (LOOKS_LIKE_GHC_INFO(info)
+ || IS_HUGS_CONSTR_INFO(info)));
+
+ if (free != p) {
+ move(free,p,size);
+ }
// Rebuild the mutable list for the old generation.
- // (the mut_once list is updated using threading, with
- // special cases for IND_OLDGEN and MUT_CONS above).
if (ip_MUTABLE(info)) {
recordMutable((StgMutClosure *)free);
}
stp->n_blocks = free_blocks;
return free_blocks;
-}
+}
static void
-update_bkwd_large( bdescr *blocks )
+thread_mut_once_list( generation *g )
{
- bdescr *bd;
+ StgMutClosure *p, *next;
- for (bd = blocks; bd != NULL; bd = bd->link ) {
- unthread(bd->start, bd->start);
+ for (p = g->mut_once_list; p != END_MUT_LIST; p = next) {
+ next = p->mut_link;
+ thread((StgPtr)&p->mut_link);
}
+
+ thread((StgPtr)&g->mut_once_list);
}
-
void
compact( void (*get_roots)(evac_fn) )
{
thread((StgPtr)&old_weak_ptr_list); // tmp
}
- // mutable lists (ToDo: all gens)
- thread((StgPtr)&oldest_gen->mut_list);
- thread((StgPtr)&oldest_gen->mut_once_list);
+ // mutable lists
+ for (g = 1; g < RtsFlags.GcFlags.generations; g++) {
+ thread((StgPtr)&generations[g].mut_list);
+ thread_mut_once_list(&generations[g]);
+ }
// the global thread list
thread((StgPtr)&all_threads);
// the stable pointer table
threadStablePtrTable((evac_fn)thread);
+ // the CAF list (used by GHCi)
+ markCAFs((evac_fn)thread);
+
// 2. update forward ptrs
for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
for (s = 0; s < generations[g].n_steps; s++) {
}
// 3. update backward ptrs
- for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
- for (s = 0; s < generations[g].n_steps; s++) {
- stp = &generations[g].steps[s];
- IF_DEBUG(gc, fprintf(stderr,"update_bkwd: %d.%d\n", stp->gen->no, stp->no););
- update_bkwd(stp->to_blocks);
- update_bkwd_large(stp->scavenged_large_objects);
- if (g == RtsFlags.GcFlags.generations-1 && stp->blocks != NULL) {
- IF_DEBUG(gc, fprintf(stderr,"update_bkwd: %d.%d (compact)\n", stp->gen->no, stp->no););
- blocks = update_bkwd_compact(stp);
- IF_DEBUG(gc, fprintf(stderr,"update_bkwd: %d.%d (compact, old: %d blocks, now %d blocks)\n",
- stp->gen->no, stp->no,
- stp->n_blocks, blocks););
- stp->n_blocks = blocks;
- }
- }
+ stp = &oldest_gen->steps[0];
+ if (stp->blocks != NULL) {
+ blocks = update_bkwd_compact(stp);
+ IF_DEBUG(gc, fprintf(stderr,"update_bkwd: %d.%d (compact, old: %d blocks, now %d blocks)\n",
+ stp->gen->no, stp->no,
+ stp->n_blocks, blocks););
+ stp->n_blocks = blocks;
}
}
projects / ghc-hetmet.git / blobdiff