+++ /dev/null
-\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 <a.out.h> */
-/* #include <stab.h> */
-/* #include <nlist.h> */
-
-#include <stdio.h>
-
-#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<n>");
- }
-#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<n>");
- }
-#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}
-
projects / ghc-hetmet.git / blobdiff