ghc/runtime/c-as-asm/StgDebug.lc

   1 \section[StgDebug]{Useful debugging routines for the STG machine}
   2
   3 Call these functions directly from a debugger to print Nodes,
   4 registers, stacks, etc.
   5
   6 (An invocation such as
   7
   8   make EXTRA_HC_OPTS='-optl-u -optl_DEBUG_LoadSymbols' ghci
   9
  10  is usually required to get this code included in the object code.)
  11
  12 Nota Bene: in a registerised build, you have to save all the registers
  13 in their appropriate SAVE locations before calling any code that needs
  14 register contents.  (This has to be repeated every time you emerge
  15 from the STG world.)
  16
  17 On a sparc, this can be done by the following gdb script
  18
  19 define saveRegs
  20
  21   set *(&MainRegTable+8) = $l1
  22   set *(&MainRegTable+9) = $l2
  23   set *(&MainRegTable+10) = $l3
  24   set *(&MainRegTable+11) = $l4
  25   set *(&MainRegTable+12) = $l5
  26   set *(&MainRegTable+13) = $l6
  27   set *(&MainRegTable+14) = $l7
  28   set *(&MainRegTable+4) = $f2
  29   set *(&MainRegTable+5) = $f3
  30   set *(&MainRegTable+6) = $f4
  31   set *(&MainRegTable+7) = $f5
  32
  33   set *((double *) &MainRegTable+0) = (double) $f6
  34   set *((double *) &MainRegTable+2) = (double) $f8
  35   set *(&MainRegTable+23) = $l0
  36   set *(&MainRegTable+16) = $i0
  37   set *(&MainRegTable+17) = $i1
  38   set *(&MainRegTable+18) = $i2
  39   set *(&MainRegTable+19) = $i3
  40   set *(&StorageMgrInfo+0) = $i4
  41   set *(&StorageMgrInfo+1) = $i5
  42
  43 end
  44
  45
  46 New code (attempts to interpret heap/stack contents)
  47   DEBUG_LoadSymbols( filename ) Load symbol table from object file
  48                                 (not essential but useful initialisation)
  49   DEBUG_PrintA( depth, size )   Print "depth" entries from A stack
  50   DEBUG_PrintB( depth, size )   ditto
  51   DEBUG_Where( depth, size )    Ambitious attempt to print stacks
  52                                 symbolically.  Result is a little inaccurate
  53                                 but often good enough to do the job.
  54   DEBUG_NODE( closure, size )   Print a closure on the heap
  55   DEBUG_INFO_TABLE(closure)     Print info-table of a closure
  56   DEBUG_SPT( size )             Print the Stable Pointer Table
  57
  58 (Use variable DEBUG_details to set level of detail shown.)
  59
  60 Older code (less fancy ==> more reliable)
  61   DEBUG_ASTACK(lines)           Print "lines" lines of the A Stack
  62   DEBUG_BSTACK(lines)           Print "lines" lines of the B Stack
  63   DEBUG_UPDATES(frames)         Print "frames" update frames
  64   DEBUG_REGS()                  Print register values
  65   DEBUG_FO()                    Print the ForeignObj Lists
  66   DEBUG_TSO(tso)                (CONCURRENT) Print a Thread State Object
  67
  68 Not yet implemented:
  69   DEBUG_STKO(stko)              (CONCURRENT) Print a STacK Object
  70
  71 \begin{code}
  72 #include "rtsdefs.h"
  73 \end{code}
  74
  75 \subsection[StgDebug_Symbol_Tables]{Loading Symbol Tables}
  76
  77 NB: this assumes a.out files - won't work on Alphas.
  78 ToDo: At least add some #ifdefs
  79
  80 \begin{code}
  81 /* #include <a.out.h> */
  82 /* #include <stab.h> */
  83 /* #include <nlist.h> */
  84
  85 #include <stdio.h>
  86
  87 #define FROM_START 0  /* for fseek */
  88
  89 /* Simple lookup table */
  90
  91 /* Current implementation is pretty dumb! */
  92
  93 struct entry {
  94   unsigned value;
  95   int index;
  96   char *name;
  97 };
  98
  99 static int table_uninitialised = 1;
 100 static int max_table_size;
 101 static int table_size;
 102 static struct entry* table;
 103
 104 static void
 105 reset_table( int size )
 106 {
 107   max_table_size = size;
 108   table_size = 0;
 109   table = (struct entry *) stgMallocBytes(size * sizeof(struct entry), "reset_table");
 110 }
 111
 112 static void
 113 prepare_table()
 114 {
 115   /* Could sort it... */
 116 }
 117
 118 static void
 119 insert( unsigned value, int index, char *name )
 120 {
 121   if ( table_size >= max_table_size ) {
 122     fprintf( stderr, "Symbol table overflow\n" );
 123     EXIT( 1 );
 124   }
 125   table[table_size].value = value;
 126   table[table_size].index = index;
 127   table[table_size].name = name;
 128   table_size = table_size + 1;
 129 }
 130
 131 static int
 132 lookup( unsigned value, int *result )
 133 {
 134   int i;
 135   for( i = 0; i < table_size && table[i].value != value; ++i ) {
 136   }
 137   if (i < table_size) {
 138     *result = table[i].index;
 139     return 1;
 140   } else {
 141     return 0;
 142   }
 143 }
 144
 145 static int
 146 lookup_name( char *name, unsigned *result )
 147 {
 148   int i;
 149   for( i = 0; i < table_size && strcmp(name,table[i].name) != 0; ++i ) {
 150   }
 151   if (i < table_size) {
 152     *result = table[i].value;
 153     return 1;
 154   } else {
 155     return 0;
 156   }
 157 }
 158 \end{code}
 159
 160 * Z-escapes:
 161     "std"++xs -> "Zstd"++xs
 162     char_to_c 'Z'  = "ZZ"
 163     char_to_c '&'  = "Za"
 164     char_to_c '|'  = "Zb"
 165     char_to_c ':'  = "Zc"
 166     char_to_c '/'  = "Zd"
 167     char_to_c '='  = "Ze"
 168     char_to_c '>'  = "Zg"
 169     char_to_c '#'  = "Zh"
 170     char_to_c '<'  = "Zl"
 171     char_to_c '-'  = "Zm"
 172     char_to_c '!'  = "Zn"
 173     char_to_c '.'  = "Zo"
 174     char_to_c '+'  = "Zp"
 175     char_to_c '\'' = "Zq"
 176     char_to_c '*'  = "Zt"
 177     char_to_c '_'  = "Zu"
 178     char_to_c c    = "Z" ++ show (ord c)
 179
 180 \begin{code}
 181 static char unZcode( char ch )
 182 {
 183   switch (ch) {
 184   case 'Z' :
 185   case '\0' :
 186     return ('Z');
 187   case 'a' :
 188     return ('&');
 189   case 'b' :
 190     return ('|');
 191   case 'c' :
 192     return (':');
 193   case 'd' :
 194     return ('/');
 195   case 'e' :
 196     return ('=');
 197   case 'g' :
 198     return ('>');
 199   case 'h' :
 200     return ('#');
 201   case 'l' :
 202     return ('<');
 203   case 'm' :
 204     return ('-');
 205   case 'n' :
 206     return ('!');
 207   case 'o' :
 208     return ('.');
 209   case 'p' :
 210     return ('+');
 211   case 'q' :
 212     return ('\'');
 213   case 't' :
 214     return ('*');
 215   case 'u' :
 216     return ('_');
 217   default :
 218     return (ch);
 219   }
 220 }
 221
 222 /* Precondition: out big enough to handle output (about twice length of in) */
 223 static void enZcode( char *in, char *out )
 224 {
 225   int i, j;
 226
 227   j = 0;
 228   out[ j++ ] = '_';
 229   for( i = 0; in[i] != '\0'; ++i ) {
 230     switch (in[i]) {
 231     case 'Z'  :
 232       out[j++] = 'Z';
 233       out[j++] = 'Z';
 234       break;
 235     case '&'  :
 236       out[j++] = 'Z';
 237       out[j++] = 'a';
 238       break;
 239     case '|'  :
 240       out[j++] = 'Z';
 241       out[j++] = 'b';
 242       break;
 243     case ':'  :
 244       out[j++] = 'Z';
 245       out[j++] = 'c';
 246       break;
 247     case '/'  :
 248       out[j++] = 'Z';
 249       out[j++] = 'd';
 250       break;
 251     case '='  :
 252       out[j++] = 'Z';
 253       out[j++] = 'e';
 254       break;
 255     case '>'  :
 256       out[j++] = 'Z';
 257       out[j++] = 'g';
 258       break;
 259     case '#'  :
 260       out[j++] = 'Z';
 261       out[j++] = 'h';
 262       break;
 263     case '<'  :
 264       out[j++] = 'Z';
 265       out[j++] = 'l';
 266       break;
 267     case '-'  :
 268       out[j++] = 'Z';
 269       out[j++] = 'm';
 270       break;
 271     case '!'  :
 272       out[j++] = 'Z';
 273       out[j++] = 'n';
 274       break;
 275     case '.'  :
 276       out[j++] = 'Z';
 277       out[j++] = 'o';
 278       break;
 279     case '+'  :
 280       out[j++] = 'Z';
 281       out[j++] = 'p';
 282       break;
 283     case '\'' :
 284       out[j++] = 'Z';
 285       out[j++] = 'q';
 286       break;
 287     case '*'  :
 288       out[j++] = 'Z';
 289       out[j++] = 't';
 290       break;
 291     case '_'  :
 292       out[j++] = 'Z';
 293       out[j++] = 'u';
 294       break;
 295     default :
 296       out[j++] = in[i];
 297       break;
 298     }
 299   }
 300   out[j] = '\0';
 301 }
 302 \end{code}
 303
 304 \begin{code}
 305 static int lookupForName( P_ addr, char **result )
 306 {
 307   int i;
 308   for( i = 0; i < table_size && table[i].value != (unsigned) addr; ++i ) {
 309   }
 310   if (i < table_size) {
 311     *result = table[i].name;
 312     return 1;
 313   } else {
 314     return 0;
 315   }
 316 }
 317
 318 static void printZcoded( char *raw )
 319 {
 320   int j;
 321
 322   /* start at 1 to skip the leading "_" */
 323   for( j = 1; raw[j] != '\0'; /* explicit */) {
 324     if (raw[j] == 'Z') {
 325       putchar(unZcode(raw[j+1]));
 326       j = j + 2;
 327     } else {
 328       putchar(raw[j]);
 329       j = j + 1;
 330     }
 331   }
 332 }
 333
 334 static void printName( P_ addr )
 335 {
 336   char *raw;
 337
 338   if (lookupForName( addr, &raw )) {
 339     printZcoded(raw);
 340   } else {
 341     printf("0x%x", addr);
 342   }
 343 }
 344
 345 #if 0           /* OMIT load-symbol stuff cos it doesn't work on Alphas */
 346
 347 /* Fairly ad-hoc piece of code that seems to filter out a lot of
 348    rubbish like the obj-splitting symbols */
 349
 350 static int
 351 isReal( unsigned char type, char *name )
 352 {
 353   int external = type & N_EXT;
 354   int tp = type & N_TYPE;
 355
 356   if (tp == N_TEXT || tp == N_DATA) {
 357     return( name[0] == '_' && name[1] != '_' );
 358   } else {
 359     return( 0 );
 360   }
 361 }
 362
 363 void
 364 DEBUG_LoadSymbols( char *name )
 365 {
 366   FILE *binary;
 367
 368   struct exec header;
 369
 370   long sym_offset;
 371   long sym_size;
 372   long num_syms;
 373   long num_real_syms;
 374   struct nlist *symbol_table;
 375
 376   long str_offset;
 377   long str_size; /* assumed 4 bytes.... */
 378   char *string_table;
 379
 380   long i;
 381
 382   binary = fopen( name, "r" );
 383   if (binary == NULL) {
 384     fprintf( stderr, "Can't open symbol table file \"%s\".\n", name );
 385   }
 386
 387
 388   if (fread( &header,  sizeof( struct exec ), 1, binary ) != 1) {
 389     fprintf( stderr, "Can't read symbol table header.\n" );
 390     EXIT( 1 );
 391   }
 392   if ( N_BADMAG( header ) ) {
 393     fprintf( stderr, "Bad magic number in symbol table header.\n" );
 394     EXIT( 1 );
 395   }
 396
 397
 398
 399   sym_offset = N_SYMOFF( header );
 400   sym_size = header.a_syms;
 401   num_syms = sym_size / sizeof( struct nlist );
 402   fseek( binary, sym_offset, FROM_START );
 403
 404   symbol_table = (struct nlist *) stgMallocBytes(sym_size, "symbol table (DEBUG_LoadSymbols)");
 405   printf("Reading %d symbols\n", num_syms);
 406
 407   if (fread( symbol_table, sym_size, 1, binary ) != 1) {
 408     fprintf( stderr, "Can't read symbol table\n");
 409     EXIT( 1 );
 410   }
 411
 412   str_offset = N_STROFF( header );
 413   fseek( binary, str_offset, FROM_START );
 414
 415   if (fread( &str_size, 4, 1, binary ) != 1) {
 416     fprintf( stderr, "Can't read string table size\n");
 417     EXIT( 1 );
 418   }
 419
 420   /* apparently the size of the string table includes the 4 bytes that
 421    * store the size...
 422    */
 423   string_table = (char *) stgMallocBytes(str_size, "string table (DEBUG_LoadSymbols)");
 424
 425   if (fread( string_table+4, str_size-4, 1, binary ) != 1) {
 426     fprintf( stderr, "Can't read string table\n");
 427     EXIT( 1 );
 428   }
 429
 430   num_real_syms = 0;
 431   for( i = 0; i != num_syms; ++i ) {
 432     unsigned char type = symbol_table[i].n_type;
 433     unsigned value = symbol_table[i].n_value;
 434     char *str = &string_table[symbol_table[i].n_un.n_strx];
 435
 436     if ( isReal( type, str ) ) {
 437       num_real_syms = num_real_syms + 1;
 438     }
 439   }
 440
 441   printf("Of which %d are real symbols\n", num_real_syms);
 442
 443 /*
 444   for( i = 0; i != num_syms; ++i ) {
 445     unsigned char type = symbol_table[i].n_type;
 446     unsigned value = symbol_table[i].n_value;
 447     char *str = &string_table[symbol_table[i].n_un.n_strx];
 448
 449     if ( isReal(type, str) ) {
 450       printf("Symbol %d. Extern? %c. Type: %c. Value: 0x%x. Name: %s\n",
 451              i,
 452              (external ? 'y' : 'n'),
 453              type,
 454              value,
 455              str
 456              );
 457     }
 458   }
 459 */
 460
 461   reset_table( num_real_syms );
 462
 463   for( i = 0; i != num_syms; ++i ) {
 464     unsigned char type = symbol_table[i].n_type;
 465     unsigned value = symbol_table[i].n_value;
 466     char *str = &string_table[symbol_table[i].n_un.n_strx];
 467
 468     if ( isReal( type, str ) ) {
 469       insert( value, i, str );
 470     }
 471
 472   }
 473
 474   prepare_table();
 475 }
 476 #endif /* 0 */
 477 \end{code}
 478
 479 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 480 %
 481 \subsection[StgDebug_PrettyPrinting]{Pretty printing internal structures}
 482 %
 483 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 484
 485 \begin{code}
 486 #include "../storage/SMinternal.h"
 487
 488 #ifdef GCap
 489 #define HP_BOT appelInfo.oldbase
 490 #elif GCdu
 491 #define HP_BOT dualmodeInfo.modeinfo[dualmodeInfo.mode].base
 492 #elif GC2s
 493 #define HP_BOT semispaceInfo[semispace].base
 494 #elif GC1s
 495 #define HP_BOT compactingInfo.base
 496 #else
 497   unknown garbage collector - help, help!
 498 #endif
 499 \end{code}
 500
 501 \begin{code}
 502 /* range: 0..NUM_LEVELS_OF_DETAIL-1.  Level of machine-related detail shown */
 503 #define NUM_LEVELS_OF_DETAIL 3
 504 static int DEBUG_details = 2;
 505 \end{code}
 506
 507 \begin{code}
 508 /* Determine the size and number of pointers for this kind of closure */
 509 static void
 510 getClosureShape( P_ node, int *vhs, int *size, int *ptrs, char **type )
 511 {
 512   /* The result is used for printing out closure contents.  If the
 513      info-table is mince, we'd better conservatively guess there's
 514      nothing in the closure to avoid chasing non-ptrs. */
 515   *vhs = 0;
 516   *size = 0;
 517   *ptrs = 0;
 518   *type = "*unknown info type*";
 519
 520     /* ToDo: if in garbage collector, consider subtracting some weird offset which some GCs add to infoptr */
 521
 522   /* The order here precisely reflects that in SMInfoTables.lh to make
 523      it easier to check that this list is complete. */
 524   switch(INFO_TYPE(INFO_PTR(node)))
 525     {
 526       case INFO_SPEC_U_TYPE:
 527         *vhs = 0; /* by decree */
 528         *size = SPEC_CLOSURE_SIZE(node);
 529         *ptrs = SPEC_CLOSURE_NoPTRS(node);
 530         *type = "SPECU";
 531         break;
 532       case INFO_SPEC_N_TYPE:
 533         *vhs = 0; /* by decree */
 534         *size = SPEC_CLOSURE_SIZE(node);
 535         *ptrs = SPEC_CLOSURE_NoPTRS(node);
 536         *type = "SPECN";
 537         break;
 538
 539       case INFO_GEN_U_TYPE:
 540         *vhs = GEN_VHS;
 541         *size = GEN_CLOSURE_SIZE(node);
 542         *ptrs = GEN_CLOSURE_NoPTRS(node);
 543         *type = "GENU";
 544         break;
 545       case INFO_GEN_N_TYPE:
 546         *vhs = GEN_VHS;
 547         *size = GEN_CLOSURE_SIZE(node);
 548         *ptrs = GEN_CLOSURE_NoPTRS(node);
 549         *type = "GENN";
 550         break;
 551
 552       case INFO_DYN_TYPE:
 553         *vhs = DYN_VHS;
 554         *size = DYN_CLOSURE_SIZE(node);
 555         *ptrs = DYN_CLOSURE_NoPTRS(node);
 556         *type = "DYN";
 557         break;
 558
 559       case INFO_TUPLE_TYPE:
 560         *vhs = TUPLE_VHS;
 561         *size = TUPLE_CLOSURE_SIZE(node);
 562         *ptrs = TUPLE_CLOSURE_NoPTRS(node);
 563         *type = "TUPLE";
 564         break;
 565
 566       case INFO_DATA_TYPE:
 567         *vhs = DATA_VHS;
 568         *size = DATA_CLOSURE_SIZE(node);
 569         *ptrs = DATA_CLOSURE_NoPTRS(node);
 570         *type = "DATA";
 571         break;
 572
 573       case INFO_MUTUPLE_TYPE:
 574         *vhs = MUTUPLE_VHS;
 575         *size = MUTUPLE_CLOSURE_SIZE(node);
 576         *ptrs = MUTUPLE_CLOSURE_NoPTRS(node);
 577         *type = "MUTUPLE";
 578         break;
 579
 580       case INFO_IMMUTUPLE_TYPE:
 581         *vhs = MUTUPLE_VHS;
 582         *size = MUTUPLE_CLOSURE_SIZE(node);
 583         *ptrs = MUTUPLE_CLOSURE_NoPTRS(node);
 584         *type = "IMMUTUPLE";
 585         break;
 586
 587       case INFO_STATIC_TYPE:
 588         *vhs = STATIC_VHS;
 589         *size = INFO_SIZE(INFO_PTR(node));
 590         *ptrs = INFO_NoPTRS(INFO_PTR(node));
 591         *type = "STATIC";
 592         break;
 593
 594       case INFO_CONST_TYPE:
 595         *vhs = 0;
 596         *size = 0;
 597         *ptrs = 0;
 598         *type = "CONST";
 599         break;
 600
 601       case INFO_CHARLIKE_TYPE:
 602         *vhs = 0;
 603         *size = 1;
 604         *ptrs = 0;
 605         *type = "CHAR";
 606         break;
 607
 608       case INFO_INTLIKE_TYPE:
 609         *vhs = 0;
 610         *size = 1;
 611         *ptrs = 0;
 612         *type = "INT";
 613         break;
 614
 615       case INFO_BH_TYPE:
 616         *vhs = 0;
 617         *size = INFO_SIZE(INFO_PTR(node));
 618         *ptrs = 0;
 619         *type = "BHOLE";
 620         break;
 621
 622 /* most of the following are plausible guesses (particularily VHSs) ADR */
 623       case INFO_BQ_TYPE:
 624 #ifdef CONCURRENT
 625         *vhs = 0;
 626         *size = BQ_CLOSURE_SIZE(node);
 627         *ptrs = BQ_CLOSURE_NoPTRS(node);
 628         *type = "BQ";
 629 #else
 630         printf("Panic: found BQ Infotable in non-threaded system.\n");
 631 #endif
 632         break;
 633
 634       case INFO_IND_TYPE:
 635         *vhs = 0;
 636         *size = IND_CLOSURE_SIZE(node);
 637         *ptrs = IND_CLOSURE_NoPTRS(node);
 638         *type = "IND";
 639         break;
 640
 641       case INFO_CAF_TYPE:
 642         *vhs = 0; /* ?? ADR */
 643         *size = INFO_SIZE(INFO_PTR(node));
 644         *ptrs = 0;
 645         *type = "CAF";
 646         break;
 647
 648       case INFO_FETCHME_TYPE:
 649 #ifdef PAR
 650         *vhs = FETCHME_VHS;
 651         *size = FETCHME_CLOSURE_SIZE(node);
 652         *ptrs = FETCHME_CLOSURE_NoPTRS(node);
 653         *type = "FETCHME";
 654 #else
 655         printf("Panic: found FETCHME Infotable in sequential system.\n");
 656 #endif
 657         break;
 658
 659       case INFO_FMBQ_TYPE:
 660 #ifdef PAR
 661         *vhs = FMBQ_VHS;
 662         *size = FMBQ_CLOSURE_SIZE(node);
 663         *ptrs = FMBQ_CLOSURE_NoPTRS(node);
 664         *type = "FMBQ";
 665 #else
 666         printf("Panic: found FMBQ Infotable in sequential system.\n");
 667 #endif
 668         break;
 669
 670       case INFO_BF_TYPE:
 671 #ifdef PAR
 672         *vhs = 0;
 673         *size = 0;
 674         *ptrs = 0;
 675         *type = "BlockedFetch";
 676 #else
 677         printf("Panic: found BlockedFetch Infotable in sequential system.\n");
 678 #endif
 679         break;
 680
 681       case INFO_TSO_TYPE:
 682         /* Conservative underestimate: this will contain a regtable
 683            which comes nowhere near fitting the standard "p ptrs; s-p
 684            non-ptrs" format. ADR */
 685 #ifdef CONCURRENT
 686         *vhs = TSO_VHS;
 687         *size = 0;
 688         *ptrs = 0;
 689         *type = "TSO";
 690 #else
 691         printf("Panic: found TSO Infotable in non-threaded system.\n");
 692 #endif
 693         break;
 694
 695       case INFO_STKO_TYPE:
 696         /* Conservative underestimate: this will contain stuff
 697            which comes nowhere near fitting the standard "p ptrs; s-p
 698            non-ptrs" format. JSM */
 699 #ifdef CONCURRENT
 700         *vhs = STKO_VHS;
 701         *size = 0;
 702         *ptrs = 0;
 703         *type = "STKO";
 704 #else
 705         printf("Panic: found STKO Infotable in non-threaded system.\n");
 706 #endif
 707         break;
 708
 709       /* There are no others in SMInfoTables.lh 11/5/94 ADR*/
 710       default:
 711         printf("Invalid/unknown info type %ld\n", INFO_TYPE(INFO_PTR(node)));
 712         break;
 713     }
 714 }
 715
 716 static void
 717 printWord( W_ word )
 718 {
 719   printf("0x%08lx", word);
 720 }
 721
 722 static void
 723 printAddress( P_ address )
 724 {
 725 # ifdef CONCURRENT
 726   PP_ SpA  = STKO_SpA(SAVE_StkO);
 727   PP_ SuA  = STKO_SuA(SAVE_StkO);
 728   P_  SpB  = STKO_SpB(SAVE_StkO);
 729   P_  SuB  = STKO_SuB(SAVE_StkO);
 730   PP_ botA = 0; /* junk */
 731   P_ botB  = 0;
 732 # define CAN_SEE_STK_BOTTOMS 0
 733 # else
 734   PP_ SpA  = SAVE_SpA;
 735   PP_ SuA  = SAVE_SuA;
 736   P_  SpB  = SAVE_SpB;
 737   P_  SuB  = SAVE_SuB;
 738   PP_ botA = stackInfo.botA;
 739   P_ botB  = stackInfo.botB;
 740 # define CAN_SEE_STK_BOTTOMS 1
 741 # endif
 742   P_  Hp   = SAVE_Hp;
 743
 744   P_ HpBot = HP_BOT;
 745
 746   char *name;
 747
 748   /* ToDo: check if it's in text or data segment. */
 749
 750   /* The @-1@s in stack comparisons are because we sometimes use the
 751      address of just below the stack... */
 752
 753 #if 0
 754   if (lookupForName( address, &name )) {
 755     printZcoded( name );
 756   }
 757   else
 758 #endif
 759   {
 760     if (DEBUG_details > 1) {
 761       printWord( (W_) address );
 762       printf(" : ");
 763     }
 764     if (HpBot <= address && address < Hp) {
 765       printf("Hp[%d]", address - HpBot);
 766     } else if ( CAN_SEE_STK_BOTTOMS
 767              && SUBTRACT_A_STK((PP_)address, botA) >= -1
 768              && SUBTRACT_A_STK(SpA, (PP_)address) >= 0) {
 769       printf("SpA[%d]", SUBTRACT_A_STK((PP_)address, botA));
 770
 771     } else if ( CAN_SEE_STK_BOTTOMS
 772              && SUBTRACT_B_STK(address, botB) >= -1
 773              && SUBTRACT_B_STK(SpB, address) >= 0) {
 774       /* ToDo: check if it's an update frame */
 775       printf("SpB[%d]", SUBTRACT_B_STK(address, botB));
 776
 777     } else {
 778       printWord( (W_) address );
 779     }
 780   }
 781 }
 782
 783 static void
 784 printIndentation( int indentation )
 785 {
 786   int i;
 787   for (i = 0; i < indentation; ++i) { printf("  "); }
 788 }
 789
 790 /* The weight parameter is used to (eventually) break cycles */
 791 static void
 792 printStandardShapeClosure(
 793       int indentation,
 794       int weight,
 795       P_ closure, int vhs, int size, int noPtrs
 796 )
 797 {
 798 #ifdef CONCURRENT
 799   PP_ SpA  = STKO_SpA(SAVE_StkO);
 800   PP_ SuA  = STKO_SuA(SAVE_StkO);
 801   P_  SpB  = STKO_SpB(SAVE_StkO);
 802   P_  SuB  = STKO_SuB(SAVE_StkO);
 803 #else
 804   PP_ SpA  = SAVE_SpA;
 805   PP_ SuA  = SAVE_SuA;
 806   P_  SpB  = SAVE_SpB;
 807   P_  SuB  = SAVE_SuB;
 808 #endif
 809   P_ Hp    = SAVE_Hp;
 810
 811   void printClosure PROTO( (P_, int, int) );
 812   int numValues = size - vhs;
 813   P_ HpBot = HP_BOT;
 814
 815   if (DEBUG_details > 1) {
 816     printAddress( closure );
 817     printf(": ");
 818   }
 819   printName((P_)INFO_PTR(closure));
 820
 821   if ( numValues > 0 ) {
 822     int newWeight = weight-1 ;
 823         /* I've tried dividing the weight by size to share it out amongst
 824            sub-closures - but that didn't work too well. */
 825
 826     if (newWeight > 0) {
 827       int i=0;
 828       printf("(\n");
 829       while (i < numValues) {
 830         P_ data = (P_) closure[_FHS + vhs + i];
 831
 832         printIndentation(indentation+1);
 833         if (i < noPtrs) {
 834           printClosure( data, indentation+1, newWeight);
 835         } else {
 836           printAddress( data );
 837         }
 838         i = i + 1;
 839         if (i < numValues) printf(",\n");
 840       }
 841       printf(")");
 842     } else {
 843       int i;
 844       printf("(_");
 845       for( i = 1; i < size; ++i ) {
 846         printf(",_");
 847       }
 848       printf(")");
 849     }
 850   }
 851 }
 852
 853 /* Should be static but has to be extern to allow mutual recursion */
 854 void
 855 printClosure( P_ closure, int indentation, int weight )
 856 {
 857   int vhs, size, ptrs;
 858   char *type;
 859
 860   /* I'd love to put a test here that this actually _is_ a closure -
 861      but testing that it is in the heap is overly strong. */
 862
 863   getClosureShape(closure, &vhs, &size, &ptrs, &type);
 864
 865   /* The order here precisely reflects that in SMInfoTables.lh to make
 866      it easier to check that this list is complete. */
 867   switch(INFO_TYPE(INFO_PTR(closure))) {
 868   case INFO_SPEC_U_TYPE:
 869   case INFO_SPEC_N_TYPE:
 870   case INFO_GEN_U_TYPE:
 871   case INFO_GEN_N_TYPE:
 872   case INFO_DYN_TYPE:
 873   case INFO_TUPLE_TYPE:
 874   case INFO_DATA_TYPE:
 875   case INFO_MUTUPLE_TYPE:
 876   case INFO_IMMUTUPLE_TYPE:
 877     printStandardShapeClosure(indentation, weight, closure,
 878                               vhs, size, ptrs);
 879     break;
 880
 881   case INFO_STATIC_TYPE:
 882     /* If the STATIC contains Floats or Doubles, we can't print it. */
 883     /* And we can't always rely on the size/ptrs info either */
 884     printAddress( closure );
 885     printf(" STATIC");
 886     break;
 887
 888   case INFO_CONST_TYPE:
 889     if (DEBUG_details > 1) {
 890       printAddress( closure );
 891       printf(": ");
 892     }
 893     printName((P_)INFO_PTR(closure));
 894     break;
 895
 896   case INFO_CHARLIKE_TYPE:
 897     /* ToDo: check for non-printable characters */
 898     if (DEBUG_details > 1) printf("CHARLIKE ");
 899     printf("\'%c\'", (unsigned char) CHARLIKE_VALUE(closure));
 900     break;
 901
 902   case INFO_INTLIKE_TYPE:
 903     if (DEBUG_details > 1) printf("INTLIKE ");
 904     printf("%ld",INTLIKE_VALUE(closure));
 905     break;
 906
 907   case INFO_BH_TYPE:
 908     /* Is there anything to say here> */
 909     if (DEBUG_details > 1) {
 910       printAddress( closure );
 911       printf(": ");
 912     }
 913     printName((P_)INFO_PTR(closure));
 914     break;
 915
 916 /* most of the following are just plausible guesses (particularily VHSs) ADR */
 917
 918   case INFO_BQ_TYPE:
 919 #ifdef CONCURRENT
 920     printStandardShapeClosure(indentation, weight, closure,
 921                               vhs, size, ptrs);
 922 #else
 923     printf("Panic: found BQ Infotable in non-threaded system.\n");
 924 #endif
 925     break;
 926
 927   case INFO_IND_TYPE:
 928     if (DEBUG_details > 0) {
 929       printAddress( closure );
 930       printf(" IND: ");
 931     }
 932     printClosure( (P_) IND_CLOSURE_PTR(closure), indentation, weight );
 933     break;
 934
 935   case INFO_CAF_TYPE:
 936     if (DEBUG_details > 0) {
 937       printAddress( closure );
 938       printf(" CAF: ");
 939     }
 940     printClosure( (P_) IND_CLOSURE_PTR(closure), indentation, weight );
 941     break;
 942
 943   case INFO_FETCHME_TYPE:
 944 #ifdef PAR
 945     printStandardShapeClosure(indentation, weight, closure,
 946                               vhs, size, ptrs);
 947 #else
 948     printf("Panic: found FETCHME Infotable in sequential system.\n");
 949 #endif
 950     break;
 951
 952   case INFO_FMBQ_TYPE:
 953 #ifdef PAR
 954     printStandardShapeClosure(indentation, weight, closure,
 955                               vhs, size, ptrs);
 956 #else
 957     printf("Panic: found FMBQ Infotable in sequential system.\n");
 958 #endif
 959     break;
 960
 961   case INFO_BF_TYPE:
 962 #ifdef PAR
 963     printStandardShapeClosure(indentation, weight, closure,
 964                               vhs, size, ptrs);
 965 #else
 966     printf("Panic: found BlockedFetch Infotable in sequential system.\n");
 967 #endif
 968     break;
 969
 970   case INFO_TSO_TYPE:
 971 #ifdef CONCURRENT
 972     /* A TSO contains a regtable... */
 973     printAddress( closure );
 974     printf(" TSO: ...");
 975 #else
 976     printf("Panic: found TSO Infotable in non-threaded system.\n");
 977 #endif
 978     break;
 979
 980     case INFO_STKO_TYPE:
 981 #ifdef CONCURRENT
 982     /* A STKO contains parts of the A and B stacks... */
 983     printAddress( closure );
 984     printf(" STKO: ...");
 985 #else
 986     printf("Panic: found STKO Infotable in non-threaded system.\n");
 987 #endif
 988     break;
 989
 990   /* There are no others in SMInfoTables.lh 11/5/94 ADR*/
 991   default:
 992     printf("Invalid/unknown info type %ld\n", INFO_TYPE(INFO_PTR(closure)));
 993     break;
 994   }
 995 }
 996
 997 void
 998 DEBUG_NODE( P_ closure, int size )
 999 {
1000   printClosure( closure, 0, size );
1001   printf("\n");
1002 }
1003 \end{code}
1004
1005 Now some stuff for printing stacks - almost certainly doesn't work
1006 under threads which keep the stack on the heap.
1007
1008 \begin{code}
1009 #ifndef CONCURRENT
1010
1011 static int
1012 minimum(int a, int b)
1013 {
1014   if (a < b) {
1015     return a;
1016   } else {
1017     return b;
1018   }
1019 }
1020
1021 void
1022 DEBUG_PrintA( int depth, int weight )
1023 {
1024   PP_ SpA  = SAVE_SpA;
1025   PP_ SuA  = SAVE_SuA;
1026
1027   int i;
1028   I_ size = minimum(depth, SUBTRACT_A_STK(SpA, stackInfo.botA)+1);
1029
1030   printf("Dump of the Address Stack (SpA = 0x%lx, SuA = 0x%lx)\n", SpA, SuA);
1031
1032   for( i = 0; i < size; ++i ) {
1033     printIndentation(1);
1034     printf("SpA[%d] (0x%08lx):", i, SpA + AREL(i));
1035     printClosure((P_)*(SpA + AREL(i)), 2, weight);
1036     printf("\n");
1037   }
1038 }
1039
1040 void
1041 DEBUG_PrintB( int depth, int weight )
1042 {
1043   PP_ SpA  = SAVE_SpA;
1044   P_  SpB  = SAVE_SpB;
1045   P_  SuB  = SAVE_SuB;
1046
1047   I_ i;
1048   I_ size = minimum(depth, SUBTRACT_B_STK(SpB, stackInfo.botB)+1);
1049
1050   P_ updateFramePtr;
1051   I_ update_count;
1052
1053   printf("Dump of the Value Stack (SpB = 0x%lx, SuB = 0x%lx)\n", SpB, SuB);
1054
1055   updateFramePtr = SuB;
1056   update_count = 0;
1057   i = 0;
1058   while (i < size) {
1059     if (updateFramePtr == SpB + BREL(i)) {
1060
1061       printIndentation(1);
1062       printf("SpB[%ld] (0x%08lx): UpdateFrame[%d](",
1063              i,
1064              updateFramePtr,
1065              update_count
1066              );
1067       printName( (P_) *(SpB + BREL(i)) );
1068       printf(", UF[%d] (= SpB[%ld]), SpA[%ld], ",
1069              update_count+1,
1070              SUBTRACT_B_STK(SpB, GRAB_SuB(updateFramePtr)),
1071              SUBTRACT_A_STK(SpA, GRAB_SuA(updateFramePtr))
1072              );
1073       printAddress( GRAB_UPDATEE(updateFramePtr) );
1074       printf(")\n");
1075
1076       printIndentation(2);
1077       printClosure( GRAB_UPDATEE(updateFramePtr), 3, weight );
1078       printf("\n");
1079
1080       updateFramePtr = GRAB_SuB(updateFramePtr);
1081       update_count = update_count + 1;
1082
1083       /* ToDo: GhcConstants.lh reveals that there are two other sizes possible */
1084       i = i + STD_UF_SIZE;
1085     } else {
1086       printIndentation(1);
1087       printf("SpB[%ld] (0x%08lx): ", i, SpB + BREL(i) );
1088       printName((P_) *(SpB + BREL(i)) );
1089       printf("\n");
1090       i = i + 1;
1091     }
1092   }
1093 }
1094
1095 #else /* CONCURRENT */
1096
1097 static int
1098 minimum(int a, int b)
1099 {
1100   if (a < b) {
1101     return a;
1102   } else {
1103     return b;
1104   }
1105 }
1106
1107 void
1108 DEBUG_PrintA( int depth, int weight )
1109 {
1110   P_ stko = SAVE_StkO;
1111   PP_ SpA  = STKO_SpA(stko);
1112   PP_ SuA  = STKO_SuA(stko);
1113   P_  SpB  = STKO_SpB(stko);
1114   P_  SuB  = STKO_SuB(stko);
1115   P_ Hp    = SAVE_Hp;
1116
1117   int i;
1118   I_ size = minimum(depth, SUBTRACT_A_STK(SpA, STKO_ASTK_BOT(stko))+1);
1119
1120   printf("Dump of the Address Stack (SpA = 0x%x, SuA = 0x%x)\n", SpA, SuA);
1121
1122   for( i = 0; i < size; ++i ) {
1123     printIndentation(1);
1124     printf("SpA[%ld] (0x%08lx):", i, SpA + AREL(i));
1125     printClosure((P_)*(SpA + AREL(i)), 2, weight);
1126     printf("\n");
1127   }
1128 }
1129
1130 void
1131 DEBUG_PrintB( int depth, int weight )
1132 {
1133   P_ stko = SAVE_StkO;
1134   PP_ SpA  = STKO_SpA(stko);
1135   PP_ SuA  = STKO_SuA(stko);
1136   P_  SpB  = STKO_SpB(stko);
1137   P_  SuB  = STKO_SuB(stko);
1138   P_ Hp    = SAVE_Hp;
1139
1140   I_ i;
1141   I_ size = minimum(depth, SUBTRACT_B_STK(SpB, STKO_BSTK_BOT(stko))+1);
1142
1143   P_ updateFramePtr;
1144   I_ update_count;
1145
1146   printf("Dump of the Value Stack (SpB = 0x%x, SuB = 0x%x)\n", SpB, SuB);
1147
1148   updateFramePtr = SuB;
1149   update_count = 0;
1150   i = 0;
1151   while (i < size) {
1152     if (updateFramePtr == SpB + BREL(i)) {
1153
1154       printIndentation(1);
1155       printf("SpB[%ld] (0x%08lx): UpdateFrame[%d](",
1156              i,
1157              updateFramePtr,
1158              update_count
1159              );
1160       printName( (P_) *(SpB + BREL(i)) );
1161       printf(", UF[%d] (= SpB[%ld]), SpA[%ld], ",
1162              update_count+1,
1163              SUBTRACT_B_STK(SpB, GRAB_SuB(updateFramePtr)),
1164              SUBTRACT_A_STK(SpA, GRAB_SuA(updateFramePtr))
1165              );
1166       printAddress( GRAB_UPDATEE(updateFramePtr) );
1167       printf(")\n");
1168
1169       printIndentation(2);
1170       printClosure( GRAB_UPDATEE(updateFramePtr), 3, weight );
1171       printf("\n");
1172
1173       updateFramePtr = GRAB_SuB(updateFramePtr);
1174       update_count = update_count + 1;
1175
1176       /* ToDo: GhcConstants.lh reveals that there are two other sizes possible */
1177       i = i + STD_UF_SIZE;
1178     } else {
1179       printIndentation(1);
1180       printf("SpB[%ld] (0x%08lx): ", i, SpB + BREL(i) );
1181       printName((P_) *(SpB + BREL(i)) );
1182       printf("\n");
1183       i = i + 1;
1184     }
1185   }
1186 }
1187
1188 #endif /* not CONCURRENT */
1189 \end{code}
1190
1191 ToDo:
1192
1193    All the following code incorrectly assumes that the only return
1194    addresses are those associated with update frames.
1195
1196    To do a proper job of printing the environment we need to:
1197
1198    1) Recognise vectored and non-vectored returns on the B stack.
1199
1200    2) Know where the local variables are in the A and B stacks for
1201       each return situation.
1202
1203    Until then, we'll just need to look suspiciously at the
1204    "environment" being printed out.
1205
1206    ADR
1207
1208 \begin{code}
1209 /* How many real stacks are there on SpA and SpB? */
1210 /* Say what?? (Will and Phil, 96/01) */
1211 #ifndef CONCURRENT
1212 static int
1213 numStacks( )
1214 {
1215 #ifdef CONCURRENT
1216   PP_ SpA  = STKO_SpA(SAVE_StkO);
1217   PP_ SuA  = STKO_SuA(SAVE_StkO);
1218   P_  SpB  = STKO_SpB(SAVE_StkO);
1219   P_  SuB  = STKO_SuB(SAVE_StkO);
1220 #else
1221   P_  SuB  = SAVE_SuB;
1222 #endif
1223
1224   int depth = 1; /* There's always at least one stack */
1225
1226   while (SUBTRACT_B_STK(SuB, stackInfo.botB) >= 0) {
1227     SuB = GRAB_SuB( SuB );
1228     depth = depth + 1;
1229   }
1230   return depth;
1231 }
1232 #endif /* !CONCURRENT */
1233
1234 static void
1235 printLocalAStack( int depth, int indentation, int weight, PP_ SpA, int size )
1236 {
1237   int i;
1238
1239   ASSERT( size >= 0 );
1240
1241   for( i = size-1; i >= 0; --i ) {
1242     printIndentation( indentation );
1243     printf("A[%ld][%d]", depth, i);
1244     if (DEBUG_details > 1) printf(" (0x%08lx) ", SpA + AREL(i) );
1245     printf("=");
1246     printClosure( *(SpA + AREL(i)), indentation+2, weight );
1247     printf("\n");
1248   }
1249 }
1250
1251 static void
1252 printLocalBStack( int depth, int indentation, int weight, P_ SpB, int size )
1253 {
1254   int i;
1255
1256   ASSERT( size >= 0 );
1257
1258   for( i = size-1; i >= 0; --i) {
1259     printIndentation( indentation );
1260     printf("B[%d][%d]", depth, i);
1261     if (DEBUG_details > 1) printf(" (0x%08lx) ", SpB + BREL(i) );
1262     printf("=");
1263     printAddress( (P_) *(SpB + BREL(i)) );
1264     printf("\n");
1265   }
1266 }
1267
1268 static void
1269 printEnvironment( int depth, int indentation, int weight, PP_ SpA, PP_ SuA, P_ SpB, P_ SuB )
1270 {
1271   int sizeA = SUBTRACT_A_STK(SpA, SuA);
1272   int sizeB = SUBTRACT_B_STK(SpB, SuB);
1273
1274   if (sizeA + sizeB > 0) {
1275     printIndentation( indentation );
1276     printf("let\n");
1277
1278     printLocalAStack( depth, indentation+1, weight, SpA, sizeA );
1279     printLocalBStack( depth, indentation+1, weight, SpB, sizeB );
1280
1281     printIndentation( indentation );
1282     printf("in\n");
1283   }
1284 }
1285 \end{code}
1286
1287 Printing the current context is a little tricky.
1288
1289 Ideally, we would work from the bottom of the stack up to the top
1290 recursively printing the stuff nearer the top.
1291
1292 In practice, we have to work from the top down because the top
1293 contains info about how much data is below the current return address.
1294
1295 The result is that we have two recursive passes over the stacks: the
1296 first one prints the "cases" and the second one prints the
1297 continuations (vector tables, etc.)
1298
1299 Note that because we compress chains of update frames, the depth and
1300 indentation do not always change in step.
1301
1302 ToDo:
1303
1304 * detecting non-updating cases too
1305 * printing continuations (from vector tables) properly
1306 * printing sensible names in environment.
1307 * fix bogus nature of lets
1308
1309
1310 \begin{code}
1311 static int maxDepth = 5;
1312
1313 static int
1314 printCases( int depth, int weight, PP_ SpA, PP_ SuA, P_ SpB, P_ SuB )
1315 {
1316 #ifdef CONCURRENT
1317   printf("no printCases for CONCURRENT\n");
1318 #else
1319   int indentation;
1320
1321   if (depth < maxDepth && SUBTRACT_B_STK(SuB, stackInfo.botB) >= 0) {
1322     PP_ nextSpA, nextSuA;
1323     P_  nextSpB, nextSuB;
1324
1325     /* ToDo: GhcConstants.lh reveals that there are two other sizes of
1326        update frame possible */
1327     /* ToDo: botB is probably wrong in THREAD system */
1328
1329     nextSpB = SuB + BREL(STD_UF_SIZE);
1330     nextSuB = GRAB_SuB( SuB );
1331     nextSpA = SuA;
1332     nextSuA = GRAB_SuA( nextSuB );
1333
1334     indentation = printCases( depth+1, weight, nextSpA, nextSuA, nextSpB, nextSuB );
1335
1336     if (DEBUG_details > 1 || nextSpB != nextSuB) { /* show frame (even if adjacent to another) */
1337       printIndentation( indentation );
1338       printf("case\n");
1339       indentation = indentation + 1;
1340     }
1341     if (SpB != SuB) {
1342       /* next thing on stack is a return vector - no need to show it here. */
1343       SpB = SpB + BREL(1);
1344     }
1345     printEnvironment( depth, indentation, weight, SpA, SuA, SpB, SuB );
1346   } else {
1347     printf("...\n");
1348     indentation = 1;
1349   }
1350
1351   return indentation;
1352
1353 #endif /* CONCURRENT */
1354 }
1355
1356 /* ToDo: pay more attention to format of vector tables in SMupdate.lh */
1357
1358 static int
1359 isVTBLEntry( P_ entry )
1360 {
1361   char *raw;
1362
1363   if (lookupForName( entry, &raw )) {
1364     if ( strncmp( "_ret", raw, 4 ) == 0 ) {
1365       return 1;
1366     } else if ( strncmp( "_djn", raw, 4 ) == 0) {
1367       return 1;
1368     } else {
1369       return 0;
1370     }
1371   } else {
1372     return 0;
1373   }
1374 }
1375
1376 static void
1377 printVectorTable( int indentation, PP_ vtbl )
1378 {
1379   if (isVTBLEntry( (P_) vtbl )) { /* Direct return */
1380     printName( (P_) vtbl );
1381   } else {
1382     int i = 0;
1383     while( isVTBLEntry( vtbl[RVREL(i)] )) {
1384       printIndentation( indentation );
1385       printf( "%d -> ", i );
1386       printName( vtbl[RVREL(i)] );
1387       printf( "\n" );
1388       i = i + 1;
1389     }
1390   }
1391 }
1392
1393 static void
1394 printContinuations( int depth, int indentation, int weight, PP_ SpA, PP_ SuA, P_ SpB, P_ SuB )
1395 {
1396 #ifdef CONCURRENT
1397   printf("no printContinuations for CONCURRENT\n");
1398 #else
1399   if (depth < maxDepth && SUBTRACT_B_STK(SuB, stackInfo.botB) >= 0) {
1400     PP_ nextSpA, nextSuA;
1401     P_  nextSpB, nextSuB;
1402     int nextIndent = indentation; /* Indentation to print next frame at */
1403
1404     /* ToDo: GhcConstants.lh reveals that there are two other sizes of
1405        update frame possible */
1406     /* ToDo: botB is probably wrong in THREAD system */
1407
1408     /* ToDo: ASSERT that SuA == nextSuA */
1409
1410     nextSpB = SuB + BREL(STD_UF_SIZE);
1411     nextSuB = GRAB_SuB( SuB );
1412     nextSpA = SuA;
1413     nextSuA = GRAB_SuA( nextSuB );
1414
1415     if (DEBUG_details > 0) { /* print update information */
1416
1417       if (SpB != SuB) { /* start of chain of update frames */
1418         printIndentation( indentation );
1419         printf("of updatePtr ->\n");
1420         printIndentation( indentation+1 );
1421         printf("update\n");
1422       }
1423       printIndentation( indentation+2 );
1424       printClosure( (P_)*(SuB + BREL(UF_UPDATEE)), indentation+2, weight );
1425       printf(" := ");
1426       printName( (P_) *(SuB + BREL(UF_RET)) );
1427       printf("(updatePtr)\n");
1428
1429       if (nextSpB != nextSuB) { /* end of chain of update frames */
1430         nextIndent = nextIndent-1;
1431         printVectorTable( indentation+1, (PP_) *(nextSpB) );
1432       }
1433     } else {
1434       if (nextSpB != nextSuB) { /* end of chain of update frames */
1435         nextIndent = nextIndent-1;
1436         printVectorTable( indentation, (PP_) *(nextSpB) );
1437       }
1438     }
1439     printContinuations( depth+1, nextIndent, weight, nextSpA, nextSuA, nextSpB, nextSuB );
1440
1441   } else {
1442     printf("...\n");
1443   }
1444 #endif /* CONCURRENT */
1445 }
1446
1447 void
1448 DEBUG_Where( int depth, int weight )
1449 {
1450 #ifdef CONCURRENT
1451   PP_ SpA  = STKO_SpA(SAVE_StkO);
1452   PP_ SuA  = STKO_SuA(SAVE_StkO);
1453   P_  SpB  = STKO_SpB(SAVE_StkO);
1454   P_  SuB  = STKO_SuB(SAVE_StkO);
1455 #else
1456   PP_ SpA  = SAVE_SpA;
1457   PP_ SuA  = SAVE_SuA;
1458   P_  SpB  = SAVE_SpB;
1459   P_  SuB  = SAVE_SuB;
1460 #endif
1461   P_ Hp    = SAVE_Hp;
1462   StgRetAddr RetReg = SAVE_Ret;
1463   P_ Node  = SAVE_R1.p;
1464
1465   int indentation;
1466
1467   maxDepth = depth;
1468
1469   printf("WARNING: Non-updating cases may be incorrectly displayed\n");
1470
1471   indentation = printCases( 1, weight, SpA, SuA, SpB, SuB );
1472
1473   printIndentation( indentation );
1474   printf("CASE\n");
1475
1476   printIndentation( indentation+1 );
1477   printName( Node );
1478   printf("\n");
1479   printVectorTable( indentation+1, (PP_) RetReg );
1480
1481   printContinuations( depth, indentation, weight, SpA, SuA, SpB, SuB );
1482 }
1483 \end{code}
1484
1485
1486 \begin{code}
1487 void
1488 DEBUG_INFO_TABLE(node)
1489   P_ node;
1490 {
1491   int vhs, size, ptrs; /* not used */
1492   char *ip_type;
1493   StgPtr info_ptr = (StgPtr) INFO_PTR(node);
1494
1495   getClosureShape(node, &vhs, &size, &ptrs, &ip_type);
1496
1497   fprintf(stderr,
1498           "%s Info Ptr 0x%lx; Entry: 0x%lx; Update: 0x%lx\n",
1499           ip_type, info_ptr,
1500           (W_) ENTRY_CODE(info_ptr), (W_) UPDATE_CODE(info_ptr));
1501   fprintf(stderr,
1502           "Tag: %ld; Type: %ld; Size: %lu; Ptrs: %lu\n\n",
1503           INFO_TAG(info_ptr), INFO_TYPE(info_ptr),
1504           INFO_SIZE(info_ptr),INFO_NoPTRS(info_ptr));
1505 #if defined(GRIP)
1506   /* flushing is GRIP only */
1507   fprintf(stderr,"Enter Flush Entry: 0x%lx;\tExit Flush Entry: 0x%lx\n",INFO_FLUSHENT(info_ptr),INFO_FLUSH(info_ptr));
1508 #endif /* GRIP */
1509
1510 #if defined(PROFILING)
1511   fprintf(stderr,"Cost Centre:       0x%lx\n",INFO_CAT(info_ptr));
1512 #endif /* PROFILING */
1513
1514 #if defined(_INFO_COPYING)
1515   fprintf(stderr,"Evacuate Entry:    0x%lx;\tScavenge Entry: 0x%lx\n",
1516           INFO_EVAC_2S(info_ptr),INFO_SCAV_2S(info_ptr));
1517 #endif /* INFO_COPYING */
1518
1519 #if defined(_INFO_COMPACTING)
1520   fprintf(stderr,"Scan Link:         0x%lx;\tScan Move:      0x%lx\n",
1521           (W_) INFO_SCAN_LINK_1S(info_ptr), (W_) INFO_SCAN_MOVE_1S(info_ptr));
1522   fprintf(stderr,"Mark:              0x%lx;\tMarked:         0x%lx;\n",
1523           (W_) INFO_MARK_1S(info_ptr), (W_) INFO_MARKED_1S(info_ptr));
1524   if(BASE_INFO_TYPE(info_ptr)==INFO_SPEC_TYPE)
1525     fprintf(stderr,"plus specialised code\n");
1526   else
1527     fprintf(stderr,"Marking:           0x%lx\n",(W_) INFO_MARKING_1S(info_ptr));
1528 #endif /* INFO_COMPACTING */
1529 }
1530
1531 void
1532 DEBUG_REGS()
1533 {
1534 #ifdef CONCURRENT
1535   PP_ SpA  = STKO_SpA(SAVE_StkO);
1536   PP_ SuA  = STKO_SuA(SAVE_StkO);
1537   P_  SpB  = STKO_SpB(SAVE_StkO);
1538   P_  SuB  = STKO_SuB(SAVE_StkO);
1539 #else
1540   PP_ SpA  = SAVE_SpA;
1541   PP_ SuA  = SAVE_SuA;
1542   P_  SpB  = SAVE_SpB;
1543   P_  SuB  = SAVE_SuB;
1544 #endif
1545   P_  Hp   = SAVE_Hp;
1546   P_  HpLim= SAVE_HpLim;
1547   I_  TagReg= SAVE_Tag;
1548   StgRetAddr RetReg = SAVE_Ret;
1549   P_  Node = SAVE_R1.p;
1550   StgUnion  R1   = SAVE_R1;
1551   StgUnion  R2   = SAVE_R2;
1552   StgUnion  R3   = SAVE_R3;
1553   StgUnion  R4   = SAVE_R4;
1554   StgUnion  R5   = SAVE_R5;
1555   StgUnion  R6   = SAVE_R6;
1556   StgUnion  R7   = SAVE_R7;
1557   StgUnion  R8   = SAVE_R8;
1558   StgFloat FltReg1 = SAVE_Flt1;
1559   StgFloat FltReg2 = SAVE_Flt2;
1560   StgFloat FltReg3 = SAVE_Flt3;
1561   StgFloat FltReg4 = SAVE_Flt4;
1562   StgDouble DblReg1 = SAVE_Dbl1;
1563   StgDouble DblReg2 = SAVE_Dbl2;
1564   StgDouble LngReg1 = SAVE_Lng1;
1565   StgDouble LngReg2 = SAVE_Lng2;
1566
1567   fprintf(stderr,"STG-Machine Register Values:\n\n");
1568   fprintf(stderr,"Node:  %08lx;  Hp:    %08lx;  HpLim: %08lx;  Tag:   %8lu\n",Node,(W_)Hp,(W_)HpLim,TagReg);
1569   fprintf(stderr,"SpA:   %08lx;  SpB:   %08lx;  SuA:   %08lx;  SuB:   %08lx\n",(W_)SpA,(W_)SpB,(W_)SuA,(W_)SuB);
1570   fprintf(stderr,"RetReg: %08lx\n",RetReg);
1571
1572 #if 0
1573 /* These bits need to have the FLUSH_REG_MAP, whereas the surrounding bits
1574    use the MAIN_REG_MAP */
1575
1576   fprintf(stderr, "\n");
1577   fprintf(stderr,"LiveR: %08lx\n", LivenessReg);
1578   fprintf(stderr,"Flush: %08lx;  FStk:  %08lx;  FStkB: %08lx;  FTmp:  %08lx\n",(W_)FlushP,(W_)FStack,(W_)FStackBase,(W_)Temp);
1579 #endif /* 0 */
1580
1581   fprintf(stderr, "\n");
1582
1583   fprintf(stderr,"Gen:   %8lu, %8lu, %8lu, %8lu\n",R1.i,R2.i,R3.i,R4.i);
1584   fprintf(stderr,"       %8lu, %8lu, %8lu, %8lu\n",R5.i,R6.i,R7.i,R8.i);
1585   fprintf(stderr,"Float: %8g, %8g, %8g, %8g\n",FltReg1,FltReg2,FltReg3,FltReg4);
1586   fprintf(stderr,"Dble:  %8g, %8g\n",DblReg1,DblReg2);
1587   fprintf(stderr,"Long:  %8lu, %8lu\n",LngReg1,LngReg2);
1588 }
1589
1590 #ifndef CONCURRENT
1591
1592 void
1593 DEBUG_FO()
1594 {
1595   StgPtr mp;
1596   StgInt i;
1597
1598   fprintf(stderr,"ForeignObjList\n\n");
1599
1600   for(mp = StorageMgrInfo.ForeignObjList;
1601       mp != NULL;
1602       mp = ForeignObj_CLOSURE_LINK(mp)) {
1603
1604     fprintf(stderr,
1605             "ForeignObjPtr(0x%lx) = 0x%lx, finaliser: 0x%lx\n",
1606             mp,
1607             ForeignObj_CLOSURE_DATA(mp),
1608             ForeignObj_CLOSURE_FINALISER(mp));
1609
1610 /*
1611     DEBUG_PRINT_NODE(mp);
1612 */
1613   }
1614
1615 # if defined(GCap) || defined(GCgn)
1616   fprintf(stderr,"\nOldForeignObj List\n\n");
1617
1618   for(mp = StorageMgrInfo.OldForeignObjList;
1619       mp != NULL;
1620       mp = ForeignObj_CLOSURE_LINK(mp)) {
1621
1622     fprintf(stderr,
1623             "ForeignObj(0x%lx) = 0x%lx, finaliser: 0x%lx\n",
1624             mp,
1625             ForeignObj_CLOSURE_DATA(mp),
1626             ForeignObj_CLOSURE_FINALISER(mp));
1627 /*
1628    DEBUG_PRINT_NODE(mp);
1629 */
1630   }
1631 # endif /* GCap || GCgn */
1632
1633   fprintf(stderr, "\n");
1634 }
1635
1636 void
1637 DEBUG_SPT(int weight)
1638 {
1639   StgPtr SPTable = StorageMgrInfo.StablePointerTable;
1640   StgInt size = SPT_SIZE(SPTable);
1641   StgInt ptrs = SPT_NoPTRS(SPTable);
1642   StgInt top = SPT_TOP(SPTable);
1643
1644   StgInt i;
1645
1646 /*
1647   DEBUG_PRINT_NODE(SPTable);
1648 */
1649
1650   fprintf(stderr,"SPTable@0x%lx:\n", SPTable);
1651   fprintf(stderr,"  InfoPtr = 0x%lx\n", INFO_PTR(SPTable));
1652   fprintf(stderr,"  size = %d, ptrs = %d, top = %d\n",
1653                     size,      ptrs,      top
1654          );
1655   for( i=0; i < ptrs; i++ ) {
1656     if (i % 10 == 0) {
1657       fprintf(stderr,"\n  ");
1658     }
1659     printClosure(SPT_SPTR(SPTable, i),1,weight);
1660     fprintf(stderr, "\n");
1661   }
1662   fprintf(stderr, "\n");
1663   for( i=0; i < top; i++) {
1664     if (i % 10 == 0) {
1665       fprintf(stderr,"\n  ");
1666     }
1667     fprintf(stderr, " %3d", SPT_FREE(SPTable, i));
1668   }
1669
1670   fprintf(stderr, "\n\n");
1671
1672 }
1673 #endif /* !CONCURRENT */
1674
1675 /*
1676   These routines crawl over the A and B stacks, printing
1677   a maximum "lines" lines at the top of the stack.
1678 */
1679
1680 #define STACK_VALUES_PER_LINE   5
1681
1682 #ifndef CONCURRENT
1683 /* (stack stuff is really different on parallel machines) */
1684
1685 void
1686 DEBUG_ASTACK(lines)
1687   I_ lines;
1688 {
1689   PP_ SpA  = SAVE_SpA;
1690   PP_ SuA  = SAVE_SuA;
1691   P_  SpB  = SAVE_SpB;
1692   P_  SuB  = SAVE_SuB;
1693
1694   PP_   stackptr;
1695   I_ count = 0;
1696
1697   fprintf(stderr,"Dump of the Address Stack, SpA: 0x%08lx, BOS: 0x%08lx\n",
1698                     (W_) SpA, (W_) stackInfo.botA);
1699
1700   for (stackptr = SpA;
1701        SUBTRACT_A_STK(stackptr, stackInfo.botA) >= 0;
1702        stackptr = stackptr + AREL(1))
1703     {
1704       if( count++ % STACK_VALUES_PER_LINE == 0)
1705         {
1706           if(count >= lines * STACK_VALUES_PER_LINE)
1707             break;
1708           fprintf(stderr,"\nSpA[%ld] (0x%08lx): ",count-1,stackptr);
1709         }
1710       fprintf(stderr,"0x%08lx ",(W_) *stackptr);
1711     }
1712   fprintf(stderr, "\n");
1713 }
1714
1715 void
1716 DEBUG_BSTACK(lines)
1717   I_ lines;
1718 {
1719   PP_ SpA  = SAVE_SpA;
1720   PP_ SuA  = SAVE_SuA;
1721   P_  SpB  = SAVE_SpB;
1722   P_  SuB  = SAVE_SuB;
1723
1724   P_    stackptr;
1725   I_ count = 0;
1726
1727   fprintf(stderr,"Dump of the Value Stack, SpB: 0x%08lx, BOS: 0x%08lx\n",
1728                 (W_) SpB, (W_) stackInfo.botB);
1729
1730   for (stackptr = SpB;
1731          SUBTRACT_B_STK(stackptr, stackInfo.botB) > 0;
1732          stackptr = stackptr + BREL(1))
1733       {
1734         if( count++ % STACK_VALUES_PER_LINE == 0)
1735           {
1736             if(count >= lines * STACK_VALUES_PER_LINE)
1737               break;
1738             fprintf(stderr,"\nSpB[%ld] (0x%08lx): ",count-1,stackptr);
1739           }
1740         fprintf(stderr,"0x%08lx ",(W_) *stackptr);
1741       }
1742   fprintf(stderr, "\n");
1743 }
1744
1745
1746 #endif /* not concurrent */
1747
1748 /*
1749   This should disentangle update frames from both stacks.
1750 */
1751
1752 #ifndef CONCURRENT
1753 void
1754 DEBUG_UPDATES(limit)
1755   I_ limit;
1756 {
1757   PP_ SpA  = SAVE_SpA;
1758   PP_ SuA  = SAVE_SuA;
1759   P_  SpB  = SAVE_SpB;
1760   P_  SuB  = SAVE_SuB;
1761
1762   P_  updatee, retreg;
1763   PP_ sua, spa;
1764   P_  sub, spb;
1765   I_  count = 0;
1766
1767   fprintf(stderr,"Update Frame Stack Dump:\n\n");
1768
1769   for(spa = SuA, spb = SuB;
1770       SUBTRACT_B_STK(spb, stackInfo.botB) > 0 && count++ < limit;
1771       spa = GRAB_SuA(spb), spb = GRAB_SuB(spb) ) {
1772
1773       updatee = GRAB_UPDATEE(spb);         /* Thing to be updated  */
1774       retreg  = (P_) GRAB_RET(spb);        /* Return vector below */
1775
1776       fprintf(stderr,"SuA: 0x%08lx, SuB: 0x%08lx, Updatee 0x%08lx (Info 0x%08lx), RetReg 0x%x\n",
1777                      (W_) spa, (W_) spb,
1778                      (W_) updatee, (W_) INFO_PTR(updatee), (W_) retreg);
1779   }
1780 }
1781
1782 #endif /* not concurrent */
1783 \end{code}
1784
1785 \begin{code}
1786 #ifdef CONCURRENT
1787
1788 void
1789 DEBUG_TSO(P_ tso)
1790 {
1791     STGRegisterTable *r = TSO_INTERNAL_PTR(tso);
1792     W_ liveness = r->rLiveness;
1793     I_ i;
1794
1795     fprintf(stderr,"TSO:\ntso=%lx, regs=%lx, liveness=%lx\nlink=%lx,name=%lx,id=%lx,type=%lx,pc1=%lx,arg1=%lx,switch=%lx\n"
1796             , tso
1797             , r
1798             , liveness
1799             , TSO_LINK(tso)
1800             , TSO_NAME(tso)
1801             , TSO_ID(tso)
1802             , TSO_TYPE(tso)
1803             , TSO_PC1(tso)
1804             , TSO_ARG1(tso)
1805             , TSO_SWITCH(tso)
1806             );
1807
1808     for (i = 0; liveness != 0; liveness >>= 1, i++) {
1809         if (liveness & 1) {
1810             fprintf(stderr, "live reg %d (%lx)\n",i, r->rR[i].p);
1811         } else {
1812             fprintf(stderr, "reg %d (%lx) not live\n", i, r->rR[i].p);
1813         }
1814     }
1815 }
1816
1817 #endif /* concurrent */
1818 \end{code}
1819
1820 %****************************************************************************
1821 %
1822 \subsection[GrAnSim-debug]{Debugging routines  for GrAnSim}
1823 %
1824 %****************************************************************************
1825
1826 Debugging routines, mainly for GrAnSim.
1827 They should really be in a separate file.
1828 There is some code duplication of above routines in here, I'm afraid.
1829
1830 As a naming convention all GrAnSim debugging functions start with @G_@.
1831 The shorthand forms defined at the end start only with @G@.
1832
1833 \begin{code}
1834 #if defined(GRAN) && defined(GRAN_CHECK)
1835
1836 #define NULL_REG_MAP        /* Not threaded */
1837 /* #include "stgdefs.h" */
1838
1839 char *
1840 info_hdr_type(info_ptr)
1841 P_ info_ptr;
1842 {
1843 #if ! defined(PAR) && !defined(GRAN)
1844   switch (INFO_TAG(info_ptr))
1845     {
1846       case INFO_OTHER_TAG:
1847         return("OTHER_TAG");
1848 /*    case INFO_IND_TAG:
1849         return("IND_TAG");
1850 */    default:
1851         return("TAG<n>");
1852     }
1853 #else /* PAR */
1854   switch(BASE_INFO_TYPE(info_ptr))
1855     {
1856       case INFO_SPEC_TYPE:
1857         return("SPEC");
1858
1859       case INFO_GEN_TYPE:
1860         return("GEN");
1861
1862       case INFO_DYN_TYPE:
1863         return("DYN");
1864
1865       case INFO_TUPLE_TYPE:
1866         return("TUPLE");
1867
1868       case INFO_DATA_TYPE:
1869         return("DATA");
1870
1871       case INFO_MUTUPLE_TYPE:
1872         return("MUTUPLE");
1873
1874       case INFO_IMMUTUPLE_TYPE:
1875         return("IMMUTUPLE");
1876
1877       case INFO_STATIC_TYPE:
1878         return("STATIC");
1879
1880       case INFO_CONST_TYPE:
1881         return("CONST");
1882
1883       case INFO_CHARLIKE_TYPE:
1884         return("CHAR");
1885
1886       case INFO_INTLIKE_TYPE:
1887         return("INT");
1888
1889       case INFO_BH_TYPE:
1890         return("BHOLE");
1891
1892       case INFO_BQ_TYPE:
1893         return("BQ");
1894
1895       case INFO_IND_TYPE:
1896         return("IND");
1897
1898       case INFO_CAF_TYPE:
1899         return("CAF");
1900
1901       case INFO_FM_TYPE:
1902         return("FETCHME");
1903
1904       case INFO_TSO_TYPE:
1905         return("TSO");
1906
1907       case INFO_STKO_TYPE:
1908         return("STKO");
1909
1910       case INFO_SPEC_RBH_TYPE:
1911         return("SPEC_RBH");
1912
1913       case INFO_GEN_RBH_TYPE:
1914         return("GEN_RBH");
1915
1916       case INFO_BF_TYPE:
1917         return("BF");
1918
1919       case INFO_INTERNAL_TYPE:
1920         return("INTERNAL");
1921
1922       default:
1923         fprintf(stderr,"Unknown header type %lu\n",INFO_TYPE(info_ptr));
1924         return("??");
1925       }
1926 #endif /* PAR */
1927 }
1928
1929 char *
1930 info_type(infoptr, str)
1931 P_ infoptr;
1932 char *str;
1933 {
1934   strcpy(str,"");
1935   if ( IS_NF(infoptr) )
1936     strcat(str,"|_NF ");
1937   else if ( IS_MUTABLE(infoptr) )
1938     strcat(str,"|_MU");
1939   else if ( IS_STATIC(infoptr) )
1940     strcat(str,"|_ST");
1941   else if ( IS_UPDATABLE(infoptr) )
1942     strcat(str,"|_UP");
1943   else if ( IS_BIG_MOTHER(infoptr) )
1944     strcat(str,"|_BM");
1945   else if ( IS_BLACK_HOLE(infoptr) )
1946     strcat(str,"|_BH");
1947   else if ( IS_INDIRECTION(infoptr) )
1948     strcat(str,"|_IN");
1949   else if ( IS_THUNK(infoptr) )
1950     strcat(str,"|_TH");
1951
1952   return(str);
1953 }
1954
1955 /*
1956 @var_hdr_size@ computes the size of the variable header for a closure.
1957 */
1958
1959 I_
1960 var_hdr_size(node)
1961 P_ node;
1962 {
1963   switch(INFO_TYPE(INFO_PTR(node)))
1964     {
1965       case INFO_SPEC_U_TYPE:    return(0);      /* by decree */
1966       case INFO_SPEC_N_TYPE:    return(0);
1967       case INFO_GEN_U_TYPE:     return(GEN_VHS);
1968       case INFO_GEN_N_TYPE:     return(GEN_VHS);
1969       case INFO_DYN_TYPE:       return(DYN_VHS);
1970       /*
1971       case INFO_DYN_TYPE_N:     return(DYN_VHS);
1972       case INFO_DYN_TYPE_U:     return(DYN_VHS);
1973       */
1974       case INFO_TUPLE_TYPE:     return(TUPLE_VHS);
1975       case INFO_DATA_TYPE:      return(DATA_VHS);
1976       case INFO_MUTUPLE_TYPE:   return(MUTUPLE_VHS);
1977       case INFO_IMMUTUPLE_TYPE: return(MUTUPLE_VHS); /* same layout */
1978       case INFO_STATIC_TYPE:    return(STATIC_VHS);
1979       case INFO_CONST_TYPE:     return(0);
1980       case INFO_CHARLIKE_TYPE:  return(0);
1981       case INFO_INTLIKE_TYPE:   return(0);
1982       case INFO_BH_TYPE:        return(0);
1983       case INFO_IND_TYPE:       return(0);
1984       case INFO_CAF_TYPE:       return(0);
1985       case INFO_FETCHME_TYPE:   return(0);
1986       case INFO_BQ_TYPE:        return(0);
1987       /*
1988       case INFO_BQENT_TYPE:     return(0);
1989       */
1990       case INFO_TSO_TYPE:       return(TSO_VHS);
1991       case INFO_STKO_TYPE:      return(STKO_VHS);
1992       default:
1993         fprintf(stderr,"Unknown info type 0x%lx (%lu)\n", INFO_PTR(node),
1994           INFO_TYPE(INFO_PTR(node)));
1995         return(0);
1996     }
1997 }
1998
1999
2000 /* Determine the size and number of pointers for this kind of closure */
2001 void
2002 size_and_ptrs(node,size,ptrs)
2003 P_ node;
2004 W_ *size, *ptrs;
2005 {
2006   switch(INFO_TYPE(INFO_PTR(node)))
2007     {
2008       case INFO_SPEC_U_TYPE:
2009       case INFO_SPEC_N_TYPE:
2010         *size = INFO_SIZE(INFO_PTR(node));          /* New for 0.24; check */
2011         *ptrs = INFO_NoPTRS(INFO_PTR(node));        /* that! -- HWL */
2012         /*
2013         *size = SPEC_CLOSURE_SIZE(node);
2014         *ptrs = SPEC_CLOSURE_NoPTRS(node);
2015         */
2016         break;
2017
2018       case INFO_GEN_U_TYPE:
2019       case INFO_GEN_N_TYPE:
2020         *size = GEN_CLOSURE_SIZE(node);
2021         *ptrs = GEN_CLOSURE_NoPTRS(node);
2022         break;
2023
2024       /*
2025       case INFO_DYN_TYPE_U:
2026       case INFO_DYN_TYPE_N:
2027       */
2028       case INFO_DYN_TYPE:
2029         *size = DYN_CLOSURE_SIZE(node);
2030         *ptrs = DYN_CLOSURE_NoPTRS(node);
2031         break;
2032
2033       case INFO_TUPLE_TYPE:
2034         *size = TUPLE_CLOSURE_SIZE(node);
2035         *ptrs = TUPLE_CLOSURE_NoPTRS(node);
2036         break;
2037
2038       case INFO_DATA_TYPE:
2039         *size = DATA_CLOSURE_SIZE(node);
2040         *ptrs = DATA_CLOSURE_NoPTRS(node);
2041         break;
2042
2043       case INFO_IND_TYPE:
2044         *size = IND_CLOSURE_SIZE(node);
2045         *ptrs = IND_CLOSURE_NoPTRS(node);
2046         break;
2047
2048 /* ToDo: more (WDP) */
2049
2050       /* Don't know about the others */
2051       default:
2052         *size = *ptrs = 0;
2053         break;
2054     }
2055 }
2056
2057 void
2058 G_PRINT_NODE(node)
2059 P_ node;
2060 {
2061    P_ info_ptr, bqe; /* = INFO_PTR(node); */
2062    I_ size = 0, ptrs = 0, nonptrs = 0, i, vhs = 0;
2063    char info_hdr_ty[80], info_ty[80];
2064
2065    if (node==NULL) {
2066      fprintf(stderr,"NULL\n");
2067      return;
2068    } else if (node==PrelBase_Z91Z93_closure) {
2069      fprintf(stderr,"PrelBase_Z91Z93_closure\n");
2070      return;
2071    } else if (node==MUT_NOT_LINKED) {
2072      fprintf(stderr,"MUT_NOT_LINKED\n");
2073      return;
2074    }
2075    /* size_and_ptrs(node,&size,&ptrs); */
2076    info_ptr = get_closure_info(node, &size, &ptrs, &nonptrs, &vhs, info_hdr_ty);
2077
2078    /* vhs = var_hdr_size(node); */
2079    info_type(info_ptr,info_ty);
2080
2081    fprintf(stderr,"Node: 0x%lx", (W_) node);
2082
2083 #if defined(PAR)
2084    fprintf(stderr," [GA: 0x%lx]",GA(node));
2085 #endif
2086
2087 #if defined(USE_COST_CENTRES)
2088    fprintf(stderr," [CC: 0x%lx]",CC_HDR(node));
2089 #endif
2090
2091 #if defined(GRAN)
2092    fprintf(stderr," [Bitmask: 0%lo]",PROCS(node));
2093 #endif
2094
2095    if (info_ptr==INFO_TSO_TYPE)
2096      fprintf(stderr," TSO: 0x%lx (%x) IP: 0x%lx (%s), type %s \n     ",
2097              node, TSO_ID(node), info_ptr, info_hdr_ty, info_ty);
2098    else
2099      fprintf(stderr," IP: 0x%lx (%s), type %s \n       VHS: %d, size: %ld, ptrs:%ld, nonptrs:  %ld\n     ",
2100              info_ptr,info_hdr_ty,info_ty,vhs,size,ptrs,nonptrs);
2101
2102    /* For now, we ignore the variable header */
2103
2104    fprintf(stderr," Ptrs: ");
2105    for(i=0; i < ptrs; ++i)
2106      {
2107      if ( (i+1) % 6 == 0)
2108        fprintf(stderr,"\n      ");
2109      fprintf(stderr," 0x%lx[P]",*(node+_FHS+vhs+i));
2110      };
2111
2112    fprintf(stderr," Data: ");
2113    for(i=0; i < nonptrs; ++i)
2114      {
2115        if( (i+1) % 6 == 0)
2116          fprintf(stderr,"\n      ");
2117        fprintf(stderr," %lu[D]",*(node+_FHS+vhs+ptrs+i));
2118      }
2119    fprintf(stderr, "\n");
2120
2121
2122    switch (INFO_TYPE(info_ptr))
2123     {
2124      case INFO_TSO_TYPE:
2125       fprintf(stderr,"\n TSO_LINK: %#lx",
2126               TSO_LINK(node));
2127       break;
2128
2129     case INFO_BH_TYPE:
2130     case INFO_BQ_TYPE:
2131       bqe = (P_)BQ_ENTRIES(node);
2132       fprintf(stderr," BQ of %#lx: ", node);
2133       PRINT_BQ(bqe);
2134       break;
2135     case INFO_FMBQ_TYPE:
2136       printf("Panic: found FMBQ Infotable in GrAnSim system.\n");
2137       break;
2138     case INFO_SPEC_RBH_TYPE:
2139       bqe = (P_)SPEC_RBH_BQ(node);
2140       fprintf(stderr," BQ of %#lx: ", node);
2141       PRINT_BQ(bqe);
2142       break;
2143     case INFO_GEN_RBH_TYPE:
2144       bqe = (P_)GEN_RBH_BQ(node);
2145       fprintf(stderr," BQ of %#lx: ", node);
2146       PRINT_BQ(bqe);
2147       break;
2148     }
2149 }
2150
2151 void
2152 G_PPN(node)  /* Extracted from PrintPacket in Pack.lc */
2153 P_ node;
2154 {
2155    P_ info ;
2156    I_ size = 0, ptrs = 0, nonptrs = 0, i, vhs = 0, locn = 0;
2157    char info_type[80];
2158
2159    /* size_and_ptrs(node,&size,&ptrs); */
2160    info = get_closure_info(node, &size, &ptrs, &nonptrs, &vhs, info_type);
2161
2162    if (INFO_TYPE(info) == INFO_FETCHME_TYPE || IS_BLACK_HOLE(info))
2163      size = ptrs = nonptrs = vhs = 0;
2164
2165    if (IS_THUNK(info)) {
2166      if (IS_UPDATABLE(info))
2167        fputs("SHARED ", stderr);
2168      else
2169        fputs("UNSHARED ", stderr);
2170    }
2171    if (IS_BLACK_HOLE(info)) {
2172      fputs("BLACK HOLE\n", stderr);
2173    } else {
2174      /* Fixed header */
2175      fprintf(stderr, "(%s) FH [%#lx", info_type, node[locn++]);
2176      for (i = 1; i < FIXED_HS; i++)
2177        fprintf(stderr, " %#lx", node[locn++]);
2178
2179      /* Variable header */
2180      if (vhs > 0) {
2181        fprintf(stderr, "] VH [%#lx", node[locn++]);
2182
2183        for (i = 1; i < vhs; i++)
2184          fprintf(stderr, " %#lx", node[locn++]);
2185      }
2186
2187      fprintf(stderr, "] PTRS %u", ptrs);
2188
2189      /* Non-pointers */
2190      if (nonptrs > 0) {
2191        fprintf(stderr, " NPTRS [%#lx", node[locn++]);
2192
2193        for (i = 1; i < nonptrs; i++)
2194          fprintf(stderr, " %#lx", node[locn++]);
2195
2196        putc(']', stderr);
2197      }
2198      putc('\n', stderr);
2199    }
2200
2201  }
2202
2203 #define INFO_MASK       0x80000000
2204
2205 void
2206 G_MUT(node,verbose)  /* Print mutables list starting with node */
2207 P_ node;
2208 {
2209   if (verbose & 0x1) { G_PRINT_NODE(node); fprintf(stderr, "\n"); }
2210   else               fprintf(stderr, "0x%#lx, ", node);
2211
2212   if (node==NULL || node==PrelBase_Z91Z93_closure || node==MUT_NOT_LINKED) {
2213      return;
2214   }
2215   G_MUT(MUT_LINK(node), verbose);
2216 }
2217
2218
2219 void
2220 G_TREE(node)
2221 P_ node;
2222 {
2223   W_ size = 0, ptrs = 0, i, vhs = 0;
2224
2225   /* Don't print cycles */
2226   if((INFO_PTR(node) & INFO_MASK) != 0)
2227     return;
2228
2229   size_and_ptrs(node,&size,&ptrs);
2230   vhs = var_hdr_size(node);
2231
2232   G_PRINT_NODE(node);
2233   fprintf(stderr, "\n");
2234
2235   /* Mark the node -- may be dangerous */
2236   INFO_PTR(node) |= INFO_MASK;
2237
2238   for(i = 0; i < ptrs; ++i)
2239     G_TREE((P_)node[i+vhs+_FHS]);
2240
2241   /* Unmark the node */
2242   INFO_PTR(node) &= ~INFO_MASK;
2243 }
2244
2245
2246 void
2247 G_INFO_TABLE(node)
2248 P_ node;
2249 {
2250   P_ info_ptr = (P_)INFO_PTR(node);
2251   char *ip_type = info_hdr_type(info_ptr);
2252
2253   fprintf(stderr,"%s Info Ptr @0x%lx; Entry: 0x%lx; Size: %lu; Ptrs: %lu\n\n",
2254                  ip_type,info_ptr,(W_) ENTRY_CODE(info_ptr),INFO_SIZE(info_ptr),INFO_NoPTRS(info_ptr));
2255
2256   if (IS_THUNK(info_ptr) && IS_UPDATABLE(info_ptr) ) {
2257     fprintf(stderr,"  RBH InfoPtr: %#lx\n",
2258             RBH_INFOPTR(info_ptr));
2259   }
2260
2261 #if defined(PAR)
2262   fprintf(stderr,"Enter Flush Entry: 0x%lx;\tExit Flush Entry: 0x%lx\n",INFO_FLUSHENT(info_ptr),INFO_FLUSH(info_ptr));
2263 #endif
2264
2265 #if defined(USE_COST_CENTRES)
2266   fprintf(stderr,"Cost Centre (???):       0x%lx\n",INFO_CAT(info_ptr));
2267 #endif
2268
2269 #if defined(_INFO_COPYING)
2270   fprintf(stderr,"Evacuate Entry:    0x%lx;\tScavenge Entry: 0x%lx\n",
2271           INFO_EVAC_2S(info_ptr),INFO_SCAV_2S(info_ptr));
2272 #endif
2273
2274 #if defined(_INFO_COMPACTING)
2275   fprintf(stderr,"Scan Link:         0x%lx;\tScan Move:      0x%lx\n",
2276           (W_) INFO_SCAN_LINK_1S(info_ptr), (W_) INFO_SCAN_MOVE_1S(info_ptr));
2277   fprintf(stderr,"Mark:              0x%lx;\tMarked:         0x%lx;\t",
2278           (W_) INFO_MARK_1S(info_ptr), (W_) INFO_MARKED_1S(info_ptr));
2279 #if 0 /* avoid INFO_TYPE */
2280   if(BASE_INFO_TYPE(info_ptr)==INFO_SPEC_TYPE)
2281     fprintf(stderr,"plus specialised code\n");
2282   else
2283     fprintf(stderr,"Marking:           0x%lx\n",(W_) INFO_MARKING_1S(info_ptr));
2284 #endif /* 0 */
2285 #endif /* _INFO_COMPACTING */
2286 }
2287 #endif /* GRAN */
2288
2289 \end{code}
2290
2291 The remaining debugging routines are more or less specific for GrAnSim.
2292
2293 \begin{code}
2294 #if defined(GRAN) && defined(GRAN_CHECK)
2295 void
2296 G_CURR_THREADQ(verbose)
2297 I_ verbose;
2298 {
2299   fprintf(stderr,"Thread Queue on proc %d: ", CurrentProc);
2300   G_THREADQ(ThreadQueueHd, verbose);
2301 }
2302
2303 void
2304 G_THREADQ(closure, verbose)
2305 P_ closure;
2306 I_ verbose;
2307 {
2308  P_ x;
2309
2310  fprintf(stderr,"Thread Queue: ");
2311  for (x=closure; x!=PrelBase_Z91Z93_closure; x=TSO_LINK(x))
2312    if (verbose)
2313      G_TSO(x,0);
2314    else
2315      fprintf(stderr," %#lx",x);
2316
2317  if (closure==PrelBase_Z91Z93_closure)
2318    fprintf(stderr,"NIL\n");
2319  else
2320    fprintf(stderr,"\n");
2321 }
2322
2323 /* Check with Threads.lh */
2324 static char *type_name[] = { "T_MAIN", "T_REQUIRED", "T_ADVISORY", "T_FAIL"};
2325
2326 void
2327 G_TSO(closure,verbose)
2328 P_ closure;
2329 I_ verbose;
2330 {
2331
2332  if (closure==PrelBase_Z91Z93_closure) {
2333    fprintf(stderr,"TSO at %#lx is PrelBase_Z91Z93_closure!\n");
2334    return;
2335  }
2336
2337  if ( verbose & 0x08 ) {   /* short info */
2338    fprintf(stderr,"[TSO @ %#lx, PE %d]: Name: %#lx, Id: %#lx, Link: %#lx\n",
2339            closure,where_is(closure),
2340            TSO_NAME(closure),TSO_ID(closure),TSO_LINK(closure));
2341    return;
2342  }
2343
2344  fprintf(stderr,"TSO at %#lx has the following contents:\n",
2345                  closure);
2346
2347  fprintf(stderr,"> Name: \t%#lx",TSO_NAME(closure));
2348  fprintf(stderr,"\tLink: \t%#lx\n",TSO_LINK(closure));
2349  fprintf(stderr,"> Id:   \t%#lx",TSO_ID(closure));
2350 #if defined(GRAN_CHECK) && defined(GRAN)
2351  if (RTSflags.GranFlags.debug & 0x10)
2352    fprintf(stderr,"\tType: \t%s  %s\n",
2353            type_name[TSO_TYPE(closure) & ~FETCH_MASK_TSO],
2354            (TSO_TYPE(closure) & FETCH_MASK_TSO) ? "SLEEPING" : "");
2355  else
2356    fprintf(stderr,"\tType: \t%s\n",type_name[TSO_TYPE(closure)]);
2357 #else
2358  fprintf(stderr,"\tType: \t%s\n",type_name[TSO_TYPE(closure)]);
2359 #endif
2360  fprintf(stderr,"> PC1:  \t%#lx",TSO_PC1(closure));
2361  fprintf(stderr,"\tPC2:  \t%#lx\n",TSO_PC2(closure));
2362  fprintf(stderr,"> ARG1: \t%#lx",TSO_ARG1(closure));
2363  /* fprintf(stderr,"\tARG2: \t%#lx\n",TSO_ARG2(closure)); */
2364  fprintf(stderr,"> SWITCH: \t%#lx", TSO_SWITCH(closure));
2365 #if defined(GRAN_PRI_SCHED)
2366  fprintf(stderr,"\tPRI: \t%#lx\n", TSO_PRI(closure));
2367 #else
2368  fprintf(stderr,"\n");
2369 #endif
2370  if (verbose) {
2371    fprintf(stderr,"} LOCKED: \t%#lx",TSO_LOCKED(closure));
2372    fprintf(stderr,"\tSPARKNAME: \t%#lx\n", TSO_SPARKNAME(closure));
2373    fprintf(stderr,"} STARTEDAT: \t%#lx", TSO_STARTEDAT(closure));
2374    fprintf(stderr,"\tEXPORTED: \t%#lx\n", TSO_EXPORTED(closure));
2375    fprintf(stderr,"} BASICBLOCKS: \t%#lx", TSO_BASICBLOCKS(closure));
2376    fprintf(stderr,"\tALLOCS: \t%#lx\n", TSO_ALLOCS(closure));
2377    fprintf(stderr,"} EXECTIME: \t%#lx", TSO_EXECTIME(closure));
2378    fprintf(stderr,"\tFETCHTIME: \t%#lx\n", TSO_FETCHTIME(closure));
2379    fprintf(stderr,"} FETCHCOUNT: \t%#lx", TSO_FETCHCOUNT(closure));
2380    fprintf(stderr,"\tBLOCKTIME: \t%#lx\n", TSO_BLOCKTIME(closure));
2381    fprintf(stderr,"} BLOCKCOUNT: \t%#lx", TSO_BLOCKCOUNT(closure));
2382    fprintf(stderr,"\tBLOCKEDAT: \t%#lx\n", TSO_BLOCKEDAT(closure));
2383    fprintf(stderr,"} GLOBALSPARKS:\t%#lx", TSO_GLOBALSPARKS(closure));
2384    fprintf(stderr,"\tLOCALSPARKS:\t%#lx\n", TSO_LOCALSPARKS(closure));
2385  }
2386 #if defined(GRAN_CHECK)
2387  if ( verbose & 0x02 ) {
2388    fprintf(stderr,"BQ that starts with this TSO: ");
2389    PRINT_BQ(closure);
2390  }
2391 #endif
2392 }
2393
2394 void
2395 G_EVENT(event, verbose)
2396 eventq event;
2397 I_ verbose;
2398 {
2399   if (verbose) {
2400     print_event(event);
2401   }else{
2402     fprintf(stderr," %#lx",event);
2403   }
2404 }
2405
2406 void
2407 G_EVENTQ(verbose)
2408 I_ verbose;
2409 {
2410  eventq x;
2411
2412  fprintf(stderr,"Eventq (hd @%#lx):\n",EventHd);
2413  for (x=EventHd; x!=NULL; x=EVENT_NEXT(x)) {
2414    G_EVENT(x,verbose);
2415  }
2416  if (EventHd==NULL)
2417    fprintf(stderr,"NIL\n");
2418  else
2419    fprintf(stderr,"\n");
2420 }
2421
2422 void
2423 G_PE_EQ(pe,verbose)
2424 PROC pe;
2425 I_ verbose;
2426 {
2427  eventq x;
2428
2429  fprintf(stderr,"Eventq (hd @%#lx):\n",EventHd);
2430  for (x=EventHd; x!=NULL; x=EVENT_NEXT(x)) {
2431    if (EVENT_PROC(x)==pe)
2432      G_EVENT(x,verbose);
2433  }
2434  if (EventHd==NULL)
2435    fprintf(stderr,"NIL\n");
2436  else
2437    fprintf(stderr,"\n");
2438 }
2439
2440 void
2441 G_SPARK(spark, verbose)
2442 sparkq spark;
2443 I_ verbose;
2444 {
2445   if (verbose)
2446     print_spark(spark);
2447   else
2448     fprintf(stderr," %#lx",spark);
2449 }
2450
2451 void
2452 G_SPARKQ(spark,verbose)
2453 sparkq spark;
2454 I_ verbose;
2455 {
2456  sparkq x;
2457
2458  fprintf(stderr,"Sparkq (hd @%#lx):\n",spark);
2459  for (x=spark; x!=NULL; x=SPARK_NEXT(x)) {
2460    G_SPARK(x,verbose);
2461  }
2462  if (spark==NULL)
2463    fprintf(stderr,"NIL\n");
2464  else
2465    fprintf(stderr,"\n");
2466 }
2467
2468 void
2469 G_CURR_SPARKQ(verbose)
2470 I_ verbose;
2471 {
2472   G_SPARKQ(SparkQueueHd,verbose);
2473 }
2474
2475 void
2476 G_PROC(proc,verbose)
2477 I_ proc;
2478 I_ verbose;
2479 {
2480   extern char *proc_status_names[];
2481
2482   fprintf(stderr,"Status of proc %d at time %d (%#lx): %s (%s)\n",
2483           proc,CurrentTime[proc],CurrentTime[proc],
2484           (CurrentProc==proc)?"ACTIVE":"INACTIVE",
2485           proc_status_names[procStatus[proc]]);
2486   G_THREADQ(RunnableThreadsHd[proc],verbose & 0x2);
2487   if ( (CurrentProc==proc) )
2488     G_TSO(CurrentTSO,1);
2489
2490   if (EventHd!=NULL)
2491     fprintf(stderr,"Next event (%s) is on proc %d\n",
2492             event_names[EVENT_TYPE(EventHd)],EVENT_PROC(EventHd));
2493
2494   if (verbose & 0x1) {
2495     fprintf(stderr,"\nREQUIRED sparks: ");
2496     G_SPARKQ(PendingSparksHd[proc][REQUIRED_POOL],1);
2497     fprintf(stderr,"\nADVISORY_sparks: ");
2498     G_SPARKQ(PendingSparksHd[proc][ADVISORY_POOL],1);
2499   }
2500 }
2501
2502 /* Debug Processor */
2503 void
2504 GP(proc)
2505 I_ proc;
2506 { G_PROC(proc,1);
2507 }
2508
2509 /* Debug Current Processor */
2510 void
2511 GCP(){ G_PROC(CurrentProc,2); }
2512
2513 /* Debug TSO */
2514 void
2515 GT(P_ tso){
2516   G_TSO(tso,1);
2517 }
2518
2519 /* Debug CurrentTSO */
2520 void
2521 GCT(){
2522   fprintf(stderr,"Current Proc: %d\n",CurrentProc);
2523   G_TSO(CurrentTSO,1);
2524 }
2525
2526 /* Shorthand for debugging event queue */
2527 void
2528 GEQ() { G_EVENTQ(1); }
2529
2530 /* Shorthand for debugging thread queue of a processor */
2531 void
2532 GTQ(PROC p) { G_THREADQ(RunnableThreadsHd[p],1); }
2533
2534 /* Shorthand for debugging thread queue of current processor */
2535 void
2536 GCTQ() { G_THREADQ(RunnableThreadsHd[CurrentProc],1); }
2537
2538 /* Shorthand for debugging spark queue of a processor */
2539 void
2540 GSQ(PROC p) { G_SPARKQ(PendingSparksHd[p][1],1); }
2541
2542 /* Shorthand for debugging spark queue of current processor */
2543 void
2544 GCSQ() { G_CURR_SPARKQ(1); }
2545
2546 /* Shorthand for printing a node */
2547 void
2548 GN(P_ node) { G_PRINT_NODE(node); }
2549
2550 /* Shorthand for printing info table */
2551 void
2552 GIT(P_ node) { G_INFO_TABLE(node); }
2553
2554 /* Shorthand for some of ADRs debugging functions */
2555
2556 void
2557 pC(P_ closure) { printClosure(closure, 0/*indentation*/, 10/*weight*/); }
2558
2559 /*   Print a closure on  the heap */
2560 void
2561 DN(P_ closure) { DEBUG_NODE( closure, 1/*size*/ );}
2562
2563 /*      Print info-table of a closure */
2564 void
2565 DIT(P_ closure) {  DEBUG_INFO_TABLE(closure); }
2566
2567 /*              (CONCURRENT) Print a Thread State Object */
2568 void
2569 DT(P_ tso) {   DEBUG_TSO(tso); }
2570
2571 /* Not yet implemented: */
2572 /* (CONCURRENT) Print a STacK Object
2573 void
2574 DS(P_ stko) {   DEBUG_STKO(stko)                ; }
2575 */
2576
2577 #endif /* GRAN */
2578
2579 /* --------------------------- vvvv   old  vvvvv ------------------------*/
2580
2581 #if 0     /* ngo' ngoq! veQ yIboS! */
2582
2583 #define NULL_REG_MAP        /* Not threaded */
2584 #include "stgdefs.h"
2585
2586 char *
2587 info_hdr_type(info_ptr)
2588 W_ info_ptr;
2589 {
2590 #if ! defined(PAR) && !defined(GRAN)
2591   switch (INFO_TAG(info_ptr))
2592     {
2593       case INFO_OTHER_TAG:
2594         return("OTHER_TAG");
2595 /*    case INFO_IND_TAG:
2596         return("IND_TAG");
2597 */    default:
2598         return("TAG<n>");
2599     }
2600 #else /* PAR */
2601   switch(INFO_TYPE(info_ptr))
2602     {
2603       case INFO_SPEC_U_TYPE:
2604         return("SPECU");
2605
2606       case INFO_SPEC_N_TYPE:
2607         return("SPECN");
2608
2609       case INFO_GEN_U_TYPE:
2610         return("GENU");
2611
2612       case INFO_GEN_N_TYPE:
2613         return("GENN");
2614
2615       case INFO_DYN_TYPE:
2616         return("DYN");
2617
2618       /*
2619       case INFO_DYN_TYPE_N:
2620         return("DYNN");
2621
2622       case INFO_DYN_TYPE_U:
2623         return("DYNU");
2624       */
2625
2626       case INFO_TUPLE_TYPE:
2627         return("TUPLE");
2628
2629       case INFO_DATA_TYPE:
2630         return("DATA");
2631
2632       case INFO_MUTUPLE_TYPE:
2633         return("MUTUPLE");
2634
2635       case INFO_IMMUTUPLE_TYPE:
2636         return("IMMUTUPLE");
2637
2638       case INFO_STATIC_TYPE:
2639         return("STATIC");
2640
2641       case INFO_CONST_TYPE:
2642         return("CONST");
2643
2644       case INFO_CHARLIKE_TYPE:
2645         return("CHAR");
2646
2647       case INFO_INTLIKE_TYPE:
2648         return("INT");
2649
2650       case INFO_BH_TYPE:
2651         return("BHOLE");
2652
2653       case INFO_IND_TYPE:
2654         return("IND");
2655
2656       case INFO_CAF_TYPE:
2657         return("CAF");
2658
2659       case INFO_FETCHME_TYPE:
2660         return("FETCHME");
2661
2662       case INFO_BQ_TYPE:
2663         return("BQ");
2664
2665       /*
2666       case INFO_BQENT_TYPE:
2667         return("BQENT");
2668       */
2669
2670       case INFO_TSO_TYPE:
2671         return("TSO");
2672
2673       case INFO_STKO_TYPE:
2674         return("STKO");
2675
2676       default:
2677         fprintf(stderr,"Unknown header type %lu\n",INFO_TYPE(info_ptr));
2678         return("??");
2679       }
2680 #endif /* PAR */
2681 }
2682
2683 /*
2684 @var_hdr_size@ computes the size of the variable header for a closure.
2685 */
2686
2687 I_
2688 var_hdr_size(node)
2689 P_ node;
2690 {
2691   switch(INFO_TYPE(INFO_PTR(node)))
2692     {
2693       case INFO_SPEC_U_TYPE:    return(0);      /* by decree */
2694       case INFO_SPEC_N_TYPE:    return(0);
2695       case INFO_GEN_U_TYPE:     return(GEN_VHS);
2696       case INFO_GEN_N_TYPE:     return(GEN_VHS);
2697       case INFO_DYN_TYPE:       return(DYN_VHS);
2698       /*
2699       case INFO_DYN_TYPE_N:     return(DYN_VHS);
2700       case INFO_DYN_TYPE_U:     return(DYN_VHS);
2701       */
2702       case INFO_TUPLE_TYPE:     return(TUPLE_VHS);
2703       case INFO_DATA_TYPE:      return(DATA_VHS);
2704       case INFO_MUTUPLE_TYPE:   return(MUTUPLE_VHS);
2705       case INFO_IMMUTUPLE_TYPE: return(MUTUPLE_VHS); /* same layout */
2706       case INFO_STATIC_TYPE:    return(STATIC_VHS);
2707       case INFO_CONST_TYPE:     return(0);
2708       case INFO_CHARLIKE_TYPE:  return(0);
2709       case INFO_INTLIKE_TYPE:   return(0);
2710       case INFO_BH_TYPE:        return(0);
2711       case INFO_IND_TYPE:       return(0);
2712       case INFO_CAF_TYPE:       return(0);
2713       case INFO_FETCHME_TYPE:   return(0);
2714       case INFO_BQ_TYPE:        return(0);
2715       /*
2716       case INFO_BQENT_TYPE:     return(0);
2717       */
2718       case INFO_TSO_TYPE:       return(TSO_VHS);
2719       case INFO_STKO_TYPE:      return(STKO_VHS);
2720       default:
2721         fprintf(stderr,"Unknown info type 0x%lx (%lu)\n", INFO_PTR(node),
2722           INFO_TYPE(INFO_PTR(node)));
2723         return(0);
2724     }
2725 }
2726
2727
2728 /* Determine the size and number of pointers for this kind of closure */
2729 void
2730 size_and_ptrs(node,size,ptrs)
2731 P_ node;
2732 W_ *size, *ptrs;
2733 {
2734   switch(INFO_TYPE(INFO_PTR(node)))
2735     {
2736       case INFO_SPEC_U_TYPE:
2737       case INFO_SPEC_N_TYPE:
2738         *size = INFO_SIZE(INFO_PTR(node));          /* New for 0.24; check */
2739         *ptrs = INFO_NoPTRS(INFO_PTR(node));        /* that! -- HWL */
2740         /*
2741         *size = SPEC_CLOSURE_SIZE(node);
2742         *ptrs = SPEC_CLOSURE_NoPTRS(node);
2743         */
2744         break;
2745
2746       case INFO_GEN_U_TYPE:
2747       case INFO_GEN_N_TYPE:
2748         *size = GEN_CLOSURE_SIZE(node);
2749         *ptrs = GEN_CLOSURE_NoPTRS(node);
2750         break;
2751
2752       /*
2753       case INFO_DYN_TYPE_U:
2754       case INFO_DYN_TYPE_N:
2755       */
2756       case INFO_DYN_TYPE:
2757         *size = DYN_CLOSURE_SIZE(node);
2758         *ptrs = DYN_CLOSURE_NoPTRS(node);
2759         break;
2760
2761       case INFO_TUPLE_TYPE:
2762         *size = TUPLE_CLOSURE_SIZE(node);
2763         *ptrs = TUPLE_CLOSURE_NoPTRS(node);
2764         break;
2765
2766       case INFO_DATA_TYPE:
2767         *size = DATA_CLOSURE_SIZE(node);
2768         *ptrs = DATA_CLOSURE_NoPTRS(node);
2769         break;
2770
2771       case INFO_IND_TYPE:
2772         *size = IND_CLOSURE_SIZE(node);
2773         *ptrs = IND_CLOSURE_NoPTRS(node);
2774         break;
2775
2776 /* ToDo: more (WDP) */
2777
2778       /* Don't know about the others */
2779       default:
2780         *size = *ptrs = 0;
2781         break;
2782     }
2783 }
2784
2785 void
2786 DEBUG_PRINT_NODE(node)
2787 P_ node;
2788 {
2789    W_ info_ptr = INFO_PTR(node);
2790    I_ size = 0, ptrs = 0, i, vhs = 0;
2791    char *info_type = info_hdr_type(info_ptr);
2792
2793    size_and_ptrs(node,&size,&ptrs);
2794    vhs = var_hdr_size(node);
2795
2796    fprintf(stderr,"Node: 0x%lx", (W_) node);
2797
2798 #if defined(PAR)
2799    fprintf(stderr," [GA: 0x%lx]",GA(node));
2800 #endif
2801
2802 #if defined(PROFILING)
2803    fprintf(stderr," [CC: 0x%lx]",CC_HDR(node));
2804 #endif
2805
2806 #if defined(GRAN)
2807    fprintf(stderr," [Bitmask: 0%lo]",PROCS(node));
2808 #endif
2809
2810    fprintf(stderr," IP: 0x%lx (%s), size %ld, %ld ptrs\n",
2811                   info_ptr,info_type,size,ptrs);
2812
2813    /* For now, we ignore the variable header */
2814
2815    for(i=0; i < size; ++i)
2816      {
2817        if(i == 0)
2818          fprintf(stderr,"Data: ");
2819
2820        else if(i % 6 == 0)
2821          fprintf(stderr,"\n      ");
2822
2823        if(i < ptrs)
2824          fprintf(stderr," 0x%lx[P]",*(node+_FHS+vhs+i));
2825        else
2826          fprintf(stderr," %lu[D]",*(node+_FHS+vhs+i));
2827      }
2828    fprintf(stderr, "\n");
2829 }
2830
2831
2832 #define INFO_MASK       0x80000000
2833
2834 void
2835 DEBUG_TREE(node)
2836 P_ node;
2837 {
2838   W_ size = 0, ptrs = 0, i, vhs = 0;
2839
2840   /* Don't print cycles */
2841   if((INFO_PTR(node) & INFO_MASK) != 0)
2842     return;
2843
2844   size_and_ptrs(node,&size,&ptrs);
2845   vhs = var_hdr_size(node);
2846
2847   DEBUG_PRINT_NODE(node);
2848   fprintf(stderr, "\n");
2849
2850   /* Mark the node -- may be dangerous */
2851   INFO_PTR(node) |= INFO_MASK;
2852
2853   for(i = 0; i < ptrs; ++i)
2854     DEBUG_TREE((P_)node[i+vhs+_FHS]);
2855
2856   /* Unmark the node */
2857   INFO_PTR(node) &= ~INFO_MASK;
2858 }
2859
2860
2861 void
2862 DEBUG_INFO_TABLE(node)
2863 P_ node;
2864 {
2865   W_ info_ptr = INFO_PTR(node);
2866   char *ip_type = info_hdr_type(info_ptr);
2867
2868   fprintf(stderr,"%s Info Ptr @0x%lx; Entry: 0x%lx; Size: %lu; Ptrs: %lu\n\n",
2869                  ip_type,info_ptr,(W_) ENTRY_CODE(info_ptr),INFO_SIZE(info_ptr),INFO_NoPTRS(info_ptr));
2870 #if defined(PAR)
2871   fprintf(stderr,"Enter Flush Entry: 0x%lx;\tExit Flush Entry: 0x%lx\n",INFO_FLUSHENT(info_ptr),INFO_FLUSH(info_ptr));
2872 #endif
2873
2874 #if defined(PROFILING)
2875   fprintf(stderr,"Cost Centre (???):       0x%lx\n",INFO_CAT(info_ptr));
2876 #endif
2877
2878 #if defined(_INFO_COPYING)
2879   fprintf(stderr,"Evacuate Entry:    0x%lx;\tScavenge Entry: 0x%lx\n",
2880           INFO_EVAC_2S(info_ptr),INFO_SCAV_2S(info_ptr));
2881 #endif
2882
2883 #if defined(_INFO_COMPACTING)
2884   fprintf(stderr,"Scan Link:         0x%lx;\tScan Move:      0x%lx\n",
2885           (W_) INFO_SCAN_LINK_1S(info_ptr), (W_) INFO_SCAN_MOVE_1S(info_ptr));
2886   fprintf(stderr,"Mark:              0x%lx;\tMarked:         0x%lx;\t",
2887           (W_) INFO_MARK_1S(info_ptr), (W_) INFO_MARKED_1S(info_ptr));
2888 #if 0 /* avoid INFO_TYPE */
2889   if(BASE_INFO_TYPE(info_ptr)==INFO_SPEC_TYPE)
2890     fprintf(stderr,"plus specialised code\n");
2891   else
2892     fprintf(stderr,"Marking:           0x%lx\n",(W_) INFO_MARKING_1S(info_ptr));
2893 #endif /* 0 */
2894 #endif /* _INFO_COMPACTING */
2895 }
2896
2897 \end{code}
2898
2899 The remaining debugging routines are more or less specific for GrAnSim.
2900
2901 \begin{code}
2902 #if defined(GRAN) && defined(GRAN_CHECK)
2903 void
2904 DEBUG_CURR_THREADQ(verbose)
2905 I_ verbose;
2906 {
2907   fprintf(stderr,"Thread Queue on proc %d: ", CurrentProc);
2908   DEBUG_THREADQ(ThreadQueueHd, verbose);
2909 }
2910
2911 void
2912 DEBUG_THREADQ(closure, verbose)
2913 P_ closure;
2914 I_ verbose;
2915 {
2916  P_ x;
2917
2918  fprintf(stderr,"Thread Queue: ");
2919  for (x=closure; x!=PrelBase_Z91Z93_closure; x=TSO_LINK(x))
2920    if (verbose)
2921      DEBUG_TSO(x,0);
2922    else
2923      fprintf(stderr," 0x%x",x);
2924
2925  if (closure==PrelBase_Z91Z93_closure)
2926    fprintf(stderr,"NIL\n");
2927  else
2928    fprintf(stderr,"\n");
2929 }
2930
2931 /* Check with Threads.lh */
2932 static char *type_name[] = { "T_MAIN", "T_REQUIRED", "T_ADVISORY", "T_FAIL"};
2933
2934 void
2935 DEBUG_TSO(closure,verbose)
2936 P_ closure;
2937 I_ verbose;
2938 {
2939
2940  if (closure==PrelBase_Z91Z93_closure) {
2941    fprintf(stderr,"TSO at 0x%x is PrelBase_Z91Z93_closure!\n");
2942    return;
2943  }
2944
2945  fprintf(stderr,"TSO at 0x%x has the following contents:\n",closure);
2946
2947  fprintf(stderr,"> Name: 0x%x",TSO_NAME(closure));
2948  fprintf(stderr,"\tLink: 0x%x\n",TSO_LINK(closure));
2949  fprintf(stderr,"> Id: 0x%x",TSO_ID(closure));
2950 #if defined(GRAN_CHECK) && defined(GRAN)
2951  if (RTSflags.GranFlags.debug & 0x10)
2952    fprintf(stderr,"\tType: %s  %s\n",
2953            type_name[TSO_TYPE(closure) & ~FETCH_MASK_TSO],
2954            (TSO_TYPE(closure) & FETCH_MASK_TSO) ? "SLEEPING" : "");
2955  else
2956    fprintf(stderr,"\tType: %s\n",type_name[TSO_TYPE(closure)]);
2957 #else
2958  fprintf(stderr,"\tType: %s\n",type_name[TSO_TYPE(closure)]);
2959 #endif
2960  fprintf(stderr,"> PC1:  0x%x",TSO_PC1(closure));
2961  fprintf(stderr,"\tPC2:  0x%x\n",TSO_PC2(closure));
2962  fprintf(stderr,"> ARG1: 0x%x",TSO_ARG1(closure));
2963  /* fprintf(stderr,"\tARG2: 0x%x\n",TSO_ARG2(closure)); */
2964  fprintf(stderr,"> SWITCH: 0x%x\n", TSO_SWITCH(closure));
2965
2966  if (verbose) {
2967    fprintf(stderr,"} LOCKED: 0x%x",TSO_LOCKED(closure));
2968    fprintf(stderr,"\tSPARKNAME: 0x%x\n", TSO_SPARKNAME(closure));
2969    fprintf(stderr,"} STARTEDAT: 0x%x", TSO_STARTEDAT(closure));
2970    fprintf(stderr,"\tEXPORTED: 0x%x\n", TSO_EXPORTED(closure));
2971    fprintf(stderr,"} BASICBLOCKS: 0x%x", TSO_BASICBLOCKS(closure));
2972    fprintf(stderr,"\tALLOCS: 0x%x\n", TSO_ALLOCS(closure));
2973    fprintf(stderr,"} EXECTIME: 0x%x", TSO_EXECTIME(closure));
2974    fprintf(stderr,"\tFETCHTIME: 0x%x\n", TSO_FETCHTIME(closure));
2975    fprintf(stderr,"} FETCHCOUNT: 0x%x", TSO_FETCHCOUNT(closure));
2976    fprintf(stderr,"\tBLOCKTIME: 0x%x\n", TSO_BLOCKTIME(closure));
2977    fprintf(stderr,"} BLOCKCOUNT: 0x%x", TSO_BLOCKCOUNT(closure));
2978    fprintf(stderr,"\tBLOCKEDAT: 0x%x\n", TSO_BLOCKEDAT(closure));
2979    fprintf(stderr,"} GLOBALSPARKS: 0x%x", TSO_GLOBALSPARKS(closure));
2980    fprintf(stderr,"\tLOCALSPARKS: 0x%x\n", TSO_LOCALSPARKS(closure));
2981  }
2982 }
2983
2984 void
2985 DEBUG_EVENT(event, verbose)
2986 eventq event;
2987 I_ verbose;
2988 {
2989   if (verbose) {
2990     print_event(event);
2991   }else{
2992     fprintf(stderr," 0x%x",event);
2993   }
2994 }
2995
2996 void
2997 DEBUG_EVENTQ(verbose)
2998 I_ verbose;
2999 {
3000  eventq x;
3001
3002  fprintf(stderr,"Eventq (hd @0x%x):\n",EventHd);
3003  for (x=EventHd; x!=NULL; x=EVENT_NEXT(x)) {
3004    DEBUG_EVENT(x,verbose);
3005  }
3006  if (EventHd==NULL)
3007    fprintf(stderr,"NIL\n");
3008  else
3009    fprintf(stderr,"\n");
3010 }
3011
3012 void
3013 DEBUG_SPARK(spark, verbose)
3014 sparkq spark;
3015 I_ verbose;
3016 {
3017   if (verbose)
3018     print_spark(spark);
3019   else
3020     fprintf(stderr," 0x%x",spark);
3021 }
3022
3023 void
3024 DEBUG_SPARKQ(spark,verbose)
3025 sparkq spark;
3026 I_ verbose;
3027 {
3028  sparkq x;
3029
3030  fprintf(stderr,"Sparkq (hd @0x%x):\n",spark);
3031  for (x=spark; x!=NULL; x=SPARK_NEXT(x)) {
3032    DEBUG_SPARK(x,verbose);
3033  }
3034  if (spark==NULL)
3035    fprintf(stderr,"NIL\n");
3036  else
3037    fprintf(stderr,"\n");
3038 }
3039
3040 void
3041 DEBUG_CURR_SPARKQ(verbose)
3042 I_ verbose;
3043 {
3044   DEBUG_SPARKQ(SparkQueueHd,verbose);
3045 }
3046
3047 void
3048 DEBUG_PROC(proc,verbose)
3049 I_ proc;
3050 I_ verbose;
3051 {
3052   fprintf(stderr,"Status of proc %d at time %d (0x%x): %s\n",
3053           proc,CurrentTime[proc],CurrentTime[proc],
3054           (CurrentProc==proc)?"ACTIVE":"INACTIVE");
3055   DEBUG_THREADQ(RunnableThreadsHd[proc],verbose & 0x2);
3056   if ( (CurrentProc==proc) )
3057     DEBUG_TSO(CurrentTSO,1);
3058
3059   if (EventHd!=NULL)
3060     fprintf(stderr,"Next event (%s) is on proc %d\n",
3061             event_names[EVENT_TYPE(EventHd)],EVENT_PROC(EventHd));
3062
3063   if (verbose & 0x1) {
3064     fprintf(stderr,"\nREQUIRED sparks: ");
3065     DEBUG_SPARKQ(PendingSparksHd[proc][REQUIRED_POOL],1);
3066     fprintf(stderr,"\nADVISORY_sparks: ");
3067     DEBUG_SPARKQ(PendingSparksHd[proc][ADVISORY_POOL],1);
3068   }
3069 }
3070
3071 /* Debug CurrentTSO */
3072 void
3073 DCT(){
3074   fprintf(stderr,"Current Proc: %d\n",CurrentProc);
3075   DEBUG_TSO(CurrentTSO,1);
3076 }
3077
3078 /* Debug Current Processor */
3079 void
3080 DCP(){ DEBUG_PROC(CurrentProc,2); }
3081
3082 /* Shorthand for debugging event queue */
3083 void
3084 DEQ() { DEBUG_EVENTQ(1); }
3085
3086 /* Shorthand for debugging spark queue */
3087 void
3088 DSQ() { DEBUG_CURR_SPARKQ(1); }
3089
3090 /* Shorthand for printing a node */
3091 void
3092 DN(P_ node) { DEBUG_PRINT_NODE(node); }
3093
3094 #endif /* GRAN */
3095
3096 #endif /* 0 */
3097 \end{code}
3098