#include "RtsFlags.h"
#include "MBlock.h"
-#include "Storage.h"
#include "Bytecodes.h" /* for InstrPtr */
#include "Disassembler.h"
#include "Apply.h"
#ifdef USING_LIBBFD
static void reset_table ( int size );
static void prepare_table ( void );
-static void insert ( unsigned value, const char *name );
+static void insert ( StgWord value, const char *name );
#endif
#if 0 /* unused but might be useful sometime */
-static rtsBool lookup_name ( char *name, unsigned *result );
+static rtsBool lookup_name ( char *name, StgWord *result );
static void enZcode ( char *in, char *out );
#endif
static char unZcode ( char ch );
case CONSTR:
case CONSTR_1_0: case CONSTR_0_1:
case CONSTR_1_1: case CONSTR_0_2: case CONSTR_2_0:
- case CONSTR_INTLIKE:
- case CONSTR_CHARLIKE:
case CONSTR_STATIC:
case CONSTR_NOCAF_STATIC:
{
StgWord i, j;
+
#ifdef PROFILING
- debugBelch("%s(", info->prof.closure_desc);
+ debugBelch("%s(", GET_PROF_DESC(info));
debugBelch("%s", obj->header.prof.ccs->cc->label);
#else
debugBelch("CONSTR(");
case THUNK_STATIC:
/* ToDo: will this work for THUNK_STATIC too? */
#ifdef PROFILING
- printThunkObject((StgThunk *)obj,info->prof.closure_desc);
+ printThunkObject((StgThunk *)obj,GET_PROF_DESC(info));
#else
printThunkObject((StgThunk *)obj,"THUNK");
#endif
/* Cannot happen -- use default case.
case RET_BCO:
case RET_SMALL:
- case RET_VEC_SMALL:
case RET_BIG:
- case RET_VEC_BIG:
case RET_DYN:
case RET_FUN:
*/
debugBelch("MUT_ARR_PTRS_FROZEN(size=%lu)\n", (lnat)((StgMutArrPtrs *)obj)->ptrs);
break;
- case MVAR:
+ case MVAR_CLEAN:
+ case MVAR_DIRTY:
{
StgMVar* mv = (StgMVar*)obj;
debugBelch("MVAR(head=%p, tail=%p, value=%p)\n", mv->head, mv->tail, mv->value);
}
case RET_SMALL:
- case RET_VEC_SMALL:
debugBelch("RET_SMALL (%p)\n", info);
bitmap = info->layout.bitmap;
printSmallBitmap(spBottom, sp+1,
}
case RET_BIG:
- case RET_VEC_BIG:
barf("todo");
case RET_FUN:
"CONSTR_2",
"CONSTR_1",
"CONSTR_0",
- "CONSTR_INTLIKE",
- "CONSTR_CHARLIKE",
"CONSTR_STATIC",
"CONSTR_NOCAF_STATIC",
"FUN",
"IND_STATIC",
"RET_BCO",
"RET_SMALL",
- "RET_VEC_SMALL",
"RET_BIG",
- "RET_VEC_BIG",
"RET_DYN",
"RET_FUN",
"UPDATE_FRAME",
"RBH",
"EVACUATED",
"REMOTE_REF",
- "TVAR_WAIT_QUEUE",
+ "TVAR_WATCH_QUEUE",
+ "INVARIANT_CHECK_QUEUE",
+ "ATOMIC_INVARIANT",
"TVAR",
"TREC_CHUNK",
"TREC_HEADER",
* ------------------------------------------------------------------------*/
struct entry {
- nat value;
+ StgWord value;
const char *name;
};
/* Could sort it... */
}
-static void insert( unsigned value, const char *name )
+static void insert( StgWord value, const char *name )
{
if ( table_size >= max_table_size ) {
barf( "Symbol table overflow\n" );
#endif
#if 0
-static rtsBool lookup_name( char *name, unsigned *result )
+static rtsBool lookup_name( char *name, StgWord *result )
{
- int i;
+ nat i;
for( i = 0; i < table_size && strcmp(name,table[i].name) != 0; ++i ) {
}
if (i < table_size) {
const char *lookupGHCName( void *addr )
{
nat i;
- for( i = 0; i < table_size && table[i].value != (unsigned) addr; ++i ) {
+ for( i = 0; i < table_size && table[i].value != (StgWord) addr; ++i ) {
}
if (i < table_size) {
return table[i].name;
void findPtr(P_ p, int); /* keep gcc -Wall happy */
+int searched = 0;
+
+static int
+findPtrBlocks (StgPtr p, bdescr *bd, StgPtr arr[], int arr_size, int i)
+{
+ StgPtr q, r;
+ for (; bd; bd = bd->link) {
+ searched++;
+ for (q = bd->start; q < bd->free; q++) {
+ if (UNTAG_CLOSURE((StgClosure*)*q) == (StgClosure *)p) {
+ if (i < arr_size) {
+ r = q;
+ while (HEAP_ALLOCED((StgPtr)*r) || !LOOKS_LIKE_INFO_PTR(*r) || (P_)*r == NULL) {
+ r--;
+ }
+ debugBelch("%p = ", r);
+ printClosure((StgClosure *)r);
+ arr[i++] = r;
+ } else {
+ return i;
+ }
+ }
+ }
+ }
+ return i;
+}
+
void
findPtr(P_ p, int follow)
{
nat s, g;
- P_ q, r;
bdescr *bd;
#if defined(__GNUC__)
const int arr_size = 1024;
#endif
StgPtr arr[arr_size];
int i = 0;
+ searched = 0;
for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
for (s = 0; s < generations[g].n_steps; s++) {
bd = generations[g].steps[s].blocks;
- for (; bd; bd = bd->link) {
- for (q = bd->start; q < bd->free; q++) {
- if (*q == (W_)p) {
- if (i < arr_size) {
- r = q;
- while (!LOOKS_LIKE_INFO_PTR(*r) || (P_)*r == NULL) {
- r--;
- }
- debugBelch("%p = ", r);
- printClosure((StgClosure *)r);
- arr[i++] = r;
- } else {
- return;
- }
- }
- }
- }
+ i = findPtrBlocks(p,bd,arr,arr_size,i);
+ bd = generations[g].steps[s].large_objects;
+ i = findPtrBlocks(p,bd,arr,arr_size,i);
+ if (i >= arr_size) return;
}
}
if (follow && i == 1) {
}
}
+/* prettyPrintClosure() is for printing out a closure using the data constructor
+ names found in the info tables. Closures are printed in a fashion that resembles
+ their Haskell representation. Useful during debugging.
+
+ Todo: support for more closure types, and support for non pointer fields in the
+ payload.
+*/
+
+void prettyPrintClosure_ (StgClosure *);
+
+void prettyPrintClosure (StgClosure *obj)
+{
+ prettyPrintClosure_ (obj);
+ debugBelch ("\n");
+}
+
+void prettyPrintClosure_ (StgClosure *obj)
+{
+ StgInfoTable *info;
+ StgConInfoTable *con_info;
+
+ /* collapse any indirections */
+ unsigned int type;
+ type = get_itbl(obj)->type;
+
+ while (type == IND ||
+ type == IND_STATIC ||
+ type == IND_OLDGEN ||
+ type == IND_PERM ||
+ type == IND_OLDGEN_PERM)
+ {
+ obj = ((StgInd *)obj)->indirectee;
+ type = get_itbl(obj)->type;
+ }
+
+ /* find the info table for this object */
+ info = get_itbl(obj);
+
+ /* determine what kind of object we have */
+ switch (info->type)
+ {
+ /* full applications of data constructors */
+ case CONSTR:
+ case CONSTR_1_0:
+ case CONSTR_0_1:
+ case CONSTR_1_1:
+ case CONSTR_0_2:
+ case CONSTR_2_0:
+ case CONSTR_STATIC:
+ case CONSTR_NOCAF_STATIC:
+ {
+ nat i;
+ char *descriptor;
+
+ /* find the con_info for the constructor */
+ con_info = get_con_itbl (obj);
+
+ /* obtain the name of the constructor */
+ descriptor = GET_CON_DESC(con_info);
+
+ debugBelch ("(%s", descriptor);
+
+ /* process the payload of the closure */
+ /* we don't handle non pointers at the moment */
+ for (i = 0; i < info->layout.payload.ptrs; i++)
+ {
+ debugBelch (" ");
+ prettyPrintClosure_ ((StgClosure *) obj->payload[i]);
+ }
+ debugBelch (")");
+ break;
+ }
+
+ /* if it isn't a constructor then just print the closure type */
+ default:
+ {
+ debugBelch ("<%s>", info_type(obj));
+ break;
+ }
+ }
+}
+
#else /* DEBUG */
void printPtr( StgPtr p )
{
{
debugBelch("obj 0x%p (enable -DDEBUG for more info) " , obj );
}
+
+
#endif /* DEBUG */