// 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; }