\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; 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); } #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==Prelude_Z91Z93_closure) { fprintf(stderr,"Prelude_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==Prelude_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!=Prelude_Z91Z93_closure; x=TSO_LINK(x)) if (verbose) G_TSO(x,0); else fprintf(stderr," %#lx",x); if (closure==Prelude_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==Prelude_Z91Z93_closure) { fprintf(stderr,"TSO at %#lx is Prelude_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!=Prelude_Z91Z93_closure; x=TSO_LINK(x)) if (verbose) DEBUG_TSO(x,0); else fprintf(stderr," 0x%x",x); if (closure==Prelude_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==Prelude_Z91Z93_closure) { fprintf(stderr,"TSO at 0x%x is Prelude_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}