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_MP()                    Print the MallocPtr 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_PTRS(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_PTRS(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 %d\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 # else
 731   PP_ SpA  = SAVE_SpA;
 732   PP_ SuA  = SAVE_SuA;
 733   P_  SpB  = SAVE_SpB;
 734   P_  SuB  = SAVE_SuB;
 735 # endif
 736   P_  Hp   = SAVE_Hp;
 737
 738   PP_ botA = stackInfo.botA;
 739   P_ botB  = stackInfo.botB;
 740   P_ HpBot = HP_BOT;
 741
 742   char *name;
 743
 744   /* ToDo: check if it's in text or data segment. */
 745
 746   /* The @-1@s in stack comparisions are because we sometimes use the
 747      address of just below the stack... */
 748
 749 #if 0
 750   if (lookupForName( address, &name )) {
 751     printZcoded( name );
 752   }
 753   else
 754 #endif
 755   {
 756     if (DEBUG_details > 1) {
 757       printWord( (W_) address );
 758       printf(" : ");
 759     }
 760     if (HpBot <= address && address < Hp) {
 761       printf("Hp[%d]", address - HpBot);
 762     } else if (SUBTRACT_A_STK((PP_)address, botA) >= -1 && SUBTRACT_A_STK(SpA, (PP_)address) >= 0) {
 763       printf("SpA[%d]", SUBTRACT_A_STK((PP_)address, botA));
 764     } else if (SUBTRACT_B_STK(address, botB) >= -1 && SUBTRACT_B_STK(SpB, address) >= 0) {
 765       /* ToDo: check if it's an update frame */
 766       printf("SpB[%d]", SUBTRACT_B_STK(address, botB));
 767     } else {
 768       printWord( (W_) address );
 769     }
 770   }
 771 }
 772
 773 static void
 774 printIndentation( int indentation )
 775 {
 776   int i;
 777   for (i = 0; i < indentation; ++i) { printf("  "); }
 778 }
 779
 780 /* The weight parameter is used to (eventually) break cycles */
 781 static void
 782 printStandardShapeClosure(
 783       int indentation,
 784       int weight,
 785       P_ closure, int vhs, int size, int noPtrs
 786 )
 787 {
 788 #ifdef CONCURRENT
 789   PP_ SpA  = STKO_SpA(SAVE_StkO);
 790   PP_ SuA  = STKO_SuA(SAVE_StkO);
 791   P_  SpB  = STKO_SpB(SAVE_StkO);
 792   P_  SuB  = STKO_SuB(SAVE_StkO);
 793 #else
 794   PP_ SpA  = SAVE_SpA;
 795   PP_ SuA  = SAVE_SuA;
 796   P_  SpB  = SAVE_SpB;
 797   P_  SuB  = SAVE_SuB;
 798 #endif
 799   P_ Hp    = SAVE_Hp;
 800
 801   extern void printClosure PROTO( (P_, int, int) );
 802   int numValues = size - vhs;
 803   P_ HpBot = HP_BOT;
 804
 805   if (DEBUG_details > 1) {
 806     printAddress( closure );
 807     printf(": ");
 808   }
 809   printName((P_)INFO_PTR(closure));
 810
 811   if ( numValues > 0 ) {
 812     int newWeight = weight-1 ;
 813         /* I've tried dividing the weight by size to share it out amongst
 814            sub-closures - but that didn't work too well. */
 815
 816     if (newWeight > 0) {
 817       int i=0;
 818       printf("(\n");
 819       while (i < numValues) {
 820         P_ data = (P_) closure[_FHS + vhs + i];
 821
 822         printIndentation(indentation+1);
 823         if (i < noPtrs) {
 824           printClosure( data, indentation+1, newWeight);
 825         } else {
 826           printAddress( data );
 827         }
 828         i = i + 1;
 829         if (i < numValues) printf(",\n");
 830       }
 831       printf(")");
 832     } else {
 833       int i;
 834       printf("(_");
 835       for( i = 1; i < size; ++i ) {
 836         printf(",_");
 837       }
 838       printf(")");
 839     }
 840   }
 841 }
 842
 843 /* Should be static but has to be extern to allow mutual recursion */
 844 void
 845 printClosure( P_ closure, int indentation, int weight )
 846 {
 847   int vhs, size, ptrs;
 848   char *type;
 849
 850   /* I'd love to put a test here that this actually _is_ a closure -
 851      but testing that it is in the heap is overly strong. */
 852
 853   getClosureShape(closure, &vhs, &size, &ptrs, &type);
 854
 855   /* The order here precisely reflects that in SMInfoTables.lh to make
 856      it easier to check that this list is complete. */
 857   switch(INFO_TYPE(INFO_PTR(closure))) {
 858   case INFO_SPEC_U_TYPE:
 859   case INFO_SPEC_N_TYPE:
 860   case INFO_GEN_U_TYPE:
 861   case INFO_GEN_N_TYPE:
 862   case INFO_DYN_TYPE:
 863   case INFO_TUPLE_TYPE:
 864   case INFO_DATA_TYPE:
 865   case INFO_MUTUPLE_TYPE:
 866   case INFO_IMMUTUPLE_TYPE:
 867     printStandardShapeClosure(indentation, weight, closure,
 868                               vhs, size, ptrs);
 869     break;
 870
 871   case INFO_STATIC_TYPE:
 872     /* If the STATIC contains Floats or Doubles, we can't print it. */
 873     /* And we can't always rely on the size/ptrs info either */
 874     printAddress( closure );
 875     printf(" STATIC");
 876     break;
 877
 878   case INFO_CONST_TYPE:
 879     if (DEBUG_details > 1) {
 880       printAddress( closure );
 881       printf(": ");
 882     }
 883     printName((P_)INFO_PTR(closure));
 884     break;
 885
 886   case INFO_CHARLIKE_TYPE:
 887     /* ToDo: check for non-printable characters */
 888     if (DEBUG_details > 1) printf("CHARLIKE ");
 889     printf("\'%c\'", (unsigned char) CHARLIKE_VALUE(closure));
 890     break;
 891
 892   case INFO_INTLIKE_TYPE:
 893     if (DEBUG_details > 1) printf("INTLIKE ");
 894     printf("%d",INTLIKE_VALUE(closure));
 895     break;
 896
 897   case INFO_BH_TYPE:
 898     /* Is there anything to say here> */
 899     if (DEBUG_details > 1) {
 900       printAddress( closure );
 901       printf(": ");
 902     }
 903     printName((P_)INFO_PTR(closure));
 904     break;
 905
 906 /* most of the following are just plausible guesses (particularily VHSs) ADR */
 907
 908   case INFO_BQ_TYPE:
 909 #ifdef CONCURRENT
 910     printStandardShapeClosure(indentation, weight, closure,
 911                               vhs, size, ptrs);
 912 #else
 913     printf("Panic: found BQ Infotable in non-threaded system.\n");
 914 #endif
 915     break;
 916
 917   case INFO_IND_TYPE:
 918     if (DEBUG_details > 0) {
 919       printAddress( closure );
 920       printf(" IND: ");
 921     }
 922     printClosure( (P_) IND_CLOSURE_PTR(closure), indentation, weight );
 923     break;
 924
 925   case INFO_CAF_TYPE:
 926     if (DEBUG_details > 0) {
 927       printAddress( closure );
 928       printf(" CAF: ");
 929     }
 930     printClosure( (P_) IND_CLOSURE_PTR(closure), indentation, weight );
 931     break;
 932
 933   case INFO_FETCHME_TYPE:
 934 #ifdef PAR
 935     printStandardShapeClosure(indentation, weight, closure,
 936                               vhs, size, ptrs);
 937 #else
 938     printf("Panic: found FETCHME Infotable in sequential system.\n");
 939 #endif
 940     break;
 941
 942   case INFO_FMBQ_TYPE:
 943 #ifdef PAR
 944     printStandardShapeClosure(indentation, weight, closure,
 945                               vhs, size, ptrs);
 946 #else
 947     printf("Panic: found FMBQ Infotable in sequential system.\n");
 948 #endif
 949     break;
 950
 951   case INFO_BF_TYPE:
 952 #ifdef PAR
 953     printStandardShapeClosure(indentation, weight, closure,
 954                               vhs, size, ptrs);
 955 #else
 956     printf("Panic: found BlockedFetch Infotable in sequential system.\n");
 957 #endif
 958     break;
 959
 960   case INFO_TSO_TYPE:
 961 #ifdef CONCURRENT
 962     /* A TSO contains a regtable... */
 963     printAddress( closure );
 964     printf(" TSO: ...");
 965 #else
 966     printf("Panic: found TSO Infotable in non-threaded system.\n");
 967 #endif
 968     break;
 969
 970     case INFO_STKO_TYPE:
 971 #ifdef CONCURRENT
 972     /* A STKO contains parts of the A and B stacks... */
 973     printAddress( closure );
 974     printf(" STKO: ...");
 975 #else
 976     printf("Panic: found STKO Infotable in non-threaded system.\n");
 977 #endif
 978     break;
 979
 980   /* There are no others in SMInfoTables.lh 11/5/94 ADR*/
 981   default:
 982     printf("Invalid/unknown info type %d\n", INFO_TYPE(INFO_PTR(closure)));
 983     break;
 984   }
 985 }
 986
 987 void
 988 DEBUG_NODE( P_ closure, int size )
 989 {
 990   printClosure( closure, 0, size );
 991   printf("\n");
 992 }
 993 \end{code}
 994
 995 Now some stuff for printing stacks - almost certainly doesn't work
 996 under threads which keep the stack on the heap.
 997
 998 \begin{code}
 999 #ifndef CONCURRENT
1000
1001 static int
1002 minimum(int a, int b)
1003 {
1004   if (a < b) {
1005     return a;
1006   } else {
1007     return b;
1008   }
1009 }
1010
1011 void
1012 DEBUG_PrintA( int depth, int weight )
1013 {
1014   PP_ SpA  = SAVE_SpA;
1015   PP_ SuA  = SAVE_SuA;
1016   P_  SpB  = SAVE_SpB;
1017   P_  SuB  = SAVE_SuB;
1018   P_ Hp    = SAVE_Hp;
1019
1020   int i;
1021   I_ size = minimum(depth, SUBTRACT_A_STK(SpA, stackInfo.botA)+1);
1022
1023   printf("Dump of the Address Stack (SpA = 0x%x, SuA = 0x%x)\n", SpA, SuA);
1024
1025   for( i = 0; i < size; ++i ) {
1026     printIndentation(1);
1027     printf("SpA[%ld] (0x%08lx):", i, SpA + AREL(i));
1028     printClosure((P_)*(SpA + AREL(i)), 2, weight);
1029     printf("\n");
1030   }
1031 }
1032
1033 void
1034 DEBUG_PrintB( int depth, int weight )
1035 {
1036   PP_ SpA  = SAVE_SpA;
1037   PP_ SuA  = SAVE_SuA;
1038   P_  SpB  = SAVE_SpB;
1039   P_  SuB  = SAVE_SuB;
1040   P_ Hp    = SAVE_Hp;
1041
1042   I_ i;
1043   I_ size = minimum(depth, SUBTRACT_B_STK(SpB, stackInfo.botB)+1);
1044
1045   P_ updateFramePtr;
1046   I_ update_count;
1047
1048   printf("Dump of the Value Stack (SpB = 0x%x, SuB = 0x%x)\n", SpB, SuB);
1049
1050   updateFramePtr = SuB;
1051   update_count = 0;
1052   i = 0;
1053   while (i < size) {
1054     if (updateFramePtr == SpB + BREL(i)) {
1055
1056       printIndentation(1);
1057       printf("SpB[%ld] (0x%08lx): UpdateFrame[%d](",
1058              i,
1059              updateFramePtr,
1060              update_count
1061              );
1062       printName( (P_) *(SpB + BREL(i)) );
1063       printf(", UF[%d] (= SpB[%ld]), SpA[%ld], ",
1064              update_count+1,
1065              SUBTRACT_B_STK(SpB, GRAB_SuB(updateFramePtr)),
1066              SUBTRACT_A_STK(SpA, GRAB_SuA(updateFramePtr))
1067              );
1068       printAddress( GRAB_UPDATEE(updateFramePtr) );
1069       printf(")\n");
1070
1071       printIndentation(2);
1072       printClosure( GRAB_UPDATEE(updateFramePtr), 3, weight );
1073       printf("\n");
1074
1075       updateFramePtr = GRAB_SuB(updateFramePtr);
1076       update_count = update_count + 1;
1077
1078       /* ToDo: GhcConstants.lh reveals that there are two other sizes possible */
1079       i = i + STD_UF_SIZE;
1080     } else {
1081       printIndentation(1);
1082       printf("SpB[%ld] (0x%08lx): ", i, SpB + BREL(i) );
1083       printName((P_) *(SpB + BREL(i)) );
1084       printf("\n");
1085       i = i + 1;
1086     }
1087   }
1088 }
1089 #endif /* not CONCURRENT */
1090 \end{code}
1091
1092 ToDo:
1093
1094    All the following code incorrectly assumes that the only return
1095    addresses are those associated with update frames.
1096
1097    To do a proper job of printing the environment we need to:
1098
1099    1) Recognise vectored and non-vectored returns on the B stack.
1100
1101    2) Know where the local variables are in the A and B stacks for
1102       each return situation.
1103
1104    Until then, we'll just need to look suspiciously at the
1105    "environment" being printed out.
1106
1107    ADR
1108
1109 \begin{code}
1110 /* How many real stacks are there on SpA and SpB? */
1111 static int
1112 numStacks( )
1113 {
1114 #ifdef CONCURRENT
1115   PP_ SpA  = STKO_SpA(SAVE_StkO);
1116   PP_ SuA  = STKO_SuA(SAVE_StkO);
1117   P_  SpB  = STKO_SpB(SAVE_StkO);
1118   P_  SuB  = STKO_SuB(SAVE_StkO);
1119 #else
1120   PP_ SpA  = SAVE_SpA;
1121   PP_ SuA  = SAVE_SuA;
1122   P_  SpB  = SAVE_SpB;
1123   P_  SuB  = SAVE_SuB;
1124 #endif
1125   P_  Hp   = SAVE_Hp;
1126
1127   int depth = 1; /* There's always at least one stack */
1128
1129   while (SUBTRACT_B_STK(SuB, stackInfo.botB) >= 0) {
1130     SuB = GRAB_SuB( SuB );
1131     depth = depth + 1;
1132   }
1133   return depth;
1134 }
1135
1136 static void
1137 printLocalAStack( int depth, int indentation, int weight, PP_ SpA, int size )
1138 {
1139   int i;
1140
1141   ASSERT( size >= 0 );
1142
1143   for( i = size-1; i >= 0; --i ) {
1144     printIndentation( indentation );
1145     printf("A[%ld][%ld]", depth, i);
1146     if (DEBUG_details > 1) printf(" (0x%08lx) ", SpA + AREL(i) );
1147     printf("=");
1148     printClosure( *(SpA + AREL(i)), indentation+2, weight );
1149     printf("\n");
1150   }
1151 }
1152
1153 static void
1154 printLocalBStack( int depth, int indentation, int weight, P_ SpB, int size )
1155 {
1156   int i;
1157
1158   ASSERT( size >= 0 );
1159
1160   for( i = size-1; i >= 0; --i) {
1161     printIndentation( indentation );
1162     printf("B[%ld][%ld]", depth, i);
1163     if (DEBUG_details > 1) printf(" (0x%08lx) ", SpB + BREL(i) );
1164     printf("=");
1165     printAddress( (P_) *(SpB + BREL(i)) );
1166     printf("\n");
1167   }
1168 }
1169
1170 static void
1171 printEnvironment( int depth, int indentation, int weight, PP_ SpA, PP_ SuA, P_ SpB, P_ SuB )
1172 {
1173   int sizeA = SUBTRACT_A_STK(SpA, SuA);
1174   int sizeB = SUBTRACT_B_STK(SpB, SuB);
1175
1176   if (sizeA + sizeB > 0) {
1177     printIndentation( indentation );
1178     printf("let\n");
1179
1180     printLocalAStack( depth, indentation+1, weight, SpA, sizeA );
1181     printLocalBStack( depth, indentation+1, weight, SpB, sizeB );
1182
1183     printIndentation( indentation );
1184     printf("in\n");
1185   }
1186 }
1187 \end{code}
1188
1189 Printing the current context is a little tricky.
1190
1191 Ideally, we would work from the bottom of the stack up to the top
1192 recursively printing the stuff nearer the top.
1193
1194 In practice, we have to work from the top down because the top
1195 contains info about how much data is below the current return address.
1196
1197 The result is that we have two recursive passes over the stacks: the
1198 first one prints the "cases" and the second one prints the
1199 continuations (vector tables, etc.)
1200
1201 Note that because we compress chains of update frames, the depth and
1202 indentation do not always change in step.
1203
1204 ToDo:
1205
1206 * detecting non-updating cases too
1207 * printing continuations (from vector tables) properly
1208 * printing sensible names in environment.
1209 * fix bogus nature of lets
1210
1211
1212 \begin{code}
1213 static int maxDepth = 5;
1214
1215 static int
1216 printCases( int depth, int weight, PP_ SpA, PP_ SuA, P_ SpB, P_ SuB )
1217 {
1218   int indentation;
1219
1220   if (depth < maxDepth && SUBTRACT_B_STK(SuB, stackInfo.botB) >= 0) {
1221     PP_ nextSpA, nextSuA;
1222     P_  nextSpB, nextSuB;
1223
1224     /* ToDo: GhcConstants.lh reveals that there are two other sizes of
1225        update frame possible */
1226     /* ToDo: botB is probably wrong in THREAD system */
1227
1228     nextSpB = SuB + BREL(STD_UF_SIZE);
1229     nextSuB = GRAB_SuB( SuB );
1230     nextSpA = SuA;
1231     nextSuA = GRAB_SuA( nextSuB );
1232
1233     indentation = printCases( depth+1, weight, nextSpA, nextSuA, nextSpB, nextSuB );
1234
1235     if (DEBUG_details > 1 || nextSpB != nextSuB) { /* show frame (even if adjacent to another) */
1236       printIndentation( indentation );
1237       printf("case\n");
1238       indentation = indentation + 1;
1239     }
1240     if (SpB != SuB) {
1241       /* next thing on stack is a return vector - no need to show it here. */
1242       SpB = SpB + BREL(1);
1243     }
1244     printEnvironment( depth, indentation, weight, SpA, SuA, SpB, SuB );
1245   } else {
1246     printf("...\n");
1247     indentation = 1;
1248   }
1249
1250   return indentation;
1251 }
1252
1253 /* ToDo: pay more attention to format of vector tables in SMupdate.lh */
1254
1255 static int
1256 isVTBLEntry( P_ entry )
1257 {
1258   char *raw;
1259
1260   if (lookupForName( entry, &raw )) {
1261     if ( strncmp( "_ret", raw, 4 ) == 0 ) {
1262       return 1;
1263     } else if ( strncmp( "_djn", raw, 4 ) == 0) {
1264       return 1;
1265     } else {
1266       return 0;
1267     }
1268   } else {
1269     return 0;
1270   }
1271 }
1272
1273 static void
1274 printVectorTable( int indentation, PP_ vtbl )
1275 {
1276   if (isVTBLEntry( (P_) vtbl )) { /* Direct return */
1277     printName( (P_) vtbl );
1278   } else {
1279     int i = 0;
1280     while( isVTBLEntry( vtbl[RVREL(i)] )) {
1281       printIndentation( indentation );
1282       printf( "%d -> ", i );
1283       printName( vtbl[RVREL(i)] );
1284       printf( "\n" );
1285       i = i + 1;
1286     }
1287   }
1288 }
1289
1290 static void
1291 printContinuations( int depth, int indentation, int weight, PP_ SpA, PP_ SuA, P_ SpB, P_ SuB )
1292 {
1293   if (depth < maxDepth && SUBTRACT_B_STK(SuB, stackInfo.botB) >= 0) {
1294     PP_ nextSpA, nextSuA;
1295     P_  nextSpB, nextSuB;
1296     int nextIndent = indentation; /* Indentation to print next frame at */
1297
1298     /* ToDo: GhcConstants.lh reveals that there are two other sizes of
1299        update frame possible */
1300     /* ToDo: botB is probably wrong in THREAD system */
1301
1302     /* ToDo: ASSERT that SuA == nextSuA */
1303
1304     nextSpB = SuB + BREL(STD_UF_SIZE);
1305     nextSuB = GRAB_SuB( SuB );
1306     nextSpA = SuA;
1307     nextSuA = GRAB_SuA( nextSuB );
1308
1309     if (DEBUG_details > 0) { /* print update information */
1310
1311       if (SpB != SuB) { /* start of chain of update frames */
1312         printIndentation( indentation );
1313         printf("of updatePtr ->\n");
1314         printIndentation( indentation+1 );
1315         printf("update\n");
1316       }
1317       printIndentation( indentation+2 );
1318       printClosure( (P_)*(SuB + BREL(UF_UPDATEE)), indentation+2, weight );
1319       printf(" := ");
1320       printName( (P_) *(SuB + BREL(UF_RET)) );
1321       printf("(updatePtr)\n");
1322
1323       if (nextSpB != nextSuB) { /* end of chain of update frames */
1324         nextIndent = nextIndent-1;
1325         printVectorTable( indentation+1, (PP_) *(nextSpB) );
1326       }
1327     } else {
1328       if (nextSpB != nextSuB) { /* end of chain of update frames */
1329         nextIndent = nextIndent-1;
1330         printVectorTable( indentation, (PP_) *(nextSpB) );
1331       }
1332     }
1333     printContinuations( depth+1, nextIndent, weight, nextSpA, nextSuA, nextSpB, nextSuB );
1334
1335   } else {
1336     printf("...\n");
1337   }
1338 }
1339
1340 void
1341 DEBUG_Where( int depth, int weight )
1342 {
1343 #ifdef CONCURRENT
1344   PP_ SpA  = STKO_SpA(SAVE_StkO);
1345   PP_ SuA  = STKO_SuA(SAVE_StkO);
1346   P_  SpB  = STKO_SpB(SAVE_StkO);
1347   P_  SuB  = STKO_SuB(SAVE_StkO);
1348 #else
1349   PP_ SpA  = SAVE_SpA;
1350   PP_ SuA  = SAVE_SuA;
1351   P_  SpB  = SAVE_SpB;
1352   P_  SuB  = SAVE_SuB;
1353 #endif
1354   P_ Hp    = SAVE_Hp;
1355   StgRetAddr RetReg = SAVE_Ret;
1356   P_ Node  = SAVE_R1.p;
1357
1358   int indentation;
1359
1360   maxDepth = depth;
1361
1362   printf("WARNING: Non-updating cases may be incorrectly displayed\n");
1363
1364   indentation = printCases( 1, weight, SpA, SuA, SpB, SuB );
1365
1366   printIndentation( indentation );
1367   printf("CASE\n");
1368
1369   printIndentation( indentation+1 );
1370   printName( Node );
1371   printf("\n");
1372   printVectorTable( indentation+1, (PP_) RetReg );
1373
1374   printContinuations( depth, indentation, weight, SpA, SuA, SpB, SuB );
1375 }
1376 \end{code}
1377
1378
1379 \begin{code}
1380 void
1381 DEBUG_INFO_TABLE(node)
1382   P_ node;
1383 {
1384   int vhs, size, ptrs; /* not used */
1385   char *ip_type;
1386   StgPtr info_ptr = (StgPtr) INFO_PTR(node);
1387
1388   getClosureShape(node, &vhs, &size, &ptrs, &ip_type);
1389
1390   fprintf(stderr,
1391           "%s Info Ptr 0x%lx; Entry: 0x%lx; Update: 0x%lx\n",
1392           ip_type, info_ptr,
1393           (W_) ENTRY_CODE(info_ptr), (W_) UPDATE_CODE(info_ptr));
1394   fprintf(stderr,
1395           "Tag: %d; Type: %d; Size: %lu; Ptrs: %lu\n\n",
1396           INFO_TAG(info_ptr), INFO_TYPE(info_ptr),
1397           INFO_SIZE(info_ptr),INFO_NoPTRS(info_ptr));
1398 #if defined(PAR)
1399   fprintf(stderr,"Enter Flush Entry: 0x%lx;\tExit Flush Entry: 0x%lx\n",INFO_FLUSHENT(info_ptr),INFO_FLUSH(info_ptr));
1400 #endif /* PAR */
1401
1402 #if defined(PROFILING)
1403   fprintf(stderr,"Cost Centre:       0x%lx\n",INFO_CAT(info_ptr));
1404 #endif /* PROFILING */
1405
1406 #if defined(_INFO_COPYING)
1407   fprintf(stderr,"Evacuate Entry:    0x%lx;\tScavenge Entry: 0x%lx\n",
1408           INFO_EVAC_2S(info_ptr),INFO_SCAV_2S(info_ptr));
1409 #endif /* INFO_COPYING */
1410
1411 #if defined(_INFO_COMPACTING)
1412   fprintf(stderr,"Scan Link:         0x%lx;\tScan Move:      0x%lx\n",
1413           (W_) INFO_SCAN_LINK_1S(info_ptr), (W_) INFO_SCAN_MOVE_1S(info_ptr));
1414   fprintf(stderr,"Mark:              0x%lx;\tMarked:         0x%lx;\n",
1415           (W_) INFO_MARK_1S(info_ptr), (W_) INFO_MARKED_1S(info_ptr));
1416   if(BASE_INFO_TYPE(info_ptr)==INFO_SPEC_TYPE)
1417     fprintf(stderr,"plus specialised code\n");
1418   else
1419     fprintf(stderr,"Marking:           0x%lx\n",(W_) INFO_MARKING_1S(info_ptr));
1420 #endif /* INFO_COMPACTING */
1421 }
1422
1423 void
1424 DEBUG_REGS()
1425 {
1426 #ifdef CONCURRENT
1427   PP_ SpA  = STKO_SpA(SAVE_StkO);
1428   PP_ SuA  = STKO_SuA(SAVE_StkO);
1429   P_  SpB  = STKO_SpB(SAVE_StkO);
1430   P_  SuB  = STKO_SuB(SAVE_StkO);
1431 #else
1432   PP_ SpA  = SAVE_SpA;
1433   PP_ SuA  = SAVE_SuA;
1434   P_  SpB  = SAVE_SpB;
1435   P_  SuB  = SAVE_SuB;
1436 #endif
1437   P_  Hp   = SAVE_Hp;
1438   P_  HpLim= SAVE_HpLim;
1439   I_  TagReg= SAVE_Tag;
1440   StgRetAddr RetReg = SAVE_Ret;
1441   P_  Node = SAVE_R1.p;
1442   StgUnion  R1   = SAVE_R1;
1443   StgUnion  R2   = SAVE_R2;
1444   StgUnion  R3   = SAVE_R3;
1445   StgUnion  R4   = SAVE_R4;
1446   StgUnion  R5   = SAVE_R5;
1447   StgUnion  R6   = SAVE_R6;
1448   StgUnion  R7   = SAVE_R7;
1449   StgUnion  R8   = SAVE_R8;
1450   StgFloat FltReg1 = SAVE_Flt1;
1451   StgFloat FltReg2 = SAVE_Flt2;
1452   StgFloat FltReg3 = SAVE_Flt3;
1453   StgFloat FltReg4 = SAVE_Flt4;
1454   StgDouble DblReg1 = SAVE_Dbl1;
1455   StgDouble DblReg2 = SAVE_Dbl2;
1456
1457   fprintf(stderr,"STG-Machine Register Values:\n\n");
1458   fprintf(stderr,"Node:  %08lx;  Hp:    %08lx;  HpLim: %08lx;  Tag:   %8lu\n",Node,(W_)Hp,(W_)HpLim,TagReg);
1459   fprintf(stderr,"SpA:   %08lx;  SpB:   %08lx;  SuA:   %08lx;  SuB:   %08lx\n",(W_)SpA,(W_)SpB,(W_)SuA,(W_)SuB);
1460   fprintf(stderr,"RetReg: %08lx\n",RetReg);
1461
1462 #if 0
1463 /* These bits need to have the FLUSH_REG_MAP, whereas the surrounding bits
1464    use the MAIN_REG_MAP */
1465
1466   fprintf(stderr, "\n");
1467   fprintf(stderr,"LiveR: %08lx\n", LivenessReg);
1468   fprintf(stderr,"Flush: %08lx;  FStk:  %08lx;  FStkB: %08lx;  FTmp:  %08lx\n",(W_)FlushP,(W_)FStack,(W_)FStackBase,(W_)Temp);
1469 #endif /* 0 */
1470
1471   fprintf(stderr, "\n");
1472
1473   fprintf(stderr,"Gen:   %8lu, %8lu, %8lu, %8lu\n",R1.i,R2.i,R3.i,R4.i);
1474   fprintf(stderr,"       %8lu, %8lu, %8lu, %8lu\n",R5.i,R6.i,R7.i,R8.i);
1475   fprintf(stderr,"Float: %8g, %8g, %8g, %8g\n",FltReg1,FltReg2,FltReg3,FltReg4);
1476   fprintf(stderr,"Dble:  %8g, %8g\n",DblReg1,DblReg2);
1477 }
1478
1479 #ifndef CONCURRENT
1480
1481 void
1482 DEBUG_MP()
1483 {
1484   StgPtr mp;
1485   StgInt i;
1486
1487   fprintf(stderr,"MallocPtrList\n\n");
1488
1489   for(mp = StorageMgrInfo.MallocPtrList;
1490       mp != NULL;
1491       mp = MallocPtr_CLOSURE_LINK(mp)) {
1492
1493     fprintf(stderr, "MallocPtr(0x%lx) = 0x%lx\n", mp, MallocPtr_CLOSURE_DATA(mp));
1494
1495 /*
1496     DEBUG_PRINT_NODE(mp);
1497 */
1498   }
1499
1500 # if defined(GCap) || defined(GCgn)
1501   fprintf(stderr,"\nOldMallocPtr List\n\n");
1502
1503   for(mp = StorageMgrInfo.OldMallocPtrList;
1504       mp != NULL;
1505       mp = MallocPtr_CLOSURE_LINK(mp)) {
1506
1507     fprintf(stderr, "  MallocPtr(0x%lx) = 0x%lx\n", mp, MallocPtr_CLOSURE_DATA(mp));
1508 /*
1509    DEBUG_PRINT_NODE(mp);
1510 */
1511   }
1512 # endif /* GCap || GCgn */
1513
1514   fprintf(stderr, "\n");
1515 }
1516
1517 void
1518 DEBUG_SPT(int weight)
1519 {
1520   StgPtr SPTable = StorageMgrInfo.StablePointerTable;
1521   StgInt size = SPT_SIZE(SPTable);
1522   StgInt ptrs = SPT_NoPTRS(SPTable);
1523   StgInt top = SPT_TOP(SPTable);
1524
1525   StgInt i;
1526
1527 /*
1528   DEBUG_PRINT_NODE(SPTable);
1529 */
1530
1531   fprintf(stderr,"SPTable@0x%lx:\n", SPTable);
1532   fprintf(stderr,"  InfoPtr = 0x%lx\n", INFO_PTR(SPTable));
1533   fprintf(stderr,"  size = %d, ptrs = %d, top = %d\n",
1534                     size,      ptrs,      top
1535          );
1536   for( i=0; i < ptrs; i++ ) {
1537     if (i % 10 == 0) {
1538       fprintf(stderr,"\n  ");
1539     }
1540     printClosure(SPT_SPTR(SPTable, i),1,weight);
1541     fprintf(stderr, "\n");
1542   }
1543   fprintf(stderr, "\n");
1544   for( i=0; i < top; i++) {
1545     if (i % 10 == 0) {
1546       fprintf(stderr,"\n  ");
1547     }
1548     fprintf(stderr, " %3d", SPT_FREE(SPTable, i));
1549   }
1550
1551   fprintf(stderr, "\n\n");
1552
1553 }
1554 #endif /* !CONCURRENT */
1555
1556 /*
1557   These routines crawl over the A and B stacks, printing
1558   a maximum "lines" lines at the top of the stack.
1559 */
1560
1561 #define STACK_VALUES_PER_LINE   5
1562
1563 #ifndef CONCURRENT
1564 /* (stack stuff is really different on parallel machines) */
1565
1566 void
1567 DEBUG_ASTACK(lines)
1568   I_ lines;
1569 {
1570   PP_ SpA  = SAVE_SpA;
1571   PP_ SuA  = SAVE_SuA;
1572   P_  SpB  = SAVE_SpB;
1573   P_  SuB  = SAVE_SuB;
1574
1575   PP_   stackptr;
1576   I_ count = 0;
1577
1578   fprintf(stderr,"Dump of the Address Stack, SpA: 0x%08lx, BOS: 0x%08lx\n",
1579                     (W_) SpA, (W_) stackInfo.botA);
1580
1581   for (stackptr = SpA;
1582        SUBTRACT_A_STK(stackptr, stackInfo.botA) >= 0;
1583        stackptr = stackptr + AREL(1))
1584     {
1585       if( count++ % STACK_VALUES_PER_LINE == 0)
1586         {
1587           if(count >= lines * STACK_VALUES_PER_LINE)
1588             break;
1589           fprintf(stderr,"\nSpA[%ld] (0x%08lx): ",count-1,stackptr);
1590         }
1591       fprintf(stderr,"0x%08lx ",(W_) *stackptr);
1592     }
1593   fprintf(stderr, "\n");
1594 }
1595
1596 void
1597 DEBUG_BSTACK(lines)
1598   I_ lines;
1599 {
1600   PP_ SpA  = SAVE_SpA;
1601   PP_ SuA  = SAVE_SuA;
1602   P_  SpB  = SAVE_SpB;
1603   P_  SuB  = SAVE_SuB;
1604
1605   P_    stackptr;
1606   I_ count = 0;
1607
1608   fprintf(stderr,"Dump of the Value Stack, SpB: 0x%08lx, BOS: 0x%08lx\n",
1609                 (W_) SpB, (W_) stackInfo.botB);
1610
1611   for (stackptr = SpB;
1612          SUBTRACT_B_STK(stackptr, stackInfo.botB) > 0;
1613          stackptr = stackptr + BREL(1))
1614       {
1615         if( count++ % STACK_VALUES_PER_LINE == 0)
1616           {
1617             if(count >= lines * STACK_VALUES_PER_LINE)
1618               break;
1619             fprintf(stderr,"\nSpB[%ld] (0x%08lx): ",count-1,stackptr);
1620           }
1621         fprintf(stderr,"0x%08lx ",(W_) *stackptr);
1622       }
1623   fprintf(stderr, "\n");
1624 }
1625 #endif /* not concurrent */
1626
1627 /*
1628   This should disentangle update frames from both stacks.
1629 */
1630
1631 #ifndef CONCURRENT
1632 void
1633 DEBUG_UPDATES(limit)
1634   I_ limit;
1635 {
1636   PP_ SpA  = SAVE_SpA;
1637   PP_ SuA  = SAVE_SuA;
1638   P_  SpB  = SAVE_SpB;
1639   P_  SuB  = SAVE_SuB;
1640
1641   P_  updatee, retreg;
1642   PP_ sua, spa;
1643   P_  sub, spb;
1644   I_  count = 0;
1645
1646   fprintf(stderr,"Update Frame Stack Dump:\n\n");
1647
1648   for(spa = SuA, spb = SuB;
1649       SUBTRACT_B_STK(spb, stackInfo.botB) > 0 && count++ < limit;
1650       spa = GRAB_SuA(spb), spb = GRAB_SuB(spb) ) {
1651
1652       updatee = GRAB_UPDATEE(spb);         /* Thing to be updated  */
1653       retreg  = (P_) GRAB_RET(spb);        /* Return vector below */
1654
1655       fprintf(stderr,"SuA: 0x%08lx, SuB: 0x%08lx, Updatee 0x%08lx (Info 0x%08lx), RetReg 0x%x\n",
1656                      (W_) spa, (W_) spb,
1657                      (W_) updatee, (W_) INFO_PTR(updatee), (W_) retreg);
1658   }
1659 }
1660
1661 #endif /* not concurrent */
1662 \end{code}
1663
1664 \begin{code}
1665 #ifdef CONCURRENT
1666
1667 void
1668 DEBUG_TSO(P_ tso)
1669 {
1670     STGRegisterTable *r = TSO_INTERNAL_PTR(tso);
1671     W_ liveness = r->rLiveness;
1672     I_ i;
1673
1674     fprintf(stderr,"TSO:\ntso=%lx, regs=%lx, liveness=%lx\nlink=%lx,name=%lx,id=%lx,type=%lx,pc1=%lx,arg1=%lx,switch=%lx\n"
1675             , tso
1676             , r
1677             , liveness
1678             , TSO_LINK(tso)
1679             , TSO_NAME(tso)
1680             , TSO_ID(tso)
1681             , TSO_TYPE(tso)
1682             , TSO_PC1(tso)
1683             , TSO_ARG1(tso)
1684             , TSO_SWITCH(tso)
1685             );
1686
1687     for (i = 0; liveness != 0; liveness >>= 1, i++) {
1688         if (liveness & 1) {
1689             fprintf(stderr, "live reg %d (%lx)\n",i, r->rR[i].p);
1690         } else {
1691             fprintf(stderr, "reg %d (%lx) not live\n", i, r->rR[i].p);
1692         }
1693     }
1694 }
1695
1696 #endif /* concurrent */
1697 \end{code}