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_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 %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   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   extern 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("%d",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 %d\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   P_  SpB  = SAVE_SpB;
1027   P_  SuB  = SAVE_SuB;
1028   P_ Hp    = SAVE_Hp;
1029
1030   int i;
1031   I_ size = minimum(depth, SUBTRACT_A_STK(SpA, stackInfo.botA)+1);
1032
1033   printf("Dump of the Address Stack (SpA = 0x%x, SuA = 0x%x)\n", SpA, SuA);
1034
1035   for( i = 0; i < size; ++i ) {
1036     printIndentation(1);
1037     printf("SpA[%ld] (0x%08lx):", i, SpA + AREL(i));
1038     printClosure((P_)*(SpA + AREL(i)), 2, weight);
1039     printf("\n");
1040   }
1041 }
1042
1043 void
1044 DEBUG_PrintB( int depth, int weight )
1045 {
1046   PP_ SpA  = SAVE_SpA;
1047   PP_ SuA  = SAVE_SuA;
1048   P_  SpB  = SAVE_SpB;
1049   P_  SuB  = SAVE_SuB;
1050   P_ Hp    = SAVE_Hp;
1051
1052   I_ i;
1053   I_ size = minimum(depth, SUBTRACT_B_STK(SpB, stackInfo.botB)+1);
1054
1055   P_ updateFramePtr;
1056   I_ update_count;
1057
1058   printf("Dump of the Value Stack (SpB = 0x%x, SuB = 0x%x)\n", SpB, SuB);
1059
1060   updateFramePtr = SuB;
1061   update_count = 0;
1062   i = 0;
1063   while (i < size) {
1064     if (updateFramePtr == SpB + BREL(i)) {
1065
1066       printIndentation(1);
1067       printf("SpB[%ld] (0x%08lx): UpdateFrame[%d](",
1068              i,
1069              updateFramePtr,
1070              update_count
1071              );
1072       printName( (P_) *(SpB + BREL(i)) );
1073       printf(", UF[%d] (= SpB[%ld]), SpA[%ld], ",
1074              update_count+1,
1075              SUBTRACT_B_STK(SpB, GRAB_SuB(updateFramePtr)),
1076              SUBTRACT_A_STK(SpA, GRAB_SuA(updateFramePtr))
1077              );
1078       printAddress( GRAB_UPDATEE(updateFramePtr) );
1079       printf(")\n");
1080
1081       printIndentation(2);
1082       printClosure( GRAB_UPDATEE(updateFramePtr), 3, weight );
1083       printf("\n");
1084
1085       updateFramePtr = GRAB_SuB(updateFramePtr);
1086       update_count = update_count + 1;
1087
1088       /* ToDo: GhcConstants.lh reveals that there are two other sizes possible */
1089       i = i + STD_UF_SIZE;
1090     } else {
1091       printIndentation(1);
1092       printf("SpB[%ld] (0x%08lx): ", i, SpB + BREL(i) );
1093       printName((P_) *(SpB + BREL(i)) );
1094       printf("\n");
1095       i = i + 1;
1096     }
1097   }
1098 }
1099 #endif /* not CONCURRENT */
1100 \end{code}
1101
1102 ToDo:
1103
1104    All the following code incorrectly assumes that the only return
1105    addresses are those associated with update frames.
1106
1107    To do a proper job of printing the environment we need to:
1108
1109    1) Recognise vectored and non-vectored returns on the B stack.
1110
1111    2) Know where the local variables are in the A and B stacks for
1112       each return situation.
1113
1114    Until then, we'll just need to look suspiciously at the
1115    "environment" being printed out.
1116
1117    ADR
1118
1119 \begin{code}
1120 /* How many real stacks are there on SpA and SpB? */
1121 /* Say what?? (Will and Phil, 96/01) */
1122 #ifndef CONCURRENT
1123 static int
1124 numStacks( )
1125 {
1126 #ifdef CONCURRENT
1127   PP_ SpA  = STKO_SpA(SAVE_StkO);
1128   PP_ SuA  = STKO_SuA(SAVE_StkO);
1129   P_  SpB  = STKO_SpB(SAVE_StkO);
1130   P_  SuB  = STKO_SuB(SAVE_StkO);
1131 #else
1132   PP_ SpA  = SAVE_SpA;
1133   PP_ SuA  = SAVE_SuA;
1134   P_  SpB  = SAVE_SpB;
1135   P_  SuB  = SAVE_SuB;
1136 #endif
1137   P_  Hp   = SAVE_Hp;
1138
1139   int depth = 1; /* There's always at least one stack */
1140
1141   while (SUBTRACT_B_STK(SuB, stackInfo.botB) >= 0) {
1142     SuB = GRAB_SuB( SuB );
1143     depth = depth + 1;
1144   }
1145   return depth;
1146 }
1147 #endif /* !CONCURRENT */
1148
1149 static void
1150 printLocalAStack( int depth, int indentation, int weight, PP_ SpA, int size )
1151 {
1152   int i;
1153
1154   ASSERT( size >= 0 );
1155
1156   for( i = size-1; i >= 0; --i ) {
1157     printIndentation( indentation );
1158     printf("A[%ld][%ld]", depth, i);
1159     if (DEBUG_details > 1) printf(" (0x%08lx) ", SpA + AREL(i) );
1160     printf("=");
1161     printClosure( *(SpA + AREL(i)), indentation+2, weight );
1162     printf("\n");
1163   }
1164 }
1165
1166 static void
1167 printLocalBStack( int depth, int indentation, int weight, P_ SpB, int size )
1168 {
1169   int i;
1170
1171   ASSERT( size >= 0 );
1172
1173   for( i = size-1; i >= 0; --i) {
1174     printIndentation( indentation );
1175     printf("B[%ld][%ld]", depth, i);
1176     if (DEBUG_details > 1) printf(" (0x%08lx) ", SpB + BREL(i) );
1177     printf("=");
1178     printAddress( (P_) *(SpB + BREL(i)) );
1179     printf("\n");
1180   }
1181 }
1182
1183 static void
1184 printEnvironment( int depth, int indentation, int weight, PP_ SpA, PP_ SuA, P_ SpB, P_ SuB )
1185 {
1186   int sizeA = SUBTRACT_A_STK(SpA, SuA);
1187   int sizeB = SUBTRACT_B_STK(SpB, SuB);
1188
1189   if (sizeA + sizeB > 0) {
1190     printIndentation( indentation );
1191     printf("let\n");
1192
1193     printLocalAStack( depth, indentation+1, weight, SpA, sizeA );
1194     printLocalBStack( depth, indentation+1, weight, SpB, sizeB );
1195
1196     printIndentation( indentation );
1197     printf("in\n");
1198   }
1199 }
1200 \end{code}
1201
1202 Printing the current context is a little tricky.
1203
1204 Ideally, we would work from the bottom of the stack up to the top
1205 recursively printing the stuff nearer the top.
1206
1207 In practice, we have to work from the top down because the top
1208 contains info about how much data is below the current return address.
1209
1210 The result is that we have two recursive passes over the stacks: the
1211 first one prints the "cases" and the second one prints the
1212 continuations (vector tables, etc.)
1213
1214 Note that because we compress chains of update frames, the depth and
1215 indentation do not always change in step.
1216
1217 ToDo:
1218
1219 * detecting non-updating cases too
1220 * printing continuations (from vector tables) properly
1221 * printing sensible names in environment.
1222 * fix bogus nature of lets
1223
1224
1225 \begin{code}
1226 static int maxDepth = 5;
1227
1228 static int
1229 printCases( int depth, int weight, PP_ SpA, PP_ SuA, P_ SpB, P_ SuB )
1230 {
1231 #ifdef CONCURRENT
1232   printf("no printCases for CONCURRENT\n");
1233 #else
1234   int indentation;
1235
1236   if (depth < maxDepth && SUBTRACT_B_STK(SuB, stackInfo.botB) >= 0) {
1237     PP_ nextSpA, nextSuA;
1238     P_  nextSpB, nextSuB;
1239
1240     /* ToDo: GhcConstants.lh reveals that there are two other sizes of
1241        update frame possible */
1242     /* ToDo: botB is probably wrong in THREAD system */
1243
1244     nextSpB = SuB + BREL(STD_UF_SIZE);
1245     nextSuB = GRAB_SuB( SuB );
1246     nextSpA = SuA;
1247     nextSuA = GRAB_SuA( nextSuB );
1248
1249     indentation = printCases( depth+1, weight, nextSpA, nextSuA, nextSpB, nextSuB );
1250
1251     if (DEBUG_details > 1 || nextSpB != nextSuB) { /* show frame (even if adjacent to another) */
1252       printIndentation( indentation );
1253       printf("case\n");
1254       indentation = indentation + 1;
1255     }
1256     if (SpB != SuB) {
1257       /* next thing on stack is a return vector - no need to show it here. */
1258       SpB = SpB + BREL(1);
1259     }
1260     printEnvironment( depth, indentation, weight, SpA, SuA, SpB, SuB );
1261   } else {
1262     printf("...\n");
1263     indentation = 1;
1264   }
1265
1266   return indentation;
1267
1268 #endif /* CONCURRENT */
1269 }
1270
1271 /* ToDo: pay more attention to format of vector tables in SMupdate.lh */
1272
1273 static int
1274 isVTBLEntry( P_ entry )
1275 {
1276   char *raw;
1277
1278   if (lookupForName( entry, &raw )) {
1279     if ( strncmp( "_ret", raw, 4 ) == 0 ) {
1280       return 1;
1281     } else if ( strncmp( "_djn", raw, 4 ) == 0) {
1282       return 1;
1283     } else {
1284       return 0;
1285     }
1286   } else {
1287     return 0;
1288   }
1289 }
1290
1291 static void
1292 printVectorTable( int indentation, PP_ vtbl )
1293 {
1294   if (isVTBLEntry( (P_) vtbl )) { /* Direct return */
1295     printName( (P_) vtbl );
1296   } else {
1297     int i = 0;
1298     while( isVTBLEntry( vtbl[RVREL(i)] )) {
1299       printIndentation( indentation );
1300       printf( "%d -> ", i );
1301       printName( vtbl[RVREL(i)] );
1302       printf( "\n" );
1303       i = i + 1;
1304     }
1305   }
1306 }
1307
1308 static void
1309 printContinuations( int depth, int indentation, int weight, PP_ SpA, PP_ SuA, P_ SpB, P_ SuB )
1310 {
1311 #ifdef CONCURRENT
1312   printf("no printContinuations for CONCURRENT\n");
1313 #else
1314   if (depth < maxDepth && SUBTRACT_B_STK(SuB, stackInfo.botB) >= 0) {
1315     PP_ nextSpA, nextSuA;
1316     P_  nextSpB, nextSuB;
1317     int nextIndent = indentation; /* Indentation to print next frame at */
1318
1319     /* ToDo: GhcConstants.lh reveals that there are two other sizes of
1320        update frame possible */
1321     /* ToDo: botB is probably wrong in THREAD system */
1322
1323     /* ToDo: ASSERT that SuA == nextSuA */
1324
1325     nextSpB = SuB + BREL(STD_UF_SIZE);
1326     nextSuB = GRAB_SuB( SuB );
1327     nextSpA = SuA;
1328     nextSuA = GRAB_SuA( nextSuB );
1329
1330     if (DEBUG_details > 0) { /* print update information */
1331
1332       if (SpB != SuB) { /* start of chain of update frames */
1333         printIndentation( indentation );
1334         printf("of updatePtr ->\n");
1335         printIndentation( indentation+1 );
1336         printf("update\n");
1337       }
1338       printIndentation( indentation+2 );
1339       printClosure( (P_)*(SuB + BREL(UF_UPDATEE)), indentation+2, weight );
1340       printf(" := ");
1341       printName( (P_) *(SuB + BREL(UF_RET)) );
1342       printf("(updatePtr)\n");
1343
1344       if (nextSpB != nextSuB) { /* end of chain of update frames */
1345         nextIndent = nextIndent-1;
1346         printVectorTable( indentation+1, (PP_) *(nextSpB) );
1347       }
1348     } else {
1349       if (nextSpB != nextSuB) { /* end of chain of update frames */
1350         nextIndent = nextIndent-1;
1351         printVectorTable( indentation, (PP_) *(nextSpB) );
1352       }
1353     }
1354     printContinuations( depth+1, nextIndent, weight, nextSpA, nextSuA, nextSpB, nextSuB );
1355
1356   } else {
1357     printf("...\n");
1358   }
1359 #endif /* CONCURRENT */
1360 }
1361
1362 void
1363 DEBUG_Where( int depth, int weight )
1364 {
1365 #ifdef CONCURRENT
1366   PP_ SpA  = STKO_SpA(SAVE_StkO);
1367   PP_ SuA  = STKO_SuA(SAVE_StkO);
1368   P_  SpB  = STKO_SpB(SAVE_StkO);
1369   P_  SuB  = STKO_SuB(SAVE_StkO);
1370 #else
1371   PP_ SpA  = SAVE_SpA;
1372   PP_ SuA  = SAVE_SuA;
1373   P_  SpB  = SAVE_SpB;
1374   P_  SuB  = SAVE_SuB;
1375 #endif
1376   P_ Hp    = SAVE_Hp;
1377   StgRetAddr RetReg = SAVE_Ret;
1378   P_ Node  = SAVE_R1.p;
1379
1380   int indentation;
1381
1382   maxDepth = depth;
1383
1384   printf("WARNING: Non-updating cases may be incorrectly displayed\n");
1385
1386   indentation = printCases( 1, weight, SpA, SuA, SpB, SuB );
1387
1388   printIndentation( indentation );
1389   printf("CASE\n");
1390
1391   printIndentation( indentation+1 );
1392   printName( Node );
1393   printf("\n");
1394   printVectorTable( indentation+1, (PP_) RetReg );
1395
1396   printContinuations( depth, indentation, weight, SpA, SuA, SpB, SuB );
1397 }
1398 \end{code}
1399
1400
1401 \begin{code}
1402 void
1403 DEBUG_INFO_TABLE(node)
1404   P_ node;
1405 {
1406   int vhs, size, ptrs; /* not used */
1407   char *ip_type;
1408   StgPtr info_ptr = (StgPtr) INFO_PTR(node);
1409
1410   getClosureShape(node, &vhs, &size, &ptrs, &ip_type);
1411
1412   fprintf(stderr,
1413           "%s Info Ptr 0x%lx; Entry: 0x%lx; Update: 0x%lx\n",
1414           ip_type, info_ptr,
1415           (W_) ENTRY_CODE(info_ptr), (W_) UPDATE_CODE(info_ptr));
1416   fprintf(stderr,
1417           "Tag: %d; Type: %d; Size: %lu; Ptrs: %lu\n\n",
1418           INFO_TAG(info_ptr), INFO_TYPE(info_ptr),
1419           INFO_SIZE(info_ptr),INFO_NoPTRS(info_ptr));
1420 #if defined(GRIP)
1421   /* flushing is GRIP only */
1422   fprintf(stderr,"Enter Flush Entry: 0x%lx;\tExit Flush Entry: 0x%lx\n",INFO_FLUSHENT(info_ptr),INFO_FLUSH(info_ptr));
1423 #endif /* GRIP */
1424
1425 #if defined(PROFILING)
1426   fprintf(stderr,"Cost Centre:       0x%lx\n",INFO_CAT(info_ptr));
1427 #endif /* PROFILING */
1428
1429 #if defined(_INFO_COPYING)
1430   fprintf(stderr,"Evacuate Entry:    0x%lx;\tScavenge Entry: 0x%lx\n",
1431           INFO_EVAC_2S(info_ptr),INFO_SCAV_2S(info_ptr));
1432 #endif /* INFO_COPYING */
1433
1434 #if defined(_INFO_COMPACTING)
1435   fprintf(stderr,"Scan Link:         0x%lx;\tScan Move:      0x%lx\n",
1436           (W_) INFO_SCAN_LINK_1S(info_ptr), (W_) INFO_SCAN_MOVE_1S(info_ptr));
1437   fprintf(stderr,"Mark:              0x%lx;\tMarked:         0x%lx;\n",
1438           (W_) INFO_MARK_1S(info_ptr), (W_) INFO_MARKED_1S(info_ptr));
1439   if(BASE_INFO_TYPE(info_ptr)==INFO_SPEC_TYPE)
1440     fprintf(stderr,"plus specialised code\n");
1441   else
1442     fprintf(stderr,"Marking:           0x%lx\n",(W_) INFO_MARKING_1S(info_ptr));
1443 #endif /* INFO_COMPACTING */
1444 }
1445
1446 void
1447 DEBUG_REGS()
1448 {
1449 #ifdef CONCURRENT
1450   PP_ SpA  = STKO_SpA(SAVE_StkO);
1451   PP_ SuA  = STKO_SuA(SAVE_StkO);
1452   P_  SpB  = STKO_SpB(SAVE_StkO);
1453   P_  SuB  = STKO_SuB(SAVE_StkO);
1454 #else
1455   PP_ SpA  = SAVE_SpA;
1456   PP_ SuA  = SAVE_SuA;
1457   P_  SpB  = SAVE_SpB;
1458   P_  SuB  = SAVE_SuB;
1459 #endif
1460   P_  Hp   = SAVE_Hp;
1461   P_  HpLim= SAVE_HpLim;
1462   I_  TagReg= SAVE_Tag;
1463   StgRetAddr RetReg = SAVE_Ret;
1464   P_  Node = SAVE_R1.p;
1465   StgUnion  R1   = SAVE_R1;
1466   StgUnion  R2   = SAVE_R2;
1467   StgUnion  R3   = SAVE_R3;
1468   StgUnion  R4   = SAVE_R4;
1469   StgUnion  R5   = SAVE_R5;
1470   StgUnion  R6   = SAVE_R6;
1471   StgUnion  R7   = SAVE_R7;
1472   StgUnion  R8   = SAVE_R8;
1473   StgFloat FltReg1 = SAVE_Flt1;
1474   StgFloat FltReg2 = SAVE_Flt2;
1475   StgFloat FltReg3 = SAVE_Flt3;
1476   StgFloat FltReg4 = SAVE_Flt4;
1477   StgDouble DblReg1 = SAVE_Dbl1;
1478   StgDouble DblReg2 = SAVE_Dbl2;
1479
1480   fprintf(stderr,"STG-Machine Register Values:\n\n");
1481   fprintf(stderr,"Node:  %08lx;  Hp:    %08lx;  HpLim: %08lx;  Tag:   %8lu\n",Node,(W_)Hp,(W_)HpLim,TagReg);
1482   fprintf(stderr,"SpA:   %08lx;  SpB:   %08lx;  SuA:   %08lx;  SuB:   %08lx\n",(W_)SpA,(W_)SpB,(W_)SuA,(W_)SuB);
1483   fprintf(stderr,"RetReg: %08lx\n",RetReg);
1484
1485 #if 0
1486 /* These bits need to have the FLUSH_REG_MAP, whereas the surrounding bits
1487    use the MAIN_REG_MAP */
1488
1489   fprintf(stderr, "\n");
1490   fprintf(stderr,"LiveR: %08lx\n", LivenessReg);
1491   fprintf(stderr,"Flush: %08lx;  FStk:  %08lx;  FStkB: %08lx;  FTmp:  %08lx\n",(W_)FlushP,(W_)FStack,(W_)FStackBase,(W_)Temp);
1492 #endif /* 0 */
1493
1494   fprintf(stderr, "\n");
1495
1496   fprintf(stderr,"Gen:   %8lu, %8lu, %8lu, %8lu\n",R1.i,R2.i,R3.i,R4.i);
1497   fprintf(stderr,"       %8lu, %8lu, %8lu, %8lu\n",R5.i,R6.i,R7.i,R8.i);
1498   fprintf(stderr,"Float: %8g, %8g, %8g, %8g\n",FltReg1,FltReg2,FltReg3,FltReg4);
1499   fprintf(stderr,"Dble:  %8g, %8g\n",DblReg1,DblReg2);
1500 }
1501
1502 #ifndef CONCURRENT
1503
1504 void
1505 DEBUG_MP()
1506 {
1507   StgPtr mp;
1508   StgInt i;
1509
1510   fprintf(stderr,"MallocPtrList\n\n");
1511
1512   for(mp = StorageMgrInfo.MallocPtrList;
1513       mp != NULL;
1514       mp = MallocPtr_CLOSURE_LINK(mp)) {
1515
1516     fprintf(stderr, "MallocPtr(0x%lx) = 0x%lx\n", mp, MallocPtr_CLOSURE_DATA(mp));
1517
1518 /*
1519     DEBUG_PRINT_NODE(mp);
1520 */
1521   }
1522
1523 # if defined(GCap) || defined(GCgn)
1524   fprintf(stderr,"\nOldMallocPtr List\n\n");
1525
1526   for(mp = StorageMgrInfo.OldMallocPtrList;
1527       mp != NULL;
1528       mp = MallocPtr_CLOSURE_LINK(mp)) {
1529
1530     fprintf(stderr, "  MallocPtr(0x%lx) = 0x%lx\n", mp, MallocPtr_CLOSURE_DATA(mp));
1531 /*
1532    DEBUG_PRINT_NODE(mp);
1533 */
1534   }
1535 # endif /* GCap || GCgn */
1536
1537   fprintf(stderr, "\n");
1538 }
1539
1540 void
1541 DEBUG_SPT(int weight)
1542 {
1543   StgPtr SPTable = StorageMgrInfo.StablePointerTable;
1544   StgInt size = SPT_SIZE(SPTable);
1545   StgInt ptrs = SPT_NoPTRS(SPTable);
1546   StgInt top = SPT_TOP(SPTable);
1547
1548   StgInt i;
1549
1550 /*
1551   DEBUG_PRINT_NODE(SPTable);
1552 */
1553
1554   fprintf(stderr,"SPTable@0x%lx:\n", SPTable);
1555   fprintf(stderr,"  InfoPtr = 0x%lx\n", INFO_PTR(SPTable));
1556   fprintf(stderr,"  size = %d, ptrs = %d, top = %d\n",
1557                     size,      ptrs,      top
1558          );
1559   for( i=0; i < ptrs; i++ ) {
1560     if (i % 10 == 0) {
1561       fprintf(stderr,"\n  ");
1562     }
1563     printClosure(SPT_SPTR(SPTable, i),1,weight);
1564     fprintf(stderr, "\n");
1565   }
1566   fprintf(stderr, "\n");
1567   for( i=0; i < top; i++) {
1568     if (i % 10 == 0) {
1569       fprintf(stderr,"\n  ");
1570     }
1571     fprintf(stderr, " %3d", SPT_FREE(SPTable, i));
1572   }
1573
1574   fprintf(stderr, "\n\n");
1575
1576 }
1577 #endif /* !CONCURRENT */
1578
1579 /*
1580   These routines crawl over the A and B stacks, printing
1581   a maximum "lines" lines at the top of the stack.
1582 */
1583
1584 #define STACK_VALUES_PER_LINE   5
1585
1586 #ifndef CONCURRENT
1587 /* (stack stuff is really different on parallel machines) */
1588
1589 void
1590 DEBUG_ASTACK(lines)
1591   I_ lines;
1592 {
1593   PP_ SpA  = SAVE_SpA;
1594   PP_ SuA  = SAVE_SuA;
1595   P_  SpB  = SAVE_SpB;
1596   P_  SuB  = SAVE_SuB;
1597
1598   PP_   stackptr;
1599   I_ count = 0;
1600
1601   fprintf(stderr,"Dump of the Address Stack, SpA: 0x%08lx, BOS: 0x%08lx\n",
1602                     (W_) SpA, (W_) stackInfo.botA);
1603
1604   for (stackptr = SpA;
1605        SUBTRACT_A_STK(stackptr, stackInfo.botA) >= 0;
1606        stackptr = stackptr + AREL(1))
1607     {
1608       if( count++ % STACK_VALUES_PER_LINE == 0)
1609         {
1610           if(count >= lines * STACK_VALUES_PER_LINE)
1611             break;
1612           fprintf(stderr,"\nSpA[%ld] (0x%08lx): ",count-1,stackptr);
1613         }
1614       fprintf(stderr,"0x%08lx ",(W_) *stackptr);
1615     }
1616   fprintf(stderr, "\n");
1617 }
1618
1619 void
1620 DEBUG_BSTACK(lines)
1621   I_ lines;
1622 {
1623   PP_ SpA  = SAVE_SpA;
1624   PP_ SuA  = SAVE_SuA;
1625   P_  SpB  = SAVE_SpB;
1626   P_  SuB  = SAVE_SuB;
1627
1628   P_    stackptr;
1629   I_ count = 0;
1630
1631   fprintf(stderr,"Dump of the Value Stack, SpB: 0x%08lx, BOS: 0x%08lx\n",
1632                 (W_) SpB, (W_) stackInfo.botB);
1633
1634   for (stackptr = SpB;
1635          SUBTRACT_B_STK(stackptr, stackInfo.botB) > 0;
1636          stackptr = stackptr + BREL(1))
1637       {
1638         if( count++ % STACK_VALUES_PER_LINE == 0)
1639           {
1640             if(count >= lines * STACK_VALUES_PER_LINE)
1641               break;
1642             fprintf(stderr,"\nSpB[%ld] (0x%08lx): ",count-1,stackptr);
1643           }
1644         fprintf(stderr,"0x%08lx ",(W_) *stackptr);
1645       }
1646   fprintf(stderr, "\n");
1647 }
1648 #endif /* not concurrent */
1649
1650 /*
1651   This should disentangle update frames from both stacks.
1652 */
1653
1654 #ifndef CONCURRENT
1655 void
1656 DEBUG_UPDATES(limit)
1657   I_ limit;
1658 {
1659   PP_ SpA  = SAVE_SpA;
1660   PP_ SuA  = SAVE_SuA;
1661   P_  SpB  = SAVE_SpB;
1662   P_  SuB  = SAVE_SuB;
1663
1664   P_  updatee, retreg;
1665   PP_ sua, spa;
1666   P_  sub, spb;
1667   I_  count = 0;
1668
1669   fprintf(stderr,"Update Frame Stack Dump:\n\n");
1670
1671   for(spa = SuA, spb = SuB;
1672       SUBTRACT_B_STK(spb, stackInfo.botB) > 0 && count++ < limit;
1673       spa = GRAB_SuA(spb), spb = GRAB_SuB(spb) ) {
1674
1675       updatee = GRAB_UPDATEE(spb);         /* Thing to be updated  */
1676       retreg  = (P_) GRAB_RET(spb);        /* Return vector below */
1677
1678       fprintf(stderr,"SuA: 0x%08lx, SuB: 0x%08lx, Updatee 0x%08lx (Info 0x%08lx), RetReg 0x%x\n",
1679                      (W_) spa, (W_) spb,
1680                      (W_) updatee, (W_) INFO_PTR(updatee), (W_) retreg);
1681   }
1682 }
1683
1684 #endif /* not concurrent */
1685 \end{code}
1686
1687 \begin{code}
1688 #ifdef CONCURRENT
1689
1690 void
1691 DEBUG_TSO(P_ tso)
1692 {
1693     STGRegisterTable *r = TSO_INTERNAL_PTR(tso);
1694     W_ liveness = r->rLiveness;
1695     I_ i;
1696
1697     fprintf(stderr,"TSO:\ntso=%lx, regs=%lx, liveness=%lx\nlink=%lx,name=%lx,id=%lx,type=%lx,pc1=%lx,arg1=%lx,switch=%lx\n"
1698             , tso
1699             , r
1700             , liveness
1701             , TSO_LINK(tso)
1702             , TSO_NAME(tso)
1703             , TSO_ID(tso)
1704             , TSO_TYPE(tso)
1705             , TSO_PC1(tso)
1706             , TSO_ARG1(tso)
1707             , TSO_SWITCH(tso)
1708             );
1709
1710     for (i = 0; liveness != 0; liveness >>= 1, i++) {
1711         if (liveness & 1) {
1712             fprintf(stderr, "live reg %d (%lx)\n",i, r->rR[i].p);
1713         } else {
1714             fprintf(stderr, "reg %d (%lx) not live\n", i, r->rR[i].p);
1715         }
1716     }
1717 }
1718
1719 #endif /* concurrent */
1720 \end{code}