// Traverse a threaded chain and pull out the info pointer at the end.
// The info pointer is also tagged with the appropriate pointer tag
// for this closure, which should be attached to the pointer
// subsequently passed to unthread().
STATIC_INLINE StgWord
get_threaded_info( StgPtr p )
{
StgWord q;
q = (W_)GET_INFO(UNTAG_CLOSURE((StgClosure *)p));
loop:
switch (GET_CLOSURE_TAG((StgClosure *)q))
{
case 0:
ASSERT(LOOKS_LIKE_INFO_PTR(q));
return q;
case 1:
{
StgWord r = *(StgPtr)(q-1);
ASSERT(LOOKS_LIKE_INFO_PTR(UNTAG_CLOSURE((StgClosure *)r)));
return r;
}
case 2:
q = *(StgPtr)(q-2);
goto loop;
default:
barf("get_threaded_info");
}
}
void
checkHeapChunk(StgPtr start, StgPtr end)
{
StgPtr p;
nat size;
for (p=start; p<end; p+=size) {
ASSERT(LOOKS_LIKE_INFO_PTR(*p));
size = checkClosure((StgClosure *)p);
/* This is the smallest size of closure that can live in the heap. */
ASSERT( size >= MIN_PAYLOAD_SIZE + sizeofW(StgHeader) );
}
}
/*
Check the static objects list.
*/
void
checkStaticObjects ( StgClosure* static_objects )
{
StgClosure *p = static_objects;
const StgInfoTable *info;
while (p != END_OF_STATIC_OBJECT_LIST) {
p = UNTAG_STATIC_LIST_PTR(p);
checkClosure(p);
info = get_itbl(p);
switch (info->type) {
case IND_STATIC:
{
const StgClosure *indirectee;
indirectee = UNTAG_CONST_CLOSURE(((StgIndStatic *)p)->indirectee);
ASSERT(LOOKS_LIKE_CLOSURE_PTR(indirectee));
ASSERT(LOOKS_LIKE_INFO_PTR((StgWord)indirectee->header.info));
p = *IND_STATIC_LINK((StgClosure *)p);
break;
}
case THUNK_STATIC:
p = *THUNK_STATIC_LINK((StgClosure *)p);
break;
case FUN_STATIC:
p = *STATIC_LINK(info,(StgClosure *)p);
break;
case CONSTR:
case CONSTR_NOCAF:
case CONSTR_1_0:
case CONSTR_2_0:
case CONSTR_1_1:
p = *STATIC_LINK(info,(StgClosure *)p);
break;
default:
barf("checkStaticObjetcs: strange closure %p (%s)",
p, info_type(p));
}
}
}
/*
Check the static objects list.
*/
void
checkStaticObjects ( StgClosure* static_objects )
{
StgClosure *p = static_objects;
StgInfoTable *info;
while (p != END_OF_STATIC_LIST) {
checkClosure(p);
info = get_itbl(p);
switch (info->type) {
case IND_STATIC:
{
StgClosure *indirectee = UNTAG_CLOSURE(((StgIndStatic *)p)->indirectee);
ASSERT(LOOKS_LIKE_CLOSURE_PTR(indirectee));
ASSERT(LOOKS_LIKE_INFO_PTR((StgWord)indirectee->header.info));
p = *IND_STATIC_LINK((StgClosure *)p);
break;
}
case THUNK_STATIC:
p = *THUNK_STATIC_LINK((StgClosure *)p);
break;
case FUN_STATIC:
p = *FUN_STATIC_LINK((StgClosure *)p);
break;
case CONSTR_STATIC:
p = *STATIC_LINK(info,(StgClosure *)p);
break;
default:
barf("checkStaticObjetcs: strange closure %p (%s)", p,
#ifndef HaLVM_TARGET_OS
info_type(p)
#else
"[HaLVM has no info_type()]"
#endif
);
}
}
}
void checkHeapChain (bdescr *bd)
{
StgPtr p;
for (; bd != NULL; bd = bd->link) {
if(!(bd->flags & BF_SWEPT)) {
p = bd->start;
while (p < bd->free) {
nat size = checkClosure((StgClosure *)p);
/* This is the smallest size of closure that can live in the heap */
ASSERT( size >= MIN_PAYLOAD_SIZE + sizeofW(StgHeader) );
p += size;
/* skip over slop */
while (p < bd->free &&
(*p < 0x1000 || !LOOKS_LIKE_INFO_PTR(*p))) { p++; }
}
}
}
}
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;
StgWord iptr;
bd = free_bd = stp->old_blocks;
free = free_bd->start;
free_blocks = 1;
// cycle through all the blocks in the step
for (; bd != NULL; bd = bd->link) {
p = bd->start;
while (p < bd->free ) {
while ( p < bd->free && !is_marked(p,bd) ) {
p++;
}
if (p >= bd->free) {
break;
}
#if 0
next:
m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
while ( p < bd->free ) {
if ((m & 1) == 0) {
m >>= 1;
p++;
if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
goto next;
} else {
continue;
}
}
#endif
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;
free = free_bd->start;
free_blocks++;
}
iptr = get_threaded_info(p);
unthread(p, (StgWord)free + GET_CLOSURE_TAG((StgClosure *)iptr));
ASSERT(LOOKS_LIKE_INFO_PTR(((StgClosure *)p)->header.info));
info = get_itbl((StgClosure *)p);
size = closure_sizeW_((StgClosure *)p,info);
if (free != p) {
move(free,p,size);
}
// relocate TSOs
if (info->type == TSO) {
move_TSO((StgTSO *)p, (StgTSO *)free);
}
free += size;
p += size;
#if 0
goto next;
#endif
}
}
// free the remaining blocks and count what's left.
free_bd->free = free;
if (free_bd->link != NULL) {
freeChain(free_bd->link);
free_bd->link = NULL;
}
return free_blocks;
}
