X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=rts%2FPrinter.c;h=3e80bd1a6f08a106eaf6e164a93861b50f77d11f;hb=4c6a3f787abcaed009a574196d82237d9ae64fc8;hp=83afd48a5079d057448e8c33a1fb654344154ca7;hpb=a0be7e7ccd602efd9b7d35b3e0747a2c4f155ce9;p=ghc-hetmet.git diff --git a/rts/Printer.c b/rts/Printer.c index 83afd48..3e80bd1 100644 --- a/rts/Printer.c +++ b/rts/Printer.c @@ -15,7 +15,6 @@ #include "RtsFlags.h" #include "MBlock.h" -#include "Storage.h" #include "Bytecodes.h" /* for InstrPtr */ #include "Disassembler.h" #include "Apply.h" @@ -37,10 +36,10 @@ static void printStdObjPayload( StgClosure *obj ); #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 ); @@ -137,8 +136,9 @@ printClosure( StgClosure *obj ) 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("); @@ -174,7 +174,7 @@ printClosure( StgClosure *obj ) 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 @@ -262,9 +262,7 @@ printClosure( StgClosure *obj ) /* 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: */ @@ -342,7 +340,8 @@ printClosure( StgClosure *obj ) 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); @@ -577,7 +576,6 @@ printStackChunk( StgPtr sp, StgPtr spBottom ) } case RET_SMALL: - case RET_VEC_SMALL: debugBelch("RET_SMALL (%p)\n", info); bitmap = info->layout.bitmap; printSmallBitmap(spBottom, sp+1, @@ -596,7 +594,6 @@ printStackChunk( StgPtr sp, StgPtr spBottom ) } case RET_BIG: - case RET_VEC_BIG: barf("todo"); case RET_FUN: @@ -683,9 +680,7 @@ static char *closure_type_names[] = { "IND_STATIC", "RET_BCO", "RET_SMALL", - "RET_VEC_SMALL", "RET_BIG", - "RET_VEC_BIG", "RET_DYN", "RET_FUN", "UPDATE_FRAME", @@ -714,7 +709,9 @@ static char *closure_type_names[] = { "RBH", "EVACUATED", "REMOTE_REF", - "TVAR_WAIT_QUEUE", + "TVAR_WATCH_QUEUE", + "INVARIANT_CHECK_QUEUE", + "ATOMIC_INVARIANT", "TVAR", "TREC_CHUNK", "TREC_HEADER", @@ -751,7 +748,7 @@ info_hdr_type(StgClosure *closure, char *res){ * ------------------------------------------------------------------------*/ struct entry { - nat value; + StgWord value; const char *name; }; @@ -773,7 +770,7 @@ static void prepare_table( void ) /* 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" ); @@ -785,9 +782,9 @@ static void insert( unsigned value, const char *name ) #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) { @@ -930,7 +927,7 @@ static void enZcode( char *in, char *out ) 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; @@ -1068,11 +1065,37 @@ extern void DEBUG_LoadSymbols( char *name STG_UNUSED ) 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; @@ -1081,27 +1104,15 @@ findPtr(P_ p, int follow) #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) { @@ -1110,6 +1121,88 @@ findPtr(P_ p, int follow) } } +/* 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 ) { @@ -1120,4 +1213,6 @@ void printObj( StgClosure *obj ) { debugBelch("obj 0x%p (enable -DDEBUG for more info) " , obj ); } + + #endif /* DEBUG */