X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fruntime%2Fc-as-asm%2FStgDebug.lc;fp=ghc%2Fruntime%2Fc-as-asm%2FStgDebug.lc;h=0000000000000000000000000000000000000000;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=51070611246bbf5bcc3cb60247e2e7262e9f58b7;hpb=967cc47f37cb93a5e2b6df7822c9a646f0428247;p=ghc-hetmet.git diff --git a/ghc/runtime/c-as-asm/StgDebug.lc b/ghc/runtime/c-as-asm/StgDebug.lc deleted file mode 100644 index 5107061..0000000 --- a/ghc/runtime/c-as-asm/StgDebug.lc +++ /dev/null @@ -1,3102 +0,0 @@ -\section[StgDebug]{Useful debugging routines for the STG machine} - -Call these functions directly from a debugger to print Nodes, -registers, stacks, etc. - -(An invocation such as - - make EXTRA_HC_OPTS='-optl-u -optl_DEBUG_LoadSymbols' ghci - - is usually required to get this code included in the object code.) - -Nota Bene: in a registerised build, you have to save all the registers -in their appropriate SAVE locations before calling any code that needs -register contents. (This has to be repeated every time you emerge -from the STG world.) - -On a sparc, this can be done by the following gdb script - -define saveRegs - - set *(&MainRegTable+8) = $l1 - set *(&MainRegTable+9) = $l2 - set *(&MainRegTable+10) = $l3 - set *(&MainRegTable+11) = $l4 - set *(&MainRegTable+12) = $l5 - set *(&MainRegTable+13) = $l6 - set *(&MainRegTable+14) = $l7 - set *(&MainRegTable+4) = $f2 - set *(&MainRegTable+5) = $f3 - set *(&MainRegTable+6) = $f4 - set *(&MainRegTable+7) = $f5 - - set *((double *) &MainRegTable+0) = (double) $f6 - set *((double *) &MainRegTable+2) = (double) $f8 - set *(&MainRegTable+23) = $l0 - set *(&MainRegTable+16) = $i0 - set *(&MainRegTable+17) = $i1 - set *(&MainRegTable+18) = $i2 - set *(&MainRegTable+19) = $i3 - set *(&StorageMgrInfo+0) = $i4 - set *(&StorageMgrInfo+1) = $i5 - -end - - -New code (attempts to interpret heap/stack contents) - DEBUG_LoadSymbols( filename ) Load symbol table from object file - (not essential but useful initialisation) - DEBUG_PrintA( depth, size ) Print "depth" entries from A stack - DEBUG_PrintB( depth, size ) ditto - DEBUG_Where( depth, size ) Ambitious attempt to print stacks - symbolically. Result is a little inaccurate - but often good enough to do the job. - DEBUG_NODE( closure, size ) Print a closure on the heap - DEBUG_INFO_TABLE(closure) Print info-table of a closure - DEBUG_SPT( size ) Print the Stable Pointer Table - -(Use variable DEBUG_details to set level of detail shown.) - -Older code (less fancy ==> more reliable) - DEBUG_ASTACK(lines) Print "lines" lines of the A Stack - DEBUG_BSTACK(lines) Print "lines" lines of the B Stack - DEBUG_UPDATES(frames) Print "frames" update frames - DEBUG_REGS() Print register values - DEBUG_FO() Print the ForeignObj Lists - DEBUG_TSO(tso) (CONCURRENT) Print a Thread State Object - -Not yet implemented: - DEBUG_STKO(stko) (CONCURRENT) Print a STacK Object - -\begin{code} -#include "rtsdefs.h" -\end{code} - -\subsection[StgDebug_Symbol_Tables]{Loading Symbol Tables} - -NB: this assumes a.out files - won't work on Alphas. -ToDo: At least add some #ifdefs - -\begin{code} -/* #include */ -/* #include */ -/* #include */ - -#include - -#define FROM_START 0 /* for fseek */ - -/* Simple lookup table */ - -/* Current implementation is pretty dumb! */ - -struct entry { - unsigned value; - int index; - char *name; -}; - -static int table_uninitialised = 1; -static int max_table_size; -static int table_size; -static struct entry* table; - -static void -reset_table( int size ) -{ - max_table_size = size; - table_size = 0; - table = (struct entry *) stgMallocBytes(size * sizeof(struct entry), "reset_table"); -} - -static void -prepare_table() -{ - /* Could sort it... */ -} - -static void -insert( unsigned value, int index, char *name ) -{ - if ( table_size >= max_table_size ) { - fprintf( stderr, "Symbol table overflow\n" ); - EXIT( 1 ); - } - table[table_size].value = value; - table[table_size].index = index; - table[table_size].name = name; - table_size = table_size + 1; -} - -static int -lookup( unsigned value, int *result ) -{ - int i; - for( i = 0; i < table_size && table[i].value != value; ++i ) { - } - if (i < table_size) { - *result = table[i].index; - return 1; - } else { - return 0; - } -} - -static int -lookup_name( char *name, unsigned *result ) -{ - int i; - for( i = 0; i < table_size && strcmp(name,table[i].name) != 0; ++i ) { - } - if (i < table_size) { - *result = table[i].value; - return 1; - } else { - return 0; - } -} -\end{code} - -* Z-escapes: - "std"++xs -> "Zstd"++xs - char_to_c 'Z' = "ZZ" - char_to_c '&' = "Za" - char_to_c '|' = "Zb" - char_to_c ':' = "Zc" - char_to_c '/' = "Zd" - char_to_c '=' = "Ze" - char_to_c '>' = "Zg" - char_to_c '#' = "Zh" - char_to_c '<' = "Zl" - char_to_c '-' = "Zm" - char_to_c '!' = "Zn" - char_to_c '.' = "Zo" - char_to_c '+' = "Zp" - char_to_c '\'' = "Zq" - char_to_c '*' = "Zt" - char_to_c '_' = "Zu" - char_to_c c = "Z" ++ show (ord c) - -\begin{code} -static char unZcode( char ch ) -{ - switch (ch) { - case 'Z' : - case '\0' : - return ('Z'); - case 'a' : - return ('&'); - case 'b' : - return ('|'); - case 'c' : - return (':'); - case 'd' : - return ('/'); - case 'e' : - return ('='); - case 'g' : - return ('>'); - case 'h' : - return ('#'); - case 'l' : - return ('<'); - case 'm' : - return ('-'); - case 'n' : - return ('!'); - case 'o' : - return ('.'); - case 'p' : - return ('+'); - case 'q' : - return ('\''); - case 't' : - return ('*'); - case 'u' : - return ('_'); - default : - return (ch); - } -} - -/* Precondition: out big enough to handle output (about twice length of in) */ -static void enZcode( char *in, char *out ) -{ - int i, j; - - j = 0; - out[ j++ ] = '_'; - for( i = 0; in[i] != '\0'; ++i ) { - switch (in[i]) { - case 'Z' : - out[j++] = 'Z'; - out[j++] = 'Z'; - break; - case '&' : - out[j++] = 'Z'; - out[j++] = 'a'; - break; - case '|' : - out[j++] = 'Z'; - out[j++] = 'b'; - break; - case ':' : - out[j++] = 'Z'; - out[j++] = 'c'; - break; - case '/' : - out[j++] = 'Z'; - out[j++] = 'd'; - break; - case '=' : - out[j++] = 'Z'; - out[j++] = 'e'; - break; - case '>' : - out[j++] = 'Z'; - out[j++] = 'g'; - break; - case '#' : - out[j++] = 'Z'; - out[j++] = 'h'; - break; - case '<' : - out[j++] = 'Z'; - out[j++] = 'l'; - break; - case '-' : - out[j++] = 'Z'; - out[j++] = 'm'; - break; - case '!' : - out[j++] = 'Z'; - out[j++] = 'n'; - break; - case '.' : - out[j++] = 'Z'; - out[j++] = 'o'; - break; - case '+' : - out[j++] = 'Z'; - out[j++] = 'p'; - break; - case '\'' : - out[j++] = 'Z'; - out[j++] = 'q'; - break; - case '*' : - out[j++] = 'Z'; - out[j++] = 't'; - break; - case '_' : - out[j++] = 'Z'; - out[j++] = 'u'; - break; - default : - out[j++] = in[i]; - break; - } - } - out[j] = '\0'; -} -\end{code} - -\begin{code} -static int lookupForName( P_ addr, char **result ) -{ - int i; - for( i = 0; i < table_size && table[i].value != (unsigned) addr; ++i ) { - } - if (i < table_size) { - *result = table[i].name; - return 1; - } else { - return 0; - } -} - -static void printZcoded( char *raw ) -{ - int j; - - /* start at 1 to skip the leading "_" */ - for( j = 1; raw[j] != '\0'; /* explicit */) { - if (raw[j] == 'Z') { - putchar(unZcode(raw[j+1])); - j = j + 2; - } else { - putchar(raw[j]); - j = j + 1; - } - } -} - -static void printName( P_ addr ) -{ - char *raw; - - if (lookupForName( addr, &raw )) { - printZcoded(raw); - } else { - printf("0x%x", addr); - } -} - -#if 0 /* OMIT load-symbol stuff cos it doesn't work on Alphas */ - -/* Fairly ad-hoc piece of code that seems to filter out a lot of - rubbish like the obj-splitting symbols */ - -static int -isReal( unsigned char type, char *name ) -{ - int external = type & N_EXT; - int tp = type & N_TYPE; - - if (tp == N_TEXT || tp == N_DATA) { - return( name[0] == '_' && name[1] != '_' ); - } else { - return( 0 ); - } -} - -void -DEBUG_LoadSymbols( char *name ) -{ - FILE *binary; - - struct exec header; - - long sym_offset; - long sym_size; - long num_syms; - long num_real_syms; - struct nlist *symbol_table; - - long str_offset; - long str_size; /* assumed 4 bytes.... */ - char *string_table; - - long i; - - binary = fopen( name, "r" ); - if (binary == NULL) { - fprintf( stderr, "Can't open symbol table file \"%s\".\n", name ); - } - - - if (fread( &header, sizeof( struct exec ), 1, binary ) != 1) { - fprintf( stderr, "Can't read symbol table header.\n" ); - EXIT( 1 ); - } - if ( N_BADMAG( header ) ) { - fprintf( stderr, "Bad magic number in symbol table header.\n" ); - EXIT( 1 ); - } - - - - sym_offset = N_SYMOFF( header ); - sym_size = header.a_syms; - num_syms = sym_size / sizeof( struct nlist ); - fseek( binary, sym_offset, FROM_START ); - - symbol_table = (struct nlist *) stgMallocBytes(sym_size, "symbol table (DEBUG_LoadSymbols)"); - printf("Reading %d symbols\n", num_syms); - - if (fread( symbol_table, sym_size, 1, binary ) != 1) { - fprintf( stderr, "Can't read symbol table\n"); - EXIT( 1 ); - } - - str_offset = N_STROFF( header ); - fseek( binary, str_offset, FROM_START ); - - if (fread( &str_size, 4, 1, binary ) != 1) { - fprintf( stderr, "Can't read string table size\n"); - EXIT( 1 ); - } - - /* apparently the size of the string table includes the 4 bytes that - * store the size... - */ - string_table = (char *) stgMallocBytes(str_size, "string table (DEBUG_LoadSymbols)"); - - if (fread( string_table+4, str_size-4, 1, binary ) != 1) { - fprintf( stderr, "Can't read string table\n"); - EXIT( 1 ); - } - - num_real_syms = 0; - for( i = 0; i != num_syms; ++i ) { - unsigned char type = symbol_table[i].n_type; - unsigned value = symbol_table[i].n_value; - char *str = &string_table[symbol_table[i].n_un.n_strx]; - - if ( isReal( type, str ) ) { - num_real_syms = num_real_syms + 1; - } - } - - printf("Of which %d are real symbols\n", num_real_syms); - -/* - for( i = 0; i != num_syms; ++i ) { - unsigned char type = symbol_table[i].n_type; - unsigned value = symbol_table[i].n_value; - char *str = &string_table[symbol_table[i].n_un.n_strx]; - - if ( isReal(type, str) ) { - printf("Symbol %d. Extern? %c. Type: %c. Value: 0x%x. Name: %s\n", - i, - (external ? 'y' : 'n'), - type, - value, - str - ); - } - } -*/ - - reset_table( num_real_syms ); - - for( i = 0; i != num_syms; ++i ) { - unsigned char type = symbol_table[i].n_type; - unsigned value = symbol_table[i].n_value; - char *str = &string_table[symbol_table[i].n_un.n_strx]; - - if ( isReal( type, str ) ) { - insert( value, i, str ); - } - - } - - prepare_table(); -} -#endif /* 0 */ -\end{code} - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -% -\subsection[StgDebug_PrettyPrinting]{Pretty printing internal structures} -% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -\begin{code} -#include "../storage/SMinternal.h" - -#ifdef GCap -#define HP_BOT appelInfo.oldbase -#elif GCdu -#define HP_BOT dualmodeInfo.modeinfo[dualmodeInfo.mode].base -#elif GC2s -#define HP_BOT semispaceInfo[semispace].base -#elif GC1s -#define HP_BOT compactingInfo.base -#else - unknown garbage collector - help, help! -#endif -\end{code} - -\begin{code} -/* range: 0..NUM_LEVELS_OF_DETAIL-1. Level of machine-related detail shown */ -#define NUM_LEVELS_OF_DETAIL 3 -static int DEBUG_details = 2; -\end{code} - -\begin{code} -/* Determine the size and number of pointers for this kind of closure */ -static void -getClosureShape( P_ node, int *vhs, int *size, int *ptrs, char **type ) -{ - /* The result is used for printing out closure contents. If the - info-table is mince, we'd better conservatively guess there's - nothing in the closure to avoid chasing non-ptrs. */ - *vhs = 0; - *size = 0; - *ptrs = 0; - *type = "*unknown info type*"; - - /* ToDo: if in garbage collector, consider subtracting some weird offset which some GCs add to infoptr */ - - /* The order here precisely reflects that in SMInfoTables.lh to make - it easier to check that this list is complete. */ - switch(INFO_TYPE(INFO_PTR(node))) - { - case INFO_SPEC_U_TYPE: - *vhs = 0; /* by decree */ - *size = SPEC_CLOSURE_SIZE(node); - *ptrs = SPEC_CLOSURE_NoPTRS(node); - *type = "SPECU"; - break; - case INFO_SPEC_N_TYPE: - *vhs = 0; /* by decree */ - *size = SPEC_CLOSURE_SIZE(node); - *ptrs = SPEC_CLOSURE_NoPTRS(node); - *type = "SPECN"; - break; - - case INFO_GEN_U_TYPE: - *vhs = GEN_VHS; - *size = GEN_CLOSURE_SIZE(node); - *ptrs = GEN_CLOSURE_NoPTRS(node); - *type = "GENU"; - break; - case INFO_GEN_N_TYPE: - *vhs = GEN_VHS; - *size = GEN_CLOSURE_SIZE(node); - *ptrs = GEN_CLOSURE_NoPTRS(node); - *type = "GENN"; - break; - - case INFO_DYN_TYPE: - *vhs = DYN_VHS; - *size = DYN_CLOSURE_SIZE(node); - *ptrs = DYN_CLOSURE_NoPTRS(node); - *type = "DYN"; - break; - - case INFO_TUPLE_TYPE: - *vhs = TUPLE_VHS; - *size = TUPLE_CLOSURE_SIZE(node); - *ptrs = TUPLE_CLOSURE_NoPTRS(node); - *type = "TUPLE"; - break; - - case INFO_DATA_TYPE: - *vhs = DATA_VHS; - *size = DATA_CLOSURE_SIZE(node); - *ptrs = DATA_CLOSURE_NoPTRS(node); - *type = "DATA"; - break; - - case INFO_MUTUPLE_TYPE: - *vhs = MUTUPLE_VHS; - *size = MUTUPLE_CLOSURE_SIZE(node); - *ptrs = MUTUPLE_CLOSURE_NoPTRS(node); - *type = "MUTUPLE"; - break; - - case INFO_IMMUTUPLE_TYPE: - *vhs = MUTUPLE_VHS; - *size = MUTUPLE_CLOSURE_SIZE(node); - *ptrs = MUTUPLE_CLOSURE_NoPTRS(node); - *type = "IMMUTUPLE"; - break; - - case INFO_STATIC_TYPE: - *vhs = STATIC_VHS; - *size = INFO_SIZE(INFO_PTR(node)); - *ptrs = INFO_NoPTRS(INFO_PTR(node)); - *type = "STATIC"; - break; - - case INFO_CONST_TYPE: - *vhs = 0; - *size = 0; - *ptrs = 0; - *type = "CONST"; - break; - - case INFO_CHARLIKE_TYPE: - *vhs = 0; - *size = 1; - *ptrs = 0; - *type = "CHAR"; - break; - - case INFO_INTLIKE_TYPE: - *vhs = 0; - *size = 1; - *ptrs = 0; - *type = "INT"; - break; - - case INFO_BH_TYPE: - *vhs = 0; - *size = INFO_SIZE(INFO_PTR(node)); - *ptrs = 0; - *type = "BHOLE"; - break; - -/* most of the following are plausible guesses (particularily VHSs) ADR */ - case INFO_BQ_TYPE: -#ifdef CONCURRENT - *vhs = 0; - *size = BQ_CLOSURE_SIZE(node); - *ptrs = BQ_CLOSURE_NoPTRS(node); - *type = "BQ"; -#else - printf("Panic: found BQ Infotable in non-threaded system.\n"); -#endif - break; - - case INFO_IND_TYPE: - *vhs = 0; - *size = IND_CLOSURE_SIZE(node); - *ptrs = IND_CLOSURE_NoPTRS(node); - *type = "IND"; - break; - - case INFO_CAF_TYPE: - *vhs = 0; /* ?? ADR */ - *size = INFO_SIZE(INFO_PTR(node)); - *ptrs = 0; - *type = "CAF"; - break; - - case INFO_FETCHME_TYPE: -#ifdef PAR - *vhs = FETCHME_VHS; - *size = FETCHME_CLOSURE_SIZE(node); - *ptrs = FETCHME_CLOSURE_NoPTRS(node); - *type = "FETCHME"; -#else - printf("Panic: found FETCHME Infotable in sequential system.\n"); -#endif - break; - - case INFO_FMBQ_TYPE: -#ifdef PAR - *vhs = FMBQ_VHS; - *size = FMBQ_CLOSURE_SIZE(node); - *ptrs = FMBQ_CLOSURE_NoPTRS(node); - *type = "FMBQ"; -#else - printf("Panic: found FMBQ Infotable in sequential system.\n"); -#endif - break; - - case INFO_BF_TYPE: -#ifdef PAR - *vhs = 0; - *size = 0; - *ptrs = 0; - *type = "BlockedFetch"; -#else - printf("Panic: found BlockedFetch Infotable in sequential system.\n"); -#endif - break; - - case INFO_TSO_TYPE: - /* Conservative underestimate: this will contain a regtable - which comes nowhere near fitting the standard "p ptrs; s-p - non-ptrs" format. ADR */ -#ifdef CONCURRENT - *vhs = TSO_VHS; - *size = 0; - *ptrs = 0; - *type = "TSO"; -#else - printf("Panic: found TSO Infotable in non-threaded system.\n"); -#endif - break; - - case INFO_STKO_TYPE: - /* Conservative underestimate: this will contain stuff - which comes nowhere near fitting the standard "p ptrs; s-p - non-ptrs" format. JSM */ -#ifdef CONCURRENT - *vhs = STKO_VHS; - *size = 0; - *ptrs = 0; - *type = "STKO"; -#else - printf("Panic: found STKO Infotable in non-threaded system.\n"); -#endif - break; - - /* There are no others in SMInfoTables.lh 11/5/94 ADR*/ - default: - printf("Invalid/unknown info type %ld\n", INFO_TYPE(INFO_PTR(node))); - break; - } -} - -static void -printWord( W_ word ) -{ - printf("0x%08lx", word); -} - -static void -printAddress( P_ address ) -{ -# ifdef CONCURRENT - PP_ SpA = STKO_SpA(SAVE_StkO); - PP_ SuA = STKO_SuA(SAVE_StkO); - P_ SpB = STKO_SpB(SAVE_StkO); - P_ SuB = STKO_SuB(SAVE_StkO); - PP_ botA = 0; /* junk */ - P_ botB = 0; -# define CAN_SEE_STK_BOTTOMS 0 -# else - PP_ SpA = SAVE_SpA; - PP_ SuA = SAVE_SuA; - P_ SpB = SAVE_SpB; - P_ SuB = SAVE_SuB; - PP_ botA = stackInfo.botA; - P_ botB = stackInfo.botB; -# define CAN_SEE_STK_BOTTOMS 1 -# endif - P_ Hp = SAVE_Hp; - - P_ HpBot = HP_BOT; - - char *name; - - /* ToDo: check if it's in text or data segment. */ - - /* The @-1@s in stack comparisons are because we sometimes use the - address of just below the stack... */ - -#if 0 - if (lookupForName( address, &name )) { - printZcoded( name ); - } - else -#endif - { - if (DEBUG_details > 1) { - printWord( (W_) address ); - printf(" : "); - } - if (HpBot <= address && address < Hp) { - printf("Hp[%d]", address - HpBot); - } else if ( CAN_SEE_STK_BOTTOMS - && SUBTRACT_A_STK((PP_)address, botA) >= -1 - && SUBTRACT_A_STK(SpA, (PP_)address) >= 0) { - printf("SpA[%d]", SUBTRACT_A_STK((PP_)address, botA)); - - } else if ( CAN_SEE_STK_BOTTOMS - && SUBTRACT_B_STK(address, botB) >= -1 - && SUBTRACT_B_STK(SpB, address) >= 0) { - /* ToDo: check if it's an update frame */ - printf("SpB[%d]", SUBTRACT_B_STK(address, botB)); - - } else { - printWord( (W_) address ); - } - } -} - -static void -printIndentation( int indentation ) -{ - int i; - for (i = 0; i < indentation; ++i) { printf(" "); } -} - -/* The weight parameter is used to (eventually) break cycles */ -static void -printStandardShapeClosure( - int indentation, - int weight, - P_ closure, int vhs, int size, int noPtrs -) -{ -#ifdef CONCURRENT - PP_ SpA = STKO_SpA(SAVE_StkO); - PP_ SuA = STKO_SuA(SAVE_StkO); - P_ SpB = STKO_SpB(SAVE_StkO); - P_ SuB = STKO_SuB(SAVE_StkO); -#else - PP_ SpA = SAVE_SpA; - PP_ SuA = SAVE_SuA; - P_ SpB = SAVE_SpB; - P_ SuB = SAVE_SuB; -#endif - P_ Hp = SAVE_Hp; - - void printClosure PROTO( (P_, int, int) ); - int numValues = size - vhs; - P_ HpBot = HP_BOT; - - if (DEBUG_details > 1) { - printAddress( closure ); - printf(": "); - } - printName((P_)INFO_PTR(closure)); - - if ( numValues > 0 ) { - int newWeight = weight-1 ; - /* I've tried dividing the weight by size to share it out amongst - sub-closures - but that didn't work too well. */ - - if (newWeight > 0) { - int i=0; - printf("(\n"); - while (i < numValues) { - P_ data = (P_) closure[_FHS + vhs + i]; - - printIndentation(indentation+1); - if (i < noPtrs) { - printClosure( data, indentation+1, newWeight); - } else { - printAddress( data ); - } - i = i + 1; - if (i < numValues) printf(",\n"); - } - printf(")"); - } else { - int i; - printf("(_"); - for( i = 1; i < size; ++i ) { - printf(",_"); - } - printf(")"); - } - } -} - -/* Should be static but has to be extern to allow mutual recursion */ -void -printClosure( P_ closure, int indentation, int weight ) -{ - int vhs, size, ptrs; - char *type; - - /* I'd love to put a test here that this actually _is_ a closure - - but testing that it is in the heap is overly strong. */ - - getClosureShape(closure, &vhs, &size, &ptrs, &type); - - /* The order here precisely reflects that in SMInfoTables.lh to make - it easier to check that this list is complete. */ - switch(INFO_TYPE(INFO_PTR(closure))) { - case INFO_SPEC_U_TYPE: - case INFO_SPEC_N_TYPE: - case INFO_GEN_U_TYPE: - case INFO_GEN_N_TYPE: - case INFO_DYN_TYPE: - case INFO_TUPLE_TYPE: - case INFO_DATA_TYPE: - case INFO_MUTUPLE_TYPE: - case INFO_IMMUTUPLE_TYPE: - printStandardShapeClosure(indentation, weight, closure, - vhs, size, ptrs); - break; - - case INFO_STATIC_TYPE: - /* If the STATIC contains Floats or Doubles, we can't print it. */ - /* And we can't always rely on the size/ptrs info either */ - printAddress( closure ); - printf(" STATIC"); - break; - - case INFO_CONST_TYPE: - if (DEBUG_details > 1) { - printAddress( closure ); - printf(": "); - } - printName((P_)INFO_PTR(closure)); - break; - - case INFO_CHARLIKE_TYPE: - /* ToDo: check for non-printable characters */ - if (DEBUG_details > 1) printf("CHARLIKE "); - printf("\'%c\'", (unsigned char) CHARLIKE_VALUE(closure)); - break; - - case INFO_INTLIKE_TYPE: - if (DEBUG_details > 1) printf("INTLIKE "); - printf("%ld",INTLIKE_VALUE(closure)); - break; - - case INFO_BH_TYPE: - /* Is there anything to say here> */ - if (DEBUG_details > 1) { - printAddress( closure ); - printf(": "); - } - printName((P_)INFO_PTR(closure)); - break; - -/* most of the following are just plausible guesses (particularily VHSs) ADR */ - - case INFO_BQ_TYPE: -#ifdef CONCURRENT - printStandardShapeClosure(indentation, weight, closure, - vhs, size, ptrs); -#else - printf("Panic: found BQ Infotable in non-threaded system.\n"); -#endif - break; - - case INFO_IND_TYPE: - if (DEBUG_details > 0) { - printAddress( closure ); - printf(" IND: "); - } - printClosure( (P_) IND_CLOSURE_PTR(closure), indentation, weight ); - break; - - case INFO_CAF_TYPE: - if (DEBUG_details > 0) { - printAddress( closure ); - printf(" CAF: "); - } - printClosure( (P_) IND_CLOSURE_PTR(closure), indentation, weight ); - break; - - case INFO_FETCHME_TYPE: -#ifdef PAR - printStandardShapeClosure(indentation, weight, closure, - vhs, size, ptrs); -#else - printf("Panic: found FETCHME Infotable in sequential system.\n"); -#endif - break; - - case INFO_FMBQ_TYPE: -#ifdef PAR - printStandardShapeClosure(indentation, weight, closure, - vhs, size, ptrs); -#else - printf("Panic: found FMBQ Infotable in sequential system.\n"); -#endif - break; - - case INFO_BF_TYPE: -#ifdef PAR - printStandardShapeClosure(indentation, weight, closure, - vhs, size, ptrs); -#else - printf("Panic: found BlockedFetch Infotable in sequential system.\n"); -#endif - break; - - case INFO_TSO_TYPE: -#ifdef CONCURRENT - /* A TSO contains a regtable... */ - printAddress( closure ); - printf(" TSO: ..."); -#else - printf("Panic: found TSO Infotable in non-threaded system.\n"); -#endif - break; - - case INFO_STKO_TYPE: -#ifdef CONCURRENT - /* A STKO contains parts of the A and B stacks... */ - printAddress( closure ); - printf(" STKO: ..."); -#else - printf("Panic: found STKO Infotable in non-threaded system.\n"); -#endif - break; - - /* There are no others in SMInfoTables.lh 11/5/94 ADR*/ - default: - printf("Invalid/unknown info type %ld\n", INFO_TYPE(INFO_PTR(closure))); - break; - } -} - -void -DEBUG_NODE( P_ closure, int size ) -{ - printClosure( closure, 0, size ); - printf("\n"); -} -\end{code} - -Now some stuff for printing stacks - almost certainly doesn't work -under threads which keep the stack on the heap. - -\begin{code} -#ifndef CONCURRENT - -static int -minimum(int a, int b) -{ - if (a < b) { - return a; - } else { - return b; - } -} - -void -DEBUG_PrintA( int depth, int weight ) -{ - PP_ SpA = SAVE_SpA; - PP_ SuA = SAVE_SuA; - - int i; - I_ size = minimum(depth, SUBTRACT_A_STK(SpA, stackInfo.botA)+1); - - printf("Dump of the Address Stack (SpA = 0x%lx, SuA = 0x%lx)\n", SpA, SuA); - - for( i = 0; i < size; ++i ) { - printIndentation(1); - printf("SpA[%d] (0x%08lx):", i, SpA + AREL(i)); - printClosure((P_)*(SpA + AREL(i)), 2, weight); - printf("\n"); - } -} - -void -DEBUG_PrintB( int depth, int weight ) -{ - PP_ SpA = SAVE_SpA; - P_ SpB = SAVE_SpB; - P_ SuB = SAVE_SuB; - - I_ i; - I_ size = minimum(depth, SUBTRACT_B_STK(SpB, stackInfo.botB)+1); - - P_ updateFramePtr; - I_ update_count; - - printf("Dump of the Value Stack (SpB = 0x%lx, SuB = 0x%lx)\n", SpB, SuB); - - updateFramePtr = SuB; - update_count = 0; - i = 0; - while (i < size) { - if (updateFramePtr == SpB + BREL(i)) { - - printIndentation(1); - printf("SpB[%ld] (0x%08lx): UpdateFrame[%d](", - i, - updateFramePtr, - update_count - ); - printName( (P_) *(SpB + BREL(i)) ); - printf(", UF[%d] (= SpB[%ld]), SpA[%ld], ", - update_count+1, - SUBTRACT_B_STK(SpB, GRAB_SuB(updateFramePtr)), - SUBTRACT_A_STK(SpA, GRAB_SuA(updateFramePtr)) - ); - printAddress( GRAB_UPDATEE(updateFramePtr) ); - printf(")\n"); - - printIndentation(2); - printClosure( GRAB_UPDATEE(updateFramePtr), 3, weight ); - printf("\n"); - - updateFramePtr = GRAB_SuB(updateFramePtr); - update_count = update_count + 1; - - /* ToDo: GhcConstants.lh reveals that there are two other sizes possible */ - i = i + STD_UF_SIZE; - } else { - printIndentation(1); - printf("SpB[%ld] (0x%08lx): ", i, SpB + BREL(i) ); - printName((P_) *(SpB + BREL(i)) ); - printf("\n"); - i = i + 1; - } - } -} - -#else /* CONCURRENT */ - -static int -minimum(int a, int b) -{ - if (a < b) { - return a; - } else { - return b; - } -} - -void -DEBUG_PrintA( int depth, int weight ) -{ - P_ stko = SAVE_StkO; - PP_ SpA = STKO_SpA(stko); - PP_ SuA = STKO_SuA(stko); - P_ SpB = STKO_SpB(stko); - P_ SuB = STKO_SuB(stko); - P_ Hp = SAVE_Hp; - - int i; - I_ size = minimum(depth, SUBTRACT_A_STK(SpA, STKO_ASTK_BOT(stko))+1); - - printf("Dump of the Address Stack (SpA = 0x%x, SuA = 0x%x)\n", SpA, SuA); - - for( i = 0; i < size; ++i ) { - printIndentation(1); - printf("SpA[%ld] (0x%08lx):", i, SpA + AREL(i)); - printClosure((P_)*(SpA + AREL(i)), 2, weight); - printf("\n"); - } -} - -void -DEBUG_PrintB( int depth, int weight ) -{ - P_ stko = SAVE_StkO; - PP_ SpA = STKO_SpA(stko); - PP_ SuA = STKO_SuA(stko); - P_ SpB = STKO_SpB(stko); - P_ SuB = STKO_SuB(stko); - P_ Hp = SAVE_Hp; - - I_ i; - I_ size = minimum(depth, SUBTRACT_B_STK(SpB, STKO_BSTK_BOT(stko))+1); - - P_ updateFramePtr; - I_ update_count; - - printf("Dump of the Value Stack (SpB = 0x%x, SuB = 0x%x)\n", SpB, SuB); - - updateFramePtr = SuB; - update_count = 0; - i = 0; - while (i < size) { - if (updateFramePtr == SpB + BREL(i)) { - - printIndentation(1); - printf("SpB[%ld] (0x%08lx): UpdateFrame[%d](", - i, - updateFramePtr, - update_count - ); - printName( (P_) *(SpB + BREL(i)) ); - printf(", UF[%d] (= SpB[%ld]), SpA[%ld], ", - update_count+1, - SUBTRACT_B_STK(SpB, GRAB_SuB(updateFramePtr)), - SUBTRACT_A_STK(SpA, GRAB_SuA(updateFramePtr)) - ); - printAddress( GRAB_UPDATEE(updateFramePtr) ); - printf(")\n"); - - printIndentation(2); - printClosure( GRAB_UPDATEE(updateFramePtr), 3, weight ); - printf("\n"); - - updateFramePtr = GRAB_SuB(updateFramePtr); - update_count = update_count + 1; - - /* ToDo: GhcConstants.lh reveals that there are two other sizes possible */ - i = i + STD_UF_SIZE; - } else { - printIndentation(1); - printf("SpB[%ld] (0x%08lx): ", i, SpB + BREL(i) ); - printName((P_) *(SpB + BREL(i)) ); - printf("\n"); - i = i + 1; - } - } -} - -#endif /* not CONCURRENT */ -\end{code} - -ToDo: - - All the following code incorrectly assumes that the only return - addresses are those associated with update frames. - - To do a proper job of printing the environment we need to: - - 1) Recognise vectored and non-vectored returns on the B stack. - - 2) Know where the local variables are in the A and B stacks for - each return situation. - - Until then, we'll just need to look suspiciously at the - "environment" being printed out. - - ADR - -\begin{code} -/* How many real stacks are there on SpA and SpB? */ -/* Say what?? (Will and Phil, 96/01) */ -#ifndef CONCURRENT -static int -numStacks( ) -{ -#ifdef CONCURRENT - PP_ SpA = STKO_SpA(SAVE_StkO); - PP_ SuA = STKO_SuA(SAVE_StkO); - P_ SpB = STKO_SpB(SAVE_StkO); - P_ SuB = STKO_SuB(SAVE_StkO); -#else - P_ SuB = SAVE_SuB; -#endif - - int depth = 1; /* There's always at least one stack */ - - while (SUBTRACT_B_STK(SuB, stackInfo.botB) >= 0) { - SuB = GRAB_SuB( SuB ); - depth = depth + 1; - } - return depth; -} -#endif /* !CONCURRENT */ - -static void -printLocalAStack( int depth, int indentation, int weight, PP_ SpA, int size ) -{ - int i; - - ASSERT( size >= 0 ); - - for( i = size-1; i >= 0; --i ) { - printIndentation( indentation ); - printf("A[%ld][%d]", depth, i); - if (DEBUG_details > 1) printf(" (0x%08lx) ", SpA + AREL(i) ); - printf("="); - printClosure( *(SpA + AREL(i)), indentation+2, weight ); - printf("\n"); - } -} - -static void -printLocalBStack( int depth, int indentation, int weight, P_ SpB, int size ) -{ - int i; - - ASSERT( size >= 0 ); - - for( i = size-1; i >= 0; --i) { - printIndentation( indentation ); - printf("B[%d][%d]", depth, i); - if (DEBUG_details > 1) printf(" (0x%08lx) ", SpB + BREL(i) ); - printf("="); - printAddress( (P_) *(SpB + BREL(i)) ); - printf("\n"); - } -} - -static void -printEnvironment( int depth, int indentation, int weight, PP_ SpA, PP_ SuA, P_ SpB, P_ SuB ) -{ - int sizeA = SUBTRACT_A_STK(SpA, SuA); - int sizeB = SUBTRACT_B_STK(SpB, SuB); - - if (sizeA + sizeB > 0) { - printIndentation( indentation ); - printf("let\n"); - - printLocalAStack( depth, indentation+1, weight, SpA, sizeA ); - printLocalBStack( depth, indentation+1, weight, SpB, sizeB ); - - printIndentation( indentation ); - printf("in\n"); - } -} -\end{code} - -Printing the current context is a little tricky. - -Ideally, we would work from the bottom of the stack up to the top -recursively printing the stuff nearer the top. - -In practice, we have to work from the top down because the top -contains info about how much data is below the current return address. - -The result is that we have two recursive passes over the stacks: the -first one prints the "cases" and the second one prints the -continuations (vector tables, etc.) - -Note that because we compress chains of update frames, the depth and -indentation do not always change in step. - -ToDo: - -* detecting non-updating cases too -* printing continuations (from vector tables) properly -* printing sensible names in environment. -* fix bogus nature of lets - - -\begin{code} -static int maxDepth = 5; - -static int -printCases( int depth, int weight, PP_ SpA, PP_ SuA, P_ SpB, P_ SuB ) -{ -#ifdef CONCURRENT - printf("no printCases for CONCURRENT\n"); -#else - int indentation; - - if (depth < maxDepth && SUBTRACT_B_STK(SuB, stackInfo.botB) >= 0) { - PP_ nextSpA, nextSuA; - P_ nextSpB, nextSuB; - - /* ToDo: GhcConstants.lh reveals that there are two other sizes of - update frame possible */ - /* ToDo: botB is probably wrong in THREAD system */ - - nextSpB = SuB + BREL(STD_UF_SIZE); - nextSuB = GRAB_SuB( SuB ); - nextSpA = SuA; - nextSuA = GRAB_SuA( nextSuB ); - - indentation = printCases( depth+1, weight, nextSpA, nextSuA, nextSpB, nextSuB ); - - if (DEBUG_details > 1 || nextSpB != nextSuB) { /* show frame (even if adjacent to another) */ - printIndentation( indentation ); - printf("case\n"); - indentation = indentation + 1; - } - if (SpB != SuB) { - /* next thing on stack is a return vector - no need to show it here. */ - SpB = SpB + BREL(1); - } - printEnvironment( depth, indentation, weight, SpA, SuA, SpB, SuB ); - } else { - printf("...\n"); - indentation = 1; - } - - return indentation; - -#endif /* CONCURRENT */ -} - -/* ToDo: pay more attention to format of vector tables in SMupdate.lh */ - -static int -isVTBLEntry( P_ entry ) -{ - char *raw; - - if (lookupForName( entry, &raw )) { - if ( strncmp( "_ret", raw, 4 ) == 0 ) { - return 1; - } else if ( strncmp( "_djn", raw, 4 ) == 0) { - return 1; - } else { - return 0; - } - } else { - return 0; - } -} - -static void -printVectorTable( int indentation, PP_ vtbl ) -{ - if (isVTBLEntry( (P_) vtbl )) { /* Direct return */ - printName( (P_) vtbl ); - } else { - int i = 0; - while( isVTBLEntry( vtbl[RVREL(i)] )) { - printIndentation( indentation ); - printf( "%d -> ", i ); - printName( vtbl[RVREL(i)] ); - printf( "\n" ); - i = i + 1; - } - } -} - -static void -printContinuations( int depth, int indentation, int weight, PP_ SpA, PP_ SuA, P_ SpB, P_ SuB ) -{ -#ifdef CONCURRENT - printf("no printContinuations for CONCURRENT\n"); -#else - if (depth < maxDepth && SUBTRACT_B_STK(SuB, stackInfo.botB) >= 0) { - PP_ nextSpA, nextSuA; - P_ nextSpB, nextSuB; - int nextIndent = indentation; /* Indentation to print next frame at */ - - /* ToDo: GhcConstants.lh reveals that there are two other sizes of - update frame possible */ - /* ToDo: botB is probably wrong in THREAD system */ - - /* ToDo: ASSERT that SuA == nextSuA */ - - nextSpB = SuB + BREL(STD_UF_SIZE); - nextSuB = GRAB_SuB( SuB ); - nextSpA = SuA; - nextSuA = GRAB_SuA( nextSuB ); - - if (DEBUG_details > 0) { /* print update information */ - - if (SpB != SuB) { /* start of chain of update frames */ - printIndentation( indentation ); - printf("of updatePtr ->\n"); - printIndentation( indentation+1 ); - printf("update\n"); - } - printIndentation( indentation+2 ); - printClosure( (P_)*(SuB + BREL(UF_UPDATEE)), indentation+2, weight ); - printf(" := "); - printName( (P_) *(SuB + BREL(UF_RET)) ); - printf("(updatePtr)\n"); - - if (nextSpB != nextSuB) { /* end of chain of update frames */ - nextIndent = nextIndent-1; - printVectorTable( indentation+1, (PP_) *(nextSpB) ); - } - } else { - if (nextSpB != nextSuB) { /* end of chain of update frames */ - nextIndent = nextIndent-1; - printVectorTable( indentation, (PP_) *(nextSpB) ); - } - } - printContinuations( depth+1, nextIndent, weight, nextSpA, nextSuA, nextSpB, nextSuB ); - - } else { - printf("...\n"); - } -#endif /* CONCURRENT */ -} - -void -DEBUG_Where( int depth, int weight ) -{ -#ifdef CONCURRENT - PP_ SpA = STKO_SpA(SAVE_StkO); - PP_ SuA = STKO_SuA(SAVE_StkO); - P_ SpB = STKO_SpB(SAVE_StkO); - P_ SuB = STKO_SuB(SAVE_StkO); -#else - PP_ SpA = SAVE_SpA; - PP_ SuA = SAVE_SuA; - P_ SpB = SAVE_SpB; - P_ SuB = SAVE_SuB; -#endif - P_ Hp = SAVE_Hp; - StgRetAddr RetReg = SAVE_Ret; - P_ Node = SAVE_R1.p; - - int indentation; - - maxDepth = depth; - - printf("WARNING: Non-updating cases may be incorrectly displayed\n"); - - indentation = printCases( 1, weight, SpA, SuA, SpB, SuB ); - - printIndentation( indentation ); - printf("CASE\n"); - - printIndentation( indentation+1 ); - printName( Node ); - printf("\n"); - printVectorTable( indentation+1, (PP_) RetReg ); - - printContinuations( depth, indentation, weight, SpA, SuA, SpB, SuB ); -} -\end{code} - - -\begin{code} -void -DEBUG_INFO_TABLE(node) - P_ node; -{ - int vhs, size, ptrs; /* not used */ - char *ip_type; - StgPtr info_ptr = (StgPtr) INFO_PTR(node); - - getClosureShape(node, &vhs, &size, &ptrs, &ip_type); - - fprintf(stderr, - "%s Info Ptr 0x%lx; Entry: 0x%lx; Update: 0x%lx\n", - ip_type, info_ptr, - (W_) ENTRY_CODE(info_ptr), (W_) UPDATE_CODE(info_ptr)); - fprintf(stderr, - "Tag: %ld; Type: %ld; Size: %lu; Ptrs: %lu\n\n", - INFO_TAG(info_ptr), INFO_TYPE(info_ptr), - INFO_SIZE(info_ptr),INFO_NoPTRS(info_ptr)); -#if defined(GRIP) - /* flushing is GRIP only */ - fprintf(stderr,"Enter Flush Entry: 0x%lx;\tExit Flush Entry: 0x%lx\n",INFO_FLUSHENT(info_ptr),INFO_FLUSH(info_ptr)); -#endif /* GRIP */ - -#if defined(PROFILING) - fprintf(stderr,"Cost Centre: 0x%lx\n",INFO_CAT(info_ptr)); -#endif /* PROFILING */ - -#if defined(_INFO_COPYING) - fprintf(stderr,"Evacuate Entry: 0x%lx;\tScavenge Entry: 0x%lx\n", - INFO_EVAC_2S(info_ptr),INFO_SCAV_2S(info_ptr)); -#endif /* INFO_COPYING */ - -#if defined(_INFO_COMPACTING) - fprintf(stderr,"Scan Link: 0x%lx;\tScan Move: 0x%lx\n", - (W_) INFO_SCAN_LINK_1S(info_ptr), (W_) INFO_SCAN_MOVE_1S(info_ptr)); - fprintf(stderr,"Mark: 0x%lx;\tMarked: 0x%lx;\n", - (W_) INFO_MARK_1S(info_ptr), (W_) INFO_MARKED_1S(info_ptr)); - if(BASE_INFO_TYPE(info_ptr)==INFO_SPEC_TYPE) - fprintf(stderr,"plus specialised code\n"); - else - fprintf(stderr,"Marking: 0x%lx\n",(W_) INFO_MARKING_1S(info_ptr)); -#endif /* INFO_COMPACTING */ -} - -void -DEBUG_REGS() -{ -#ifdef CONCURRENT - PP_ SpA = STKO_SpA(SAVE_StkO); - PP_ SuA = STKO_SuA(SAVE_StkO); - P_ SpB = STKO_SpB(SAVE_StkO); - P_ SuB = STKO_SuB(SAVE_StkO); -#else - PP_ SpA = SAVE_SpA; - PP_ SuA = SAVE_SuA; - P_ SpB = SAVE_SpB; - P_ SuB = SAVE_SuB; -#endif - P_ Hp = SAVE_Hp; - P_ HpLim= SAVE_HpLim; - I_ TagReg= SAVE_Tag; - StgRetAddr RetReg = SAVE_Ret; - P_ Node = SAVE_R1.p; - StgUnion R1 = SAVE_R1; - StgUnion R2 = SAVE_R2; - StgUnion R3 = SAVE_R3; - StgUnion R4 = SAVE_R4; - StgUnion R5 = SAVE_R5; - StgUnion R6 = SAVE_R6; - StgUnion R7 = SAVE_R7; - StgUnion R8 = SAVE_R8; - StgFloat FltReg1 = SAVE_Flt1; - StgFloat FltReg2 = SAVE_Flt2; - StgFloat FltReg3 = SAVE_Flt3; - StgFloat FltReg4 = SAVE_Flt4; - StgDouble DblReg1 = SAVE_Dbl1; - StgDouble DblReg2 = SAVE_Dbl2; -#if HAVE_LONG_LONG - StgDouble LngReg1 = SAVE_Lng1; - StgDouble LngReg2 = SAVE_Lng2; -#endif - - fprintf(stderr,"STG-Machine Register Values:\n\n"); - fprintf(stderr,"Node: %08lx; Hp: %08lx; HpLim: %08lx; Tag: %8lu\n",Node,(W_)Hp,(W_)HpLim,TagReg); - fprintf(stderr,"SpA: %08lx; SpB: %08lx; SuA: %08lx; SuB: %08lx\n",(W_)SpA,(W_)SpB,(W_)SuA,(W_)SuB); - fprintf(stderr,"RetReg: %08lx\n",RetReg); - -#if 0 -/* These bits need to have the FLUSH_REG_MAP, whereas the surrounding bits - use the MAIN_REG_MAP */ - - fprintf(stderr, "\n"); - fprintf(stderr,"LiveR: %08lx\n", LivenessReg); - fprintf(stderr,"Flush: %08lx; FStk: %08lx; FStkB: %08lx; FTmp: %08lx\n",(W_)FlushP,(W_)FStack,(W_)FStackBase,(W_)Temp); -#endif /* 0 */ - - fprintf(stderr, "\n"); - - fprintf(stderr,"Gen: %8lu, %8lu, %8lu, %8lu\n",R1.i,R2.i,R3.i,R4.i); - fprintf(stderr," %8lu, %8lu, %8lu, %8lu\n",R5.i,R6.i,R7.i,R8.i); - fprintf(stderr,"Float: %8g, %8g, %8g, %8g\n",FltReg1,FltReg2,FltReg3,FltReg4); - fprintf(stderr,"Dble: %8g, %8g\n",DblReg1,DblReg2); -#if HAVE_LONG_LONG - fprintf(stderr,"Long: %8lu, %8lu\n",LngReg1,LngReg2); -#endif -} - -#ifndef CONCURRENT - -void -DEBUG_FO() -{ - StgPtr mp; - StgInt i; - - fprintf(stderr,"ForeignObjList\n\n"); - - for(mp = StorageMgrInfo.ForeignObjList; - mp != NULL; - mp = ForeignObj_CLOSURE_LINK(mp)) { - - fprintf(stderr, - "ForeignObjPtr(0x%lx) = 0x%lx, finaliser: 0x%lx\n", - mp, - ForeignObj_CLOSURE_DATA(mp), - ForeignObj_CLOSURE_FINALISER(mp)); - -/* - DEBUG_PRINT_NODE(mp); -*/ - } - -# if defined(GCap) || defined(GCgn) - fprintf(stderr,"\nOldForeignObj List\n\n"); - - for(mp = StorageMgrInfo.OldForeignObjList; - mp != NULL; - mp = ForeignObj_CLOSURE_LINK(mp)) { - - fprintf(stderr, - "ForeignObj(0x%lx) = 0x%lx, finaliser: 0x%lx\n", - mp, - ForeignObj_CLOSURE_DATA(mp), - ForeignObj_CLOSURE_FINALISER(mp)); -/* - DEBUG_PRINT_NODE(mp); -*/ - } -# endif /* GCap || GCgn */ - - fprintf(stderr, "\n"); -} - -void -DEBUG_SPT(int weight) -{ - StgPtr SPTable = StorageMgrInfo.StablePointerTable; - StgInt size = SPT_SIZE(SPTable); - StgInt ptrs = SPT_NoPTRS(SPTable); - StgInt top = SPT_TOP(SPTable); - - StgInt i; - -/* - DEBUG_PRINT_NODE(SPTable); -*/ - - fprintf(stderr,"SPTable@0x%lx:\n", SPTable); - fprintf(stderr," InfoPtr = 0x%lx\n", INFO_PTR(SPTable)); - fprintf(stderr," size = %d, ptrs = %d, top = %d\n", - size, ptrs, top - ); - for( i=0; i < ptrs; i++ ) { - if (i % 10 == 0) { - fprintf(stderr,"\n "); - } - printClosure(SPT_SPTR(SPTable, i),1,weight); - fprintf(stderr, "\n"); - } - fprintf(stderr, "\n"); - for( i=0; i < top; i++) { - if (i % 10 == 0) { - fprintf(stderr,"\n "); - } - fprintf(stderr, " %3d", SPT_FREE(SPTable, i)); - } - - fprintf(stderr, "\n\n"); - -} -#endif /* !CONCURRENT */ - -/* - These routines crawl over the A and B stacks, printing - a maximum "lines" lines at the top of the stack. -*/ - -#define STACK_VALUES_PER_LINE 5 - -#ifndef CONCURRENT -/* (stack stuff is really different on parallel machines) */ - -void -DEBUG_ASTACK(lines) - I_ lines; -{ - PP_ SpA = SAVE_SpA; - PP_ SuA = SAVE_SuA; - P_ SpB = SAVE_SpB; - P_ SuB = SAVE_SuB; - - PP_ stackptr; - I_ count = 0; - - fprintf(stderr,"Dump of the Address Stack, SpA: 0x%08lx, BOS: 0x%08lx\n", - (W_) SpA, (W_) stackInfo.botA); - - for (stackptr = SpA; - SUBTRACT_A_STK(stackptr, stackInfo.botA) >= 0; - stackptr = stackptr + AREL(1)) - { - if( count++ % STACK_VALUES_PER_LINE == 0) - { - if(count >= lines * STACK_VALUES_PER_LINE) - break; - fprintf(stderr,"\nSpA[%ld] (0x%08lx): ",count-1,stackptr); - } - fprintf(stderr,"0x%08lx ",(W_) *stackptr); - } - fprintf(stderr, "\n"); -} - -void -DEBUG_BSTACK(lines) - I_ lines; -{ - PP_ SpA = SAVE_SpA; - PP_ SuA = SAVE_SuA; - P_ SpB = SAVE_SpB; - P_ SuB = SAVE_SuB; - - P_ stackptr; - I_ count = 0; - - fprintf(stderr,"Dump of the Value Stack, SpB: 0x%08lx, BOS: 0x%08lx\n", - (W_) SpB, (W_) stackInfo.botB); - - for (stackptr = SpB; - SUBTRACT_B_STK(stackptr, stackInfo.botB) > 0; - stackptr = stackptr + BREL(1)) - { - if( count++ % STACK_VALUES_PER_LINE == 0) - { - if(count >= lines * STACK_VALUES_PER_LINE) - break; - fprintf(stderr,"\nSpB[%ld] (0x%08lx): ",count-1,stackptr); - } - fprintf(stderr,"0x%08lx ",(W_) *stackptr); - } - fprintf(stderr, "\n"); -} - - -#endif /* not concurrent */ - -/* - This should disentangle update frames from both stacks. -*/ - -#ifndef CONCURRENT -void -DEBUG_UPDATES(limit) - I_ limit; -{ - PP_ SpA = SAVE_SpA; - PP_ SuA = SAVE_SuA; - P_ SpB = SAVE_SpB; - P_ SuB = SAVE_SuB; - - P_ updatee, retreg; - PP_ sua, spa; - P_ sub, spb; - I_ count = 0; - - fprintf(stderr,"Update Frame Stack Dump:\n\n"); - - for(spa = SuA, spb = SuB; - SUBTRACT_B_STK(spb, stackInfo.botB) > 0 && count++ < limit; - spa = GRAB_SuA(spb), spb = GRAB_SuB(spb) ) { - - updatee = GRAB_UPDATEE(spb); /* Thing to be updated */ - retreg = (P_) GRAB_RET(spb); /* Return vector below */ - - fprintf(stderr,"SuA: 0x%08lx, SuB: 0x%08lx, Updatee 0x%08lx (Info 0x%08lx), RetReg 0x%x\n", - (W_) spa, (W_) spb, - (W_) updatee, (W_) INFO_PTR(updatee), (W_) retreg); - } -} - -#endif /* not concurrent */ -\end{code} - -\begin{code} -#ifdef CONCURRENT - -void -DEBUG_TSO(P_ tso) -{ - STGRegisterTable *r = TSO_INTERNAL_PTR(tso); - W_ liveness = r->rLiveness; - I_ i; - - fprintf(stderr,"TSO:\ntso=%lx, regs=%lx, liveness=%lx\nlink=%lx,name=%lx,id=%lx,type=%lx,pc1=%lx,arg1=%lx,switch=%lx\n" - , tso - , r - , liveness - , TSO_LINK(tso) - , TSO_NAME(tso) - , TSO_ID(tso) - , TSO_TYPE(tso) - , TSO_PC1(tso) - , TSO_ARG1(tso) - , TSO_SWITCH(tso) - ); - - for (i = 0; liveness != 0; liveness >>= 1, i++) { - if (liveness & 1) { - fprintf(stderr, "live reg %d (%lx)\n",i, r->rR[i].p); - } else { - fprintf(stderr, "reg %d (%lx) not live\n", i, r->rR[i].p); - } - } -} - -#endif /* concurrent */ -\end{code} - -%**************************************************************************** -% -\subsection[GrAnSim-debug]{Debugging routines for GrAnSim} -% -%**************************************************************************** - -Debugging routines, mainly for GrAnSim. -They should really be in a separate file. -There is some code duplication of above routines in here, I'm afraid. - -As a naming convention all GrAnSim debugging functions start with @G_@. -The shorthand forms defined at the end start only with @G@. - -\begin{code} -#if defined(GRAN) && defined(GRAN_CHECK) - -#define NULL_REG_MAP /* Not threaded */ -/* #include "stgdefs.h" */ - -char * -info_hdr_type(info_ptr) -P_ info_ptr; -{ -#if ! defined(PAR) && !defined(GRAN) - switch (INFO_TAG(info_ptr)) - { - case INFO_OTHER_TAG: - return("OTHER_TAG"); -/* case INFO_IND_TAG: - return("IND_TAG"); -*/ default: - return("TAG"); - } -#else /* PAR */ - switch(BASE_INFO_TYPE(info_ptr)) - { - case INFO_SPEC_TYPE: - return("SPEC"); - - case INFO_GEN_TYPE: - return("GEN"); - - case INFO_DYN_TYPE: - return("DYN"); - - case INFO_TUPLE_TYPE: - return("TUPLE"); - - case INFO_DATA_TYPE: - return("DATA"); - - case INFO_MUTUPLE_TYPE: - return("MUTUPLE"); - - case INFO_IMMUTUPLE_TYPE: - return("IMMUTUPLE"); - - case INFO_STATIC_TYPE: - return("STATIC"); - - case INFO_CONST_TYPE: - return("CONST"); - - case INFO_CHARLIKE_TYPE: - return("CHAR"); - - case INFO_INTLIKE_TYPE: - return("INT"); - - case INFO_BH_TYPE: - return("BHOLE"); - - case INFO_BQ_TYPE: - return("BQ"); - - case INFO_IND_TYPE: - return("IND"); - - case INFO_CAF_TYPE: - return("CAF"); - - case INFO_FM_TYPE: - return("FETCHME"); - - case INFO_TSO_TYPE: - return("TSO"); - - case INFO_STKO_TYPE: - return("STKO"); - - case INFO_SPEC_RBH_TYPE: - return("SPEC_RBH"); - - case INFO_GEN_RBH_TYPE: - return("GEN_RBH"); - - case INFO_BF_TYPE: - return("BF"); - - case INFO_INTERNAL_TYPE: - return("INTERNAL"); - - default: - fprintf(stderr,"Unknown header type %lu\n",INFO_TYPE(info_ptr)); - return("??"); - } -#endif /* PAR */ -} - -char * -info_type(infoptr, str) -P_ infoptr; -char *str; -{ - strcpy(str,""); - if ( IS_NF(infoptr) ) - strcat(str,"|_NF "); - else if ( IS_MUTABLE(infoptr) ) - strcat(str,"|_MU"); - else if ( IS_STATIC(infoptr) ) - strcat(str,"|_ST"); - else if ( IS_UPDATABLE(infoptr) ) - strcat(str,"|_UP"); - else if ( IS_BIG_MOTHER(infoptr) ) - strcat(str,"|_BM"); - else if ( IS_BLACK_HOLE(infoptr) ) - strcat(str,"|_BH"); - else if ( IS_INDIRECTION(infoptr) ) - strcat(str,"|_IN"); - else if ( IS_THUNK(infoptr) ) - strcat(str,"|_TH"); - - return(str); -} - -/* -@var_hdr_size@ computes the size of the variable header for a closure. -*/ - -I_ -var_hdr_size(node) -P_ node; -{ - switch(INFO_TYPE(INFO_PTR(node))) - { - case INFO_SPEC_U_TYPE: return(0); /* by decree */ - case INFO_SPEC_N_TYPE: return(0); - case INFO_GEN_U_TYPE: return(GEN_VHS); - case INFO_GEN_N_TYPE: return(GEN_VHS); - case INFO_DYN_TYPE: return(DYN_VHS); - /* - case INFO_DYN_TYPE_N: return(DYN_VHS); - case INFO_DYN_TYPE_U: return(DYN_VHS); - */ - case INFO_TUPLE_TYPE: return(TUPLE_VHS); - case INFO_DATA_TYPE: return(DATA_VHS); - case INFO_MUTUPLE_TYPE: return(MUTUPLE_VHS); - case INFO_IMMUTUPLE_TYPE: return(MUTUPLE_VHS); /* same layout */ - case INFO_STATIC_TYPE: return(STATIC_VHS); - case INFO_CONST_TYPE: return(0); - case INFO_CHARLIKE_TYPE: return(0); - case INFO_INTLIKE_TYPE: return(0); - case INFO_BH_TYPE: return(0); - case INFO_IND_TYPE: return(0); - case INFO_CAF_TYPE: return(0); - case INFO_FETCHME_TYPE: return(0); - case INFO_BQ_TYPE: return(0); - /* - case INFO_BQENT_TYPE: return(0); - */ - case INFO_TSO_TYPE: return(TSO_VHS); - case INFO_STKO_TYPE: return(STKO_VHS); - default: - fprintf(stderr,"Unknown info type 0x%lx (%lu)\n", INFO_PTR(node), - INFO_TYPE(INFO_PTR(node))); - return(0); - } -} - - -/* Determine the size and number of pointers for this kind of closure */ -void -size_and_ptrs(node,size,ptrs) -P_ node; -W_ *size, *ptrs; -{ - switch(INFO_TYPE(INFO_PTR(node))) - { - case INFO_SPEC_U_TYPE: - case INFO_SPEC_N_TYPE: - *size = INFO_SIZE(INFO_PTR(node)); /* New for 0.24; check */ - *ptrs = INFO_NoPTRS(INFO_PTR(node)); /* that! -- HWL */ - /* - *size = SPEC_CLOSURE_SIZE(node); - *ptrs = SPEC_CLOSURE_NoPTRS(node); - */ - break; - - case INFO_GEN_U_TYPE: - case INFO_GEN_N_TYPE: - *size = GEN_CLOSURE_SIZE(node); - *ptrs = GEN_CLOSURE_NoPTRS(node); - break; - - /* - case INFO_DYN_TYPE_U: - case INFO_DYN_TYPE_N: - */ - case INFO_DYN_TYPE: - *size = DYN_CLOSURE_SIZE(node); - *ptrs = DYN_CLOSURE_NoPTRS(node); - break; - - case INFO_TUPLE_TYPE: - *size = TUPLE_CLOSURE_SIZE(node); - *ptrs = TUPLE_CLOSURE_NoPTRS(node); - break; - - case INFO_DATA_TYPE: - *size = DATA_CLOSURE_SIZE(node); - *ptrs = DATA_CLOSURE_NoPTRS(node); - break; - - case INFO_IND_TYPE: - *size = IND_CLOSURE_SIZE(node); - *ptrs = IND_CLOSURE_NoPTRS(node); - break; - -/* ToDo: more (WDP) */ - - /* Don't know about the others */ - default: - *size = *ptrs = 0; - break; - } -} - -void -G_PRINT_NODE(node) -P_ node; -{ - P_ info_ptr, bqe; /* = INFO_PTR(node); */ - I_ size = 0, ptrs = 0, nonptrs = 0, i, vhs = 0; - char info_hdr_ty[80], info_ty[80]; - - if (node==NULL) { - fprintf(stderr,"NULL\n"); - return; - } else if (node==PrelBase_Z91Z93_closure) { - fprintf(stderr,"PrelBase_Z91Z93_closure\n"); - return; - } else if (node==MUT_NOT_LINKED) { - fprintf(stderr,"MUT_NOT_LINKED\n"); - return; - } - /* size_and_ptrs(node,&size,&ptrs); */ - info_ptr = get_closure_info(node, &size, &ptrs, &nonptrs, &vhs, info_hdr_ty); - - /* vhs = var_hdr_size(node); */ - info_type(info_ptr,info_ty); - - fprintf(stderr,"Node: 0x%lx", (W_) node); - -#if defined(PAR) - fprintf(stderr," [GA: 0x%lx]",GA(node)); -#endif - -#if defined(USE_COST_CENTRES) - fprintf(stderr," [CC: 0x%lx]",CC_HDR(node)); -#endif - -#if defined(GRAN) - fprintf(stderr," [Bitmask: 0%lo]",PROCS(node)); -#endif - - if (info_ptr==INFO_TSO_TYPE) - fprintf(stderr," TSO: 0x%lx (%x) IP: 0x%lx (%s), type %s \n ", - node, TSO_ID(node), info_ptr, info_hdr_ty, info_ty); - else - fprintf(stderr," IP: 0x%lx (%s), type %s \n VHS: %d, size: %ld, ptrs:%ld, nonptrs: %ld\n ", - info_ptr,info_hdr_ty,info_ty,vhs,size,ptrs,nonptrs); - - /* For now, we ignore the variable header */ - - fprintf(stderr," Ptrs: "); - for(i=0; i < ptrs; ++i) - { - if ( (i+1) % 6 == 0) - fprintf(stderr,"\n "); - fprintf(stderr," 0x%lx[P]",*(node+_FHS+vhs+i)); - }; - - fprintf(stderr," Data: "); - for(i=0; i < nonptrs; ++i) - { - if( (i+1) % 6 == 0) - fprintf(stderr,"\n "); - fprintf(stderr," %lu[D]",*(node+_FHS+vhs+ptrs+i)); - } - fprintf(stderr, "\n"); - - - switch (INFO_TYPE(info_ptr)) - { - case INFO_TSO_TYPE: - fprintf(stderr,"\n TSO_LINK: %#lx", - TSO_LINK(node)); - break; - - case INFO_BH_TYPE: - case INFO_BQ_TYPE: - bqe = (P_)BQ_ENTRIES(node); - fprintf(stderr," BQ of %#lx: ", node); - PRINT_BQ(bqe); - break; - case INFO_FMBQ_TYPE: - printf("Panic: found FMBQ Infotable in GrAnSim system.\n"); - break; - case INFO_SPEC_RBH_TYPE: - bqe = (P_)SPEC_RBH_BQ(node); - fprintf(stderr," BQ of %#lx: ", node); - PRINT_BQ(bqe); - break; - case INFO_GEN_RBH_TYPE: - bqe = (P_)GEN_RBH_BQ(node); - fprintf(stderr," BQ of %#lx: ", node); - PRINT_BQ(bqe); - break; - } -} - -void -G_PPN(node) /* Extracted from PrintPacket in Pack.lc */ -P_ node; -{ - P_ info ; - I_ size = 0, ptrs = 0, nonptrs = 0, i, vhs = 0, locn = 0; - char info_type[80]; - - /* size_and_ptrs(node,&size,&ptrs); */ - info = get_closure_info(node, &size, &ptrs, &nonptrs, &vhs, info_type); - - if (INFO_TYPE(info) == INFO_FETCHME_TYPE || IS_BLACK_HOLE(info)) - size = ptrs = nonptrs = vhs = 0; - - if (IS_THUNK(info)) { - if (IS_UPDATABLE(info)) - fputs("SHARED ", stderr); - else - fputs("UNSHARED ", stderr); - } - if (IS_BLACK_HOLE(info)) { - fputs("BLACK HOLE\n", stderr); - } else { - /* Fixed header */ - fprintf(stderr, "(%s) FH [%#lx", info_type, node[locn++]); - for (i = 1; i < FIXED_HS; i++) - fprintf(stderr, " %#lx", node[locn++]); - - /* Variable header */ - if (vhs > 0) { - fprintf(stderr, "] VH [%#lx", node[locn++]); - - for (i = 1; i < vhs; i++) - fprintf(stderr, " %#lx", node[locn++]); - } - - fprintf(stderr, "] PTRS %u", ptrs); - - /* Non-pointers */ - if (nonptrs > 0) { - fprintf(stderr, " NPTRS [%#lx", node[locn++]); - - for (i = 1; i < nonptrs; i++) - fprintf(stderr, " %#lx", node[locn++]); - - putc(']', stderr); - } - putc('\n', stderr); - } - - } - -#define INFO_MASK 0x80000000 - -void -G_MUT(node,verbose) /* Print mutables list starting with node */ -P_ node; -{ - if (verbose & 0x1) { G_PRINT_NODE(node); fprintf(stderr, "\n"); } - else fprintf(stderr, "0x%#lx, ", node); - - if (node==NULL || node==PrelBase_Z91Z93_closure || node==MUT_NOT_LINKED) { - return; - } - G_MUT(MUT_LINK(node), verbose); -} - - -void -G_TREE(node) -P_ node; -{ - W_ size = 0, ptrs = 0, i, vhs = 0; - - /* Don't print cycles */ - if((INFO_PTR(node) & INFO_MASK) != 0) - return; - - size_and_ptrs(node,&size,&ptrs); - vhs = var_hdr_size(node); - - G_PRINT_NODE(node); - fprintf(stderr, "\n"); - - /* Mark the node -- may be dangerous */ - INFO_PTR(node) |= INFO_MASK; - - for(i = 0; i < ptrs; ++i) - G_TREE((P_)node[i+vhs+_FHS]); - - /* Unmark the node */ - INFO_PTR(node) &= ~INFO_MASK; -} - - -void -G_INFO_TABLE(node) -P_ node; -{ - P_ info_ptr = (P_)INFO_PTR(node); - char *ip_type = info_hdr_type(info_ptr); - - fprintf(stderr,"%s Info Ptr @0x%lx; Entry: 0x%lx; Size: %lu; Ptrs: %lu\n\n", - ip_type,info_ptr,(W_) ENTRY_CODE(info_ptr),INFO_SIZE(info_ptr),INFO_NoPTRS(info_ptr)); - - if (IS_THUNK(info_ptr) && IS_UPDATABLE(info_ptr) ) { - fprintf(stderr," RBH InfoPtr: %#lx\n", - RBH_INFOPTR(info_ptr)); - } - -#if defined(PAR) - fprintf(stderr,"Enter Flush Entry: 0x%lx;\tExit Flush Entry: 0x%lx\n",INFO_FLUSHENT(info_ptr),INFO_FLUSH(info_ptr)); -#endif - -#if defined(USE_COST_CENTRES) - fprintf(stderr,"Cost Centre (???): 0x%lx\n",INFO_CAT(info_ptr)); -#endif - -#if defined(_INFO_COPYING) - fprintf(stderr,"Evacuate Entry: 0x%lx;\tScavenge Entry: 0x%lx\n", - INFO_EVAC_2S(info_ptr),INFO_SCAV_2S(info_ptr)); -#endif - -#if defined(_INFO_COMPACTING) - fprintf(stderr,"Scan Link: 0x%lx;\tScan Move: 0x%lx\n", - (W_) INFO_SCAN_LINK_1S(info_ptr), (W_) INFO_SCAN_MOVE_1S(info_ptr)); - fprintf(stderr,"Mark: 0x%lx;\tMarked: 0x%lx;\t", - (W_) INFO_MARK_1S(info_ptr), (W_) INFO_MARKED_1S(info_ptr)); -#if 0 /* avoid INFO_TYPE */ - if(BASE_INFO_TYPE(info_ptr)==INFO_SPEC_TYPE) - fprintf(stderr,"plus specialised code\n"); - else - fprintf(stderr,"Marking: 0x%lx\n",(W_) INFO_MARKING_1S(info_ptr)); -#endif /* 0 */ -#endif /* _INFO_COMPACTING */ -} -#endif /* GRAN */ - -\end{code} - -The remaining debugging routines are more or less specific for GrAnSim. - -\begin{code} -#if defined(GRAN) && defined(GRAN_CHECK) -void -G_CURR_THREADQ(verbose) -I_ verbose; -{ - fprintf(stderr,"Thread Queue on proc %d: ", CurrentProc); - G_THREADQ(ThreadQueueHd, verbose); -} - -void -G_THREADQ(closure, verbose) -P_ closure; -I_ verbose; -{ - P_ x; - - fprintf(stderr,"Thread Queue: "); - for (x=closure; x!=PrelBase_Z91Z93_closure; x=TSO_LINK(x)) - if (verbose) - G_TSO(x,0); - else - fprintf(stderr," %#lx",x); - - if (closure==PrelBase_Z91Z93_closure) - fprintf(stderr,"NIL\n"); - else - fprintf(stderr,"\n"); -} - -/* Check with Threads.lh */ -static char *type_name[] = { "T_MAIN", "T_REQUIRED", "T_ADVISORY", "T_FAIL"}; - -void -G_TSO(closure,verbose) -P_ closure; -I_ verbose; -{ - - if (closure==PrelBase_Z91Z93_closure) { - fprintf(stderr,"TSO at %#lx is PrelBase_Z91Z93_closure!\n"); - return; - } - - if ( verbose & 0x08 ) { /* short info */ - fprintf(stderr,"[TSO @ %#lx, PE %d]: Name: %#lx, Id: %#lx, Link: %#lx\n", - closure,where_is(closure), - TSO_NAME(closure),TSO_ID(closure),TSO_LINK(closure)); - return; - } - - fprintf(stderr,"TSO at %#lx has the following contents:\n", - closure); - - fprintf(stderr,"> Name: \t%#lx",TSO_NAME(closure)); - fprintf(stderr,"\tLink: \t%#lx\n",TSO_LINK(closure)); - fprintf(stderr,"> Id: \t%#lx",TSO_ID(closure)); -#if defined(GRAN_CHECK) && defined(GRAN) - if (RTSflags.GranFlags.debug & 0x10) - fprintf(stderr,"\tType: \t%s %s\n", - type_name[TSO_TYPE(closure) & ~FETCH_MASK_TSO], - (TSO_TYPE(closure) & FETCH_MASK_TSO) ? "SLEEPING" : ""); - else - fprintf(stderr,"\tType: \t%s\n",type_name[TSO_TYPE(closure)]); -#else - fprintf(stderr,"\tType: \t%s\n",type_name[TSO_TYPE(closure)]); -#endif - fprintf(stderr,"> PC1: \t%#lx",TSO_PC1(closure)); - fprintf(stderr,"\tPC2: \t%#lx\n",TSO_PC2(closure)); - fprintf(stderr,"> ARG1: \t%#lx",TSO_ARG1(closure)); - /* fprintf(stderr,"\tARG2: \t%#lx\n",TSO_ARG2(closure)); */ - fprintf(stderr,"> SWITCH: \t%#lx", TSO_SWITCH(closure)); -#if defined(GRAN_PRI_SCHED) - fprintf(stderr,"\tPRI: \t%#lx\n", TSO_PRI(closure)); -#else - fprintf(stderr,"\n"); -#endif - if (verbose) { - fprintf(stderr,"} LOCKED: \t%#lx",TSO_LOCKED(closure)); - fprintf(stderr,"\tSPARKNAME: \t%#lx\n", TSO_SPARKNAME(closure)); - fprintf(stderr,"} STARTEDAT: \t%#lx", TSO_STARTEDAT(closure)); - fprintf(stderr,"\tEXPORTED: \t%#lx\n", TSO_EXPORTED(closure)); - fprintf(stderr,"} BASICBLOCKS: \t%#lx", TSO_BASICBLOCKS(closure)); - fprintf(stderr,"\tALLOCS: \t%#lx\n", TSO_ALLOCS(closure)); - fprintf(stderr,"} EXECTIME: \t%#lx", TSO_EXECTIME(closure)); - fprintf(stderr,"\tFETCHTIME: \t%#lx\n", TSO_FETCHTIME(closure)); - fprintf(stderr,"} FETCHCOUNT: \t%#lx", TSO_FETCHCOUNT(closure)); - fprintf(stderr,"\tBLOCKTIME: \t%#lx\n", TSO_BLOCKTIME(closure)); - fprintf(stderr,"} BLOCKCOUNT: \t%#lx", TSO_BLOCKCOUNT(closure)); - fprintf(stderr,"\tBLOCKEDAT: \t%#lx\n", TSO_BLOCKEDAT(closure)); - fprintf(stderr,"} GLOBALSPARKS:\t%#lx", TSO_GLOBALSPARKS(closure)); - fprintf(stderr,"\tLOCALSPARKS:\t%#lx\n", TSO_LOCALSPARKS(closure)); - } -#if defined(GRAN_CHECK) - if ( verbose & 0x02 ) { - fprintf(stderr,"BQ that starts with this TSO: "); - PRINT_BQ(closure); - } -#endif -} - -void -G_EVENT(event, verbose) -eventq event; -I_ verbose; -{ - if (verbose) { - print_event(event); - }else{ - fprintf(stderr," %#lx",event); - } -} - -void -G_EVENTQ(verbose) -I_ verbose; -{ - eventq x; - - fprintf(stderr,"Eventq (hd @%#lx):\n",EventHd); - for (x=EventHd; x!=NULL; x=EVENT_NEXT(x)) { - G_EVENT(x,verbose); - } - if (EventHd==NULL) - fprintf(stderr,"NIL\n"); - else - fprintf(stderr,"\n"); -} - -void -G_PE_EQ(pe,verbose) -PROC pe; -I_ verbose; -{ - eventq x; - - fprintf(stderr,"Eventq (hd @%#lx):\n",EventHd); - for (x=EventHd; x!=NULL; x=EVENT_NEXT(x)) { - if (EVENT_PROC(x)==pe) - G_EVENT(x,verbose); - } - if (EventHd==NULL) - fprintf(stderr,"NIL\n"); - else - fprintf(stderr,"\n"); -} - -void -G_SPARK(spark, verbose) -sparkq spark; -I_ verbose; -{ - if (verbose) - print_spark(spark); - else - fprintf(stderr," %#lx",spark); -} - -void -G_SPARKQ(spark,verbose) -sparkq spark; -I_ verbose; -{ - sparkq x; - - fprintf(stderr,"Sparkq (hd @%#lx):\n",spark); - for (x=spark; x!=NULL; x=SPARK_NEXT(x)) { - G_SPARK(x,verbose); - } - if (spark==NULL) - fprintf(stderr,"NIL\n"); - else - fprintf(stderr,"\n"); -} - -void -G_CURR_SPARKQ(verbose) -I_ verbose; -{ - G_SPARKQ(SparkQueueHd,verbose); -} - -void -G_PROC(proc,verbose) -I_ proc; -I_ verbose; -{ - extern char *proc_status_names[]; - - fprintf(stderr,"Status of proc %d at time %d (%#lx): %s (%s)\n", - proc,CurrentTime[proc],CurrentTime[proc], - (CurrentProc==proc)?"ACTIVE":"INACTIVE", - proc_status_names[procStatus[proc]]); - G_THREADQ(RunnableThreadsHd[proc],verbose & 0x2); - if ( (CurrentProc==proc) ) - G_TSO(CurrentTSO,1); - - if (EventHd!=NULL) - fprintf(stderr,"Next event (%s) is on proc %d\n", - event_names[EVENT_TYPE(EventHd)],EVENT_PROC(EventHd)); - - if (verbose & 0x1) { - fprintf(stderr,"\nREQUIRED sparks: "); - G_SPARKQ(PendingSparksHd[proc][REQUIRED_POOL],1); - fprintf(stderr,"\nADVISORY_sparks: "); - G_SPARKQ(PendingSparksHd[proc][ADVISORY_POOL],1); - } -} - -/* Debug Processor */ -void -GP(proc) -I_ proc; -{ G_PROC(proc,1); -} - -/* Debug Current Processor */ -void -GCP(){ G_PROC(CurrentProc,2); } - -/* Debug TSO */ -void -GT(P_ tso){ - G_TSO(tso,1); -} - -/* Debug CurrentTSO */ -void -GCT(){ - fprintf(stderr,"Current Proc: %d\n",CurrentProc); - G_TSO(CurrentTSO,1); -} - -/* Shorthand for debugging event queue */ -void -GEQ() { G_EVENTQ(1); } - -/* Shorthand for debugging thread queue of a processor */ -void -GTQ(PROC p) { G_THREADQ(RunnableThreadsHd[p],1); } - -/* Shorthand for debugging thread queue of current processor */ -void -GCTQ() { G_THREADQ(RunnableThreadsHd[CurrentProc],1); } - -/* Shorthand for debugging spark queue of a processor */ -void -GSQ(PROC p) { G_SPARKQ(PendingSparksHd[p][1],1); } - -/* Shorthand for debugging spark queue of current processor */ -void -GCSQ() { G_CURR_SPARKQ(1); } - -/* Shorthand for printing a node */ -void -GN(P_ node) { G_PRINT_NODE(node); } - -/* Shorthand for printing info table */ -void -GIT(P_ node) { G_INFO_TABLE(node); } - -/* Shorthand for some of ADRs debugging functions */ - -void -pC(P_ closure) { printClosure(closure, 0/*indentation*/, 10/*weight*/); } - -/* Print a closure on the heap */ -void -DN(P_ closure) { DEBUG_NODE( closure, 1/*size*/ );} - -/* Print info-table of a closure */ -void -DIT(P_ closure) { DEBUG_INFO_TABLE(closure); } - -/* (CONCURRENT) Print a Thread State Object */ -void -DT(P_ tso) { DEBUG_TSO(tso); } - -/* Not yet implemented: */ -/* (CONCURRENT) Print a STacK Object -void -DS(P_ stko) { DEBUG_STKO(stko) ; } -*/ - -#endif /* GRAN */ - -/* --------------------------- vvvv old vvvvv ------------------------*/ - -#if 0 /* ngo' ngoq! veQ yIboS! */ - -#define NULL_REG_MAP /* Not threaded */ -#include "stgdefs.h" - -char * -info_hdr_type(info_ptr) -W_ info_ptr; -{ -#if ! defined(PAR) && !defined(GRAN) - switch (INFO_TAG(info_ptr)) - { - case INFO_OTHER_TAG: - return("OTHER_TAG"); -/* case INFO_IND_TAG: - return("IND_TAG"); -*/ default: - return("TAG"); - } -#else /* PAR */ - switch(INFO_TYPE(info_ptr)) - { - case INFO_SPEC_U_TYPE: - return("SPECU"); - - case INFO_SPEC_N_TYPE: - return("SPECN"); - - case INFO_GEN_U_TYPE: - return("GENU"); - - case INFO_GEN_N_TYPE: - return("GENN"); - - case INFO_DYN_TYPE: - return("DYN"); - - /* - case INFO_DYN_TYPE_N: - return("DYNN"); - - case INFO_DYN_TYPE_U: - return("DYNU"); - */ - - case INFO_TUPLE_TYPE: - return("TUPLE"); - - case INFO_DATA_TYPE: - return("DATA"); - - case INFO_MUTUPLE_TYPE: - return("MUTUPLE"); - - case INFO_IMMUTUPLE_TYPE: - return("IMMUTUPLE"); - - case INFO_STATIC_TYPE: - return("STATIC"); - - case INFO_CONST_TYPE: - return("CONST"); - - case INFO_CHARLIKE_TYPE: - return("CHAR"); - - case INFO_INTLIKE_TYPE: - return("INT"); - - case INFO_BH_TYPE: - return("BHOLE"); - - case INFO_IND_TYPE: - return("IND"); - - case INFO_CAF_TYPE: - return("CAF"); - - case INFO_FETCHME_TYPE: - return("FETCHME"); - - case INFO_BQ_TYPE: - return("BQ"); - - /* - case INFO_BQENT_TYPE: - return("BQENT"); - */ - - case INFO_TSO_TYPE: - return("TSO"); - - case INFO_STKO_TYPE: - return("STKO"); - - default: - fprintf(stderr,"Unknown header type %lu\n",INFO_TYPE(info_ptr)); - return("??"); - } -#endif /* PAR */ -} - -/* -@var_hdr_size@ computes the size of the variable header for a closure. -*/ - -I_ -var_hdr_size(node) -P_ node; -{ - switch(INFO_TYPE(INFO_PTR(node))) - { - case INFO_SPEC_U_TYPE: return(0); /* by decree */ - case INFO_SPEC_N_TYPE: return(0); - case INFO_GEN_U_TYPE: return(GEN_VHS); - case INFO_GEN_N_TYPE: return(GEN_VHS); - case INFO_DYN_TYPE: return(DYN_VHS); - /* - case INFO_DYN_TYPE_N: return(DYN_VHS); - case INFO_DYN_TYPE_U: return(DYN_VHS); - */ - case INFO_TUPLE_TYPE: return(TUPLE_VHS); - case INFO_DATA_TYPE: return(DATA_VHS); - case INFO_MUTUPLE_TYPE: return(MUTUPLE_VHS); - case INFO_IMMUTUPLE_TYPE: return(MUTUPLE_VHS); /* same layout */ - case INFO_STATIC_TYPE: return(STATIC_VHS); - case INFO_CONST_TYPE: return(0); - case INFO_CHARLIKE_TYPE: return(0); - case INFO_INTLIKE_TYPE: return(0); - case INFO_BH_TYPE: return(0); - case INFO_IND_TYPE: return(0); - case INFO_CAF_TYPE: return(0); - case INFO_FETCHME_TYPE: return(0); - case INFO_BQ_TYPE: return(0); - /* - case INFO_BQENT_TYPE: return(0); - */ - case INFO_TSO_TYPE: return(TSO_VHS); - case INFO_STKO_TYPE: return(STKO_VHS); - default: - fprintf(stderr,"Unknown info type 0x%lx (%lu)\n", INFO_PTR(node), - INFO_TYPE(INFO_PTR(node))); - return(0); - } -} - - -/* Determine the size and number of pointers for this kind of closure */ -void -size_and_ptrs(node,size,ptrs) -P_ node; -W_ *size, *ptrs; -{ - switch(INFO_TYPE(INFO_PTR(node))) - { - case INFO_SPEC_U_TYPE: - case INFO_SPEC_N_TYPE: - *size = INFO_SIZE(INFO_PTR(node)); /* New for 0.24; check */ - *ptrs = INFO_NoPTRS(INFO_PTR(node)); /* that! -- HWL */ - /* - *size = SPEC_CLOSURE_SIZE(node); - *ptrs = SPEC_CLOSURE_NoPTRS(node); - */ - break; - - case INFO_GEN_U_TYPE: - case INFO_GEN_N_TYPE: - *size = GEN_CLOSURE_SIZE(node); - *ptrs = GEN_CLOSURE_NoPTRS(node); - break; - - /* - case INFO_DYN_TYPE_U: - case INFO_DYN_TYPE_N: - */ - case INFO_DYN_TYPE: - *size = DYN_CLOSURE_SIZE(node); - *ptrs = DYN_CLOSURE_NoPTRS(node); - break; - - case INFO_TUPLE_TYPE: - *size = TUPLE_CLOSURE_SIZE(node); - *ptrs = TUPLE_CLOSURE_NoPTRS(node); - break; - - case INFO_DATA_TYPE: - *size = DATA_CLOSURE_SIZE(node); - *ptrs = DATA_CLOSURE_NoPTRS(node); - break; - - case INFO_IND_TYPE: - *size = IND_CLOSURE_SIZE(node); - *ptrs = IND_CLOSURE_NoPTRS(node); - break; - -/* ToDo: more (WDP) */ - - /* Don't know about the others */ - default: - *size = *ptrs = 0; - break; - } -} - -void -DEBUG_PRINT_NODE(node) -P_ node; -{ - W_ info_ptr = INFO_PTR(node); - I_ size = 0, ptrs = 0, i, vhs = 0; - char *info_type = info_hdr_type(info_ptr); - - size_and_ptrs(node,&size,&ptrs); - vhs = var_hdr_size(node); - - fprintf(stderr,"Node: 0x%lx", (W_) node); - -#if defined(PAR) - fprintf(stderr," [GA: 0x%lx]",GA(node)); -#endif - -#if defined(PROFILING) - fprintf(stderr," [CC: 0x%lx]",CC_HDR(node)); -#endif - -#if defined(GRAN) - fprintf(stderr," [Bitmask: 0%lo]",PROCS(node)); -#endif - - fprintf(stderr," IP: 0x%lx (%s), size %ld, %ld ptrs\n", - info_ptr,info_type,size,ptrs); - - /* For now, we ignore the variable header */ - - for(i=0; i < size; ++i) - { - if(i == 0) - fprintf(stderr,"Data: "); - - else if(i % 6 == 0) - fprintf(stderr,"\n "); - - if(i < ptrs) - fprintf(stderr," 0x%lx[P]",*(node+_FHS+vhs+i)); - else - fprintf(stderr," %lu[D]",*(node+_FHS+vhs+i)); - } - fprintf(stderr, "\n"); -} - - -#define INFO_MASK 0x80000000 - -void -DEBUG_TREE(node) -P_ node; -{ - W_ size = 0, ptrs = 0, i, vhs = 0; - - /* Don't print cycles */ - if((INFO_PTR(node) & INFO_MASK) != 0) - return; - - size_and_ptrs(node,&size,&ptrs); - vhs = var_hdr_size(node); - - DEBUG_PRINT_NODE(node); - fprintf(stderr, "\n"); - - /* Mark the node -- may be dangerous */ - INFO_PTR(node) |= INFO_MASK; - - for(i = 0; i < ptrs; ++i) - DEBUG_TREE((P_)node[i+vhs+_FHS]); - - /* Unmark the node */ - INFO_PTR(node) &= ~INFO_MASK; -} - - -void -DEBUG_INFO_TABLE(node) -P_ node; -{ - W_ info_ptr = INFO_PTR(node); - char *ip_type = info_hdr_type(info_ptr); - - fprintf(stderr,"%s Info Ptr @0x%lx; Entry: 0x%lx; Size: %lu; Ptrs: %lu\n\n", - ip_type,info_ptr,(W_) ENTRY_CODE(info_ptr),INFO_SIZE(info_ptr),INFO_NoPTRS(info_ptr)); -#if defined(PAR) - fprintf(stderr,"Enter Flush Entry: 0x%lx;\tExit Flush Entry: 0x%lx\n",INFO_FLUSHENT(info_ptr),INFO_FLUSH(info_ptr)); -#endif - -#if defined(PROFILING) - fprintf(stderr,"Cost Centre (???): 0x%lx\n",INFO_CAT(info_ptr)); -#endif - -#if defined(_INFO_COPYING) - fprintf(stderr,"Evacuate Entry: 0x%lx;\tScavenge Entry: 0x%lx\n", - INFO_EVAC_2S(info_ptr),INFO_SCAV_2S(info_ptr)); -#endif - -#if defined(_INFO_COMPACTING) - fprintf(stderr,"Scan Link: 0x%lx;\tScan Move: 0x%lx\n", - (W_) INFO_SCAN_LINK_1S(info_ptr), (W_) INFO_SCAN_MOVE_1S(info_ptr)); - fprintf(stderr,"Mark: 0x%lx;\tMarked: 0x%lx;\t", - (W_) INFO_MARK_1S(info_ptr), (W_) INFO_MARKED_1S(info_ptr)); -#if 0 /* avoid INFO_TYPE */ - if(BASE_INFO_TYPE(info_ptr)==INFO_SPEC_TYPE) - fprintf(stderr,"plus specialised code\n"); - else - fprintf(stderr,"Marking: 0x%lx\n",(W_) INFO_MARKING_1S(info_ptr)); -#endif /* 0 */ -#endif /* _INFO_COMPACTING */ -} - -\end{code} - -The remaining debugging routines are more or less specific for GrAnSim. - -\begin{code} -#if defined(GRAN) && defined(GRAN_CHECK) -void -DEBUG_CURR_THREADQ(verbose) -I_ verbose; -{ - fprintf(stderr,"Thread Queue on proc %d: ", CurrentProc); - DEBUG_THREADQ(ThreadQueueHd, verbose); -} - -void -DEBUG_THREADQ(closure, verbose) -P_ closure; -I_ verbose; -{ - P_ x; - - fprintf(stderr,"Thread Queue: "); - for (x=closure; x!=PrelBase_Z91Z93_closure; x=TSO_LINK(x)) - if (verbose) - DEBUG_TSO(x,0); - else - fprintf(stderr," 0x%x",x); - - if (closure==PrelBase_Z91Z93_closure) - fprintf(stderr,"NIL\n"); - else - fprintf(stderr,"\n"); -} - -/* Check with Threads.lh */ -static char *type_name[] = { "T_MAIN", "T_REQUIRED", "T_ADVISORY", "T_FAIL"}; - -void -DEBUG_TSO(closure,verbose) -P_ closure; -I_ verbose; -{ - - if (closure==PrelBase_Z91Z93_closure) { - fprintf(stderr,"TSO at 0x%x is PrelBase_Z91Z93_closure!\n"); - return; - } - - fprintf(stderr,"TSO at 0x%x has the following contents:\n",closure); - - fprintf(stderr,"> Name: 0x%x",TSO_NAME(closure)); - fprintf(stderr,"\tLink: 0x%x\n",TSO_LINK(closure)); - fprintf(stderr,"> Id: 0x%x",TSO_ID(closure)); -#if defined(GRAN_CHECK) && defined(GRAN) - if (RTSflags.GranFlags.debug & 0x10) - fprintf(stderr,"\tType: %s %s\n", - type_name[TSO_TYPE(closure) & ~FETCH_MASK_TSO], - (TSO_TYPE(closure) & FETCH_MASK_TSO) ? "SLEEPING" : ""); - else - fprintf(stderr,"\tType: %s\n",type_name[TSO_TYPE(closure)]); -#else - fprintf(stderr,"\tType: %s\n",type_name[TSO_TYPE(closure)]); -#endif - fprintf(stderr,"> PC1: 0x%x",TSO_PC1(closure)); - fprintf(stderr,"\tPC2: 0x%x\n",TSO_PC2(closure)); - fprintf(stderr,"> ARG1: 0x%x",TSO_ARG1(closure)); - /* fprintf(stderr,"\tARG2: 0x%x\n",TSO_ARG2(closure)); */ - fprintf(stderr,"> SWITCH: 0x%x\n", TSO_SWITCH(closure)); - - if (verbose) { - fprintf(stderr,"} LOCKED: 0x%x",TSO_LOCKED(closure)); - fprintf(stderr,"\tSPARKNAME: 0x%x\n", TSO_SPARKNAME(closure)); - fprintf(stderr,"} STARTEDAT: 0x%x", TSO_STARTEDAT(closure)); - fprintf(stderr,"\tEXPORTED: 0x%x\n", TSO_EXPORTED(closure)); - fprintf(stderr,"} BASICBLOCKS: 0x%x", TSO_BASICBLOCKS(closure)); - fprintf(stderr,"\tALLOCS: 0x%x\n", TSO_ALLOCS(closure)); - fprintf(stderr,"} EXECTIME: 0x%x", TSO_EXECTIME(closure)); - fprintf(stderr,"\tFETCHTIME: 0x%x\n", TSO_FETCHTIME(closure)); - fprintf(stderr,"} FETCHCOUNT: 0x%x", TSO_FETCHCOUNT(closure)); - fprintf(stderr,"\tBLOCKTIME: 0x%x\n", TSO_BLOCKTIME(closure)); - fprintf(stderr,"} BLOCKCOUNT: 0x%x", TSO_BLOCKCOUNT(closure)); - fprintf(stderr,"\tBLOCKEDAT: 0x%x\n", TSO_BLOCKEDAT(closure)); - fprintf(stderr,"} GLOBALSPARKS: 0x%x", TSO_GLOBALSPARKS(closure)); - fprintf(stderr,"\tLOCALSPARKS: 0x%x\n", TSO_LOCALSPARKS(closure)); - } -} - -void -DEBUG_EVENT(event, verbose) -eventq event; -I_ verbose; -{ - if (verbose) { - print_event(event); - }else{ - fprintf(stderr," 0x%x",event); - } -} - -void -DEBUG_EVENTQ(verbose) -I_ verbose; -{ - eventq x; - - fprintf(stderr,"Eventq (hd @0x%x):\n",EventHd); - for (x=EventHd; x!=NULL; x=EVENT_NEXT(x)) { - DEBUG_EVENT(x,verbose); - } - if (EventHd==NULL) - fprintf(stderr,"NIL\n"); - else - fprintf(stderr,"\n"); -} - -void -DEBUG_SPARK(spark, verbose) -sparkq spark; -I_ verbose; -{ - if (verbose) - print_spark(spark); - else - fprintf(stderr," 0x%x",spark); -} - -void -DEBUG_SPARKQ(spark,verbose) -sparkq spark; -I_ verbose; -{ - sparkq x; - - fprintf(stderr,"Sparkq (hd @0x%x):\n",spark); - for (x=spark; x!=NULL; x=SPARK_NEXT(x)) { - DEBUG_SPARK(x,verbose); - } - if (spark==NULL) - fprintf(stderr,"NIL\n"); - else - fprintf(stderr,"\n"); -} - -void -DEBUG_CURR_SPARKQ(verbose) -I_ verbose; -{ - DEBUG_SPARKQ(SparkQueueHd,verbose); -} - -void -DEBUG_PROC(proc,verbose) -I_ proc; -I_ verbose; -{ - fprintf(stderr,"Status of proc %d at time %d (0x%x): %s\n", - proc,CurrentTime[proc],CurrentTime[proc], - (CurrentProc==proc)?"ACTIVE":"INACTIVE"); - DEBUG_THREADQ(RunnableThreadsHd[proc],verbose & 0x2); - if ( (CurrentProc==proc) ) - DEBUG_TSO(CurrentTSO,1); - - if (EventHd!=NULL) - fprintf(stderr,"Next event (%s) is on proc %d\n", - event_names[EVENT_TYPE(EventHd)],EVENT_PROC(EventHd)); - - if (verbose & 0x1) { - fprintf(stderr,"\nREQUIRED sparks: "); - DEBUG_SPARKQ(PendingSparksHd[proc][REQUIRED_POOL],1); - fprintf(stderr,"\nADVISORY_sparks: "); - DEBUG_SPARKQ(PendingSparksHd[proc][ADVISORY_POOL],1); - } -} - -/* Debug CurrentTSO */ -void -DCT(){ - fprintf(stderr,"Current Proc: %d\n",CurrentProc); - DEBUG_TSO(CurrentTSO,1); -} - -/* Debug Current Processor */ -void -DCP(){ DEBUG_PROC(CurrentProc,2); } - -/* Shorthand for debugging event queue */ -void -DEQ() { DEBUG_EVENTQ(1); } - -/* Shorthand for debugging spark queue */ -void -DSQ() { DEBUG_CURR_SPARKQ(1); } - -/* Shorthand for printing a node */ -void -DN(P_ node) { DEBUG_PRINT_NODE(node); } - -#endif /* GRAN */ - -#endif /* 0 */ -\end{code} -