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
  67 \begin{code}
  68 #if defined(RUNTIME_DEBUGGING)
  69
  70 #include "rtsdefs.h"
  71 \end{code}
  72
  73 \subsection[StgDebug_Symbol_Tables]{Loading Symbol Tables}
  74
  75 NB: this assumes a.out files - won't work on Alphas.
  76 ToDo: At least add some #ifdefs
  77
  78 \begin{code}
  79 #include <a.out.h>
  80 #include <stab.h>
  81 /* #include <nlist.h> */
  82
  83 #include <stdio.h>
  84
  85 #define FROM_START 0  /* for fseek */
  86
  87 /* Simple lookup table */
  88
  89 /* Current implementation is pretty dumb! */
  90
  91 struct entry {
  92   unsigned value;
  93   int index;
  94   char *name;
  95 };
  96
  97 static int table_uninitialised = 1;
  98 static int max_table_size;
  99 static int table_size;
 100 static struct entry* table;
 101
 102 static
 103 void reset_table( int size )
 104 {
 105   max_table_size = size;
 106   table_size = 0;
 107   table = (struct entry *) malloc( size * sizeof( struct entry ) );
 108 }
 109
 110 static
 111 void prepare_table()
 112 {
 113   /* Could sort it... */
 114 }
 115
 116 static
 117 void insert( unsigned value, int index, char *name )
 118 {
 119   if ( table_size >= max_table_size ) {
 120     fprintf( stderr, "Symbol table overflow\n" );
 121     exit( 1 );
 122   }
 123   table[table_size].value = value;
 124   table[table_size].index = index;
 125   table[table_size].name = name;
 126   table_size = table_size + 1;
 127 }
 128
 129 static
 130 int lookup( unsigned value, int *result )
 131 {
 132   int i;
 133   for( i = 0; i < table_size && table[i].value != value; ++i ) {
 134   }
 135   if (i < table_size) {
 136     *result = table[i].index;
 137     return 1;
 138   } else {
 139     return 0;
 140   }
 141 }
 142
 143 static int lookup_name( char *name, unsigned *result )
 144 {
 145   int i;
 146   for( i = 0; i < table_size && strcmp(name,table[i].name) != 0; ++i ) {
 147   }
 148   if (i < table_size) {
 149     *result = table[i].value;
 150     return 1;
 151   } else {
 152     return 0;
 153   }
 154 }
 155 \end{code}
 156
 157 * Z-escapes:
 158     "std"++xs -> "Zstd"++xs
 159     char_to_c 'Z'  = "ZZ"
 160     char_to_c '&'  = "Za"
 161     char_to_c '|'  = "Zb"
 162     char_to_c ':'  = "Zc"
 163     char_to_c '/'  = "Zd"
 164     char_to_c '='  = "Ze"
 165     char_to_c '>'  = "Zg"
 166     char_to_c '#'  = "Zh"
 167     char_to_c '<'  = "Zl"
 168     char_to_c '-'  = "Zm"
 169     char_to_c '!'  = "Zn"
 170     char_to_c '.'  = "Zo"
 171     char_to_c '+'  = "Zp"
 172     char_to_c '\'' = "Zq"
 173     char_to_c '*'  = "Zt"
 174     char_to_c '_'  = "Zu"
 175     char_to_c c    = "Z" ++ show (ord c)
 176
 177 \begin{code}
 178 static char unZcode( char ch )
 179 {
 180   switch (ch) {
 181   case 'Z' :
 182   case '\0' :
 183     return ('Z');
 184   case 'a' :
 185     return ('&');
 186   case 'b' :
 187     return ('|');
 188   case 'c' :
 189     return (':');
 190   case 'd' :
 191     return ('/');
 192   case 'e' :
 193     return ('=');
 194   case 'g' :
 195     return ('>');
 196   case 'h' :
 197     return ('#');
 198   case 'l' :
 199     return ('<');
 200   case 'm' :
 201     return ('-');
 202   case 'n' :
 203     return ('!');
 204   case 'o' :
 205     return ('.');
 206   case 'p' :
 207     return ('+');
 208   case 'q' :
 209     return ('\'');
 210   case 't' :
 211     return ('*');
 212   case 'u' :
 213     return ('_');
 214   default :
 215     return (ch);
 216   }
 217 }
 218
 219 /* Precondition: out big enough to handle output (about twice length of in) */
 220 static void enZcode( char *in, char *out )
 221 {
 222   int i, j;
 223
 224   j = 0;
 225   out[ j++ ] = '_';
 226   for( i = 0; in[i] != '\0'; ++i ) {
 227     switch (in[i]) {
 228     case 'Z'  :
 229       out[j++] = 'Z';
 230       out[j++] = 'Z';
 231       break;
 232     case '&'  :
 233       out[j++] = 'Z';
 234       out[j++] = 'a';
 235       break;
 236     case '|'  :
 237       out[j++] = 'Z';
 238       out[j++] = 'b';
 239       break;
 240     case ':'  :
 241       out[j++] = 'Z';
 242       out[j++] = 'c';
 243       break;
 244     case '/'  :
 245       out[j++] = 'Z';
 246       out[j++] = 'd';
 247       break;
 248     case '='  :
 249       out[j++] = 'Z';
 250       out[j++] = 'e';
 251       break;
 252     case '>'  :
 253       out[j++] = 'Z';
 254       out[j++] = 'g';
 255       break;
 256     case '#'  :
 257       out[j++] = 'Z';
 258       out[j++] = 'h';
 259       break;
 260     case '<'  :
 261       out[j++] = 'Z';
 262       out[j++] = 'l';
 263       break;
 264     case '-'  :
 265       out[j++] = 'Z';
 266       out[j++] = 'm';
 267       break;
 268     case '!'  :
 269       out[j++] = 'Z';
 270       out[j++] = 'n';
 271       break;
 272     case '.'  :
 273       out[j++] = 'Z';
 274       out[j++] = 'o';
 275       break;
 276     case '+'  :
 277       out[j++] = 'Z';
 278       out[j++] = 'p';
 279       break;
 280     case '\'' :
 281       out[j++] = 'Z';
 282       out[j++] = 'q';
 283       break;
 284     case '*'  :
 285       out[j++] = 'Z';
 286       out[j++] = 't';
 287       break;
 288     case '_'  :
 289       out[j++] = 'Z';
 290       out[j++] = 'u';
 291       break;
 292     default :
 293       out[j++] = in[i];
 294       break;
 295     }
 296   }
 297   out[j] = '\0';
 298 }
 299 \end{code}
 300
 301 \begin{code}
 302 static int lookupForName( P_ addr, char **result )
 303 {
 304   int i;
 305   for( i = 0; i < table_size && table[i].value != (unsigned) addr; ++i ) {
 306   }
 307   if (i < table_size) {
 308     *result = table[i].name;
 309     return 1;
 310   } else {
 311     return 0;
 312   }
 313 }
 314
 315 static void printZcoded( char *raw )
 316 {
 317   int j;
 318
 319   /* start at 1 to skip the leading "_" */
 320   for( j = 1; raw[j] != '\0'; /* explicit */) {
 321     if (raw[j] == 'Z') {
 322       putchar(unZcode(raw[j+1]));
 323       j = j + 2;
 324     } else {
 325       putchar(raw[j]);
 326       j = j + 1;
 327     }
 328   }
 329 }
 330
 331 static void printName( P_ addr )
 332 {
 333   char *raw;
 334
 335   if (lookupForName( addr, &raw )) {
 336     printZcoded(raw);
 337   } else {
 338     printf("0x%x", addr);
 339   }
 340 }
 341
 342 /* Fairly ad-hoc piece of code that seems to filter out a lot of
 343    rubbish like the obj-splitting symbols */
 344
 345 static
 346 int isReal( unsigned char type, char *name )
 347 {
 348   int external = type & N_EXT;
 349   int tp = type & N_TYPE;
 350
 351   if (tp == N_TEXT || tp == N_DATA) {
 352     return( name[0] == '_' && name[1] != '_' );
 353   } else {
 354     return( 0 );
 355   }
 356 }
 357
 358 void DEBUG_LoadSymbols( char *name )
 359 {
 360   FILE *binary;
 361
 362   struct exec header;
 363
 364   long sym_offset;
 365   long sym_size;
 366   long num_syms;
 367   long num_real_syms;
 368   struct nlist *symbol_table;
 369
 370   long str_offset;
 371   long str_size; /* assumed 4 bytes.... */
 372   char *string_table;
 373
 374   long i;
 375
 376   binary = fopen( name, "r" );
 377   if (binary == NULL) {
 378     fprintf( stderr, "Can't open symbol table file \"%s\".\n", name );
 379   }
 380
 381
 382   if (fread( &header,  sizeof( struct exec ), 1, binary ) != 1) {
 383     fprintf( stderr, "Can't read symbol table header.\n" );
 384     exit( 1 );
 385   }
 386   if ( N_BADMAG( header ) ) {
 387     fprintf( stderr, "Bad magic number in symbol table header.\n" );
 388     exit( 1 );
 389   }
 390
 391
 392
 393   sym_offset = N_SYMOFF( header );
 394   sym_size = header.a_syms;
 395   num_syms = sym_size / sizeof( struct nlist );
 396   fseek( binary, sym_offset, FROM_START );
 397
 398   symbol_table = (struct nlist *) malloc( sym_size );
 399   if (symbol_table == NULL) {
 400     fprintf( stderr, "Can't allocate symbol table of size %d\n", sym_size );
 401     exit( 1 );
 402   }
 403
 404   printf("Reading %d symbols\n", num_syms);
 405
 406   if (fread( symbol_table, sym_size, 1, binary ) != 1) {
 407     fprintf( stderr, "Can't read symbol table\n");
 408     exit( 1 );
 409   }
 410
 411
 412
 413   str_offset = N_STROFF( header );
 414   fseek( binary, str_offset, FROM_START );
 415
 416   if (fread( &str_size, 4, 1, binary ) != 1) {
 417     fprintf( stderr, "Can't read string table size\n");
 418     exit( 1 );
 419   }
 420
 421   /* apparently the size of the string table includes the 4 bytes that
 422    * store the size...
 423    */
 424   string_table = (char *) malloc( str_size );
 425   if (string_table == NULL) {
 426     fprintf( stderr, "Can't allocate string table of size %d\n", str_size );
 427     exit( 1 );
 428   }
 429
 430   if (fread( string_table+4, str_size-4, 1, binary ) != 1) {
 431     fprintf( stderr, "Can't read string table\n");
 432     exit( 1 );
 433   }
 434
 435   num_real_syms = 0;
 436   for( i = 0; i != num_syms; ++i ) {
 437     unsigned char type = symbol_table[i].n_type;
 438     unsigned value = symbol_table[i].n_value;
 439     char *str = &string_table[symbol_table[i].n_un.n_strx];
 440
 441     if ( isReal( type, str ) ) {
 442       num_real_syms = num_real_syms + 1;
 443     }
 444   }
 445
 446   printf("Of which %d are real symbols\n", num_real_syms);
 447
 448 /*
 449   for( i = 0; i != num_syms; ++i ) {
 450     unsigned char type = symbol_table[i].n_type;
 451     unsigned value = symbol_table[i].n_value;
 452     char *str = &string_table[symbol_table[i].n_un.n_strx];
 453
 454     if ( isReal(type, str) ) {
 455       printf("Symbol %d. Extern? %c. Type: %c. Value: 0x%x. Name: %s\n",
 456              i,
 457              (external ? 'y' : 'n'),
 458              type,
 459              value,
 460              str
 461              );
 462     }
 463   }
 464 */
 465
 466   reset_table( num_real_syms );
 467
 468   for( i = 0; i != num_syms; ++i ) {
 469     unsigned char type = symbol_table[i].n_type;
 470     unsigned value = symbol_table[i].n_value;
 471     char *str = &string_table[symbol_table[i].n_un.n_strx];
 472
 473     if ( isReal( type, str ) ) {
 474       insert( value, i, str );
 475     }
 476
 477   }
 478
 479   prepare_table();
 480 }
 481 \end{code}
 482
 483 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 484 %
 485 \subsection[StgDebug_PrettyPrinting]{Pretty printing internal structures}
 486 %
 487 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 488
 489 \begin{code}
 490 #include "../storage/SMinternal.h"
 491
 492 #ifdef GCap
 493 #define HP_BOT appelInfo.oldbase
 494 #elif GCdu
 495 #define HP_BOT dualmodeInfo.modeinfo[dualmodeInfo.mode].base
 496 #elif GC2s
 497 #define HP_BOT semispaceInfo[semispace].base
 498 #elif GC1s
 499 #define HP_BOT compactingInfo.base
 500 #else
 501   unknown garbage collector - help, help!
 502 #endif
 503 \end{code}
 504
 505 \begin{code}
 506 /* range: 0..NUM_LEVELS_OF_DETAIL-1.  Level of machine-related detail shown */
 507 #define NUM_LEVELS_OF_DETAIL 3
 508 static int DEBUG_details = 2;
 509 \end{code}
 510
 511 \begin{code}
 512 /* Determine the size and number of pointers for this kind of closure */
 513 static
 514 void
 515 getClosureShape( P_ node, int *vhs, int *size, int *ptrs, char **type )
 516 {
 517   /* The result is used for printing out closure contents.  If the
 518      info-table is mince, we'd better conservatively guess there's
 519      nothing in the closure to avoid chasing non-ptrs. */
 520   *vhs = 0;
 521   *size = 0;
 522   *ptrs = 0;
 523   *type = "*unknown info type*";
 524
 525     /* ToDo: if in garbage collector, consider subtracting some weird offset which some GCs add to infoptr */
 526
 527   /* The order here precisely reflects that in SMInfoTables.lh to make
 528      it easier to check that this list is complete. */
 529   switch(INFO_TYPE(INFO_PTR(node)))
 530     {
 531       case INFO_SPEC_U_TYPE:
 532         *vhs = 0; /* by decree */
 533         *size = SPEC_CLOSURE_SIZE(node);
 534         *ptrs = SPEC_CLOSURE_NoPTRS(node);
 535         *type = "SPECU";
 536         break;
 537       case INFO_SPEC_N_TYPE:
 538         *vhs = 0; /* by decree */
 539         *size = SPEC_CLOSURE_SIZE(node);
 540         *ptrs = SPEC_CLOSURE_NoPTRS(node);
 541         *type = "SPECN";
 542         break;
 543
 544       case INFO_GEN_U_TYPE:
 545         *vhs = GEN_VHS;
 546         *size = GEN_CLOSURE_SIZE(node);
 547         *ptrs = GEN_CLOSURE_NoPTRS(node);
 548         *type = "GENU";
 549         break;
 550       case INFO_GEN_N_TYPE:
 551         *vhs = GEN_VHS;
 552         *size = GEN_CLOSURE_SIZE(node);
 553         *ptrs = GEN_CLOSURE_NoPTRS(node);
 554         *type = "GENN";
 555         break;
 556
 557       case INFO_DYN_TYPE:
 558         *vhs = DYN_VHS;
 559         *size = DYN_CLOSURE_SIZE(node);
 560         *ptrs = DYN_CLOSURE_NoPTRS(node);
 561         *type = "DYN";
 562         break;
 563
 564       case INFO_TUPLE_TYPE:
 565         *vhs = TUPLE_VHS;
 566         *size = TUPLE_CLOSURE_SIZE(node);
 567         *ptrs = TUPLE_CLOSURE_NoPTRS(node);
 568         *type = "TUPLE";
 569         break;
 570
 571       case INFO_DATA_TYPE:
 572         *vhs = DATA_VHS;
 573         *size = DATA_CLOSURE_SIZE(node);
 574         *ptrs = DATA_CLOSURE_NoPTRS(node);
 575         *type = "DATA";
 576         break;
 577
 578       case INFO_MUTUPLE_TYPE:
 579         *vhs = MUTUPLE_VHS;
 580         *size = MUTUPLE_CLOSURE_SIZE(node);
 581         *ptrs = MUTUPLE_CLOSURE_NoPTRS(node);
 582         *type = "MUTUPLE";
 583         break;
 584
 585       case INFO_IMMUTUPLE_TYPE:
 586         *vhs = MUTUPLE_VHS;
 587         *size = MUTUPLE_CLOSURE_SIZE(node);
 588         *ptrs = MUTUPLE_CLOSURE_NoPTRS(node);
 589         *type = "IMMUTUPLE";
 590         break;
 591
 592       case INFO_STATIC_TYPE:
 593         *vhs = STATIC_VHS;
 594         *size = INFO_SIZE(INFO_PTR(node));
 595         *ptrs = INFO_NoPTRS(INFO_PTR(node));
 596         *type = "STATIC";
 597         break;
 598
 599       case INFO_CONST_TYPE:
 600         *vhs = 0;
 601         *size = 0;
 602         *ptrs = 0;
 603         *type = "CONST";
 604         break;
 605
 606       case INFO_CHARLIKE_TYPE:
 607         *vhs = 0;
 608         *size = 1;
 609         *ptrs = 0;
 610         *type = "CHAR";
 611         break;
 612
 613       case INFO_INTLIKE_TYPE:
 614         *vhs = 0;
 615         *size = 1;
 616         *ptrs = 0;
 617         *type = "INT";
 618         break;
 619
 620       case INFO_BH_TYPE:
 621         *vhs = 0;
 622         *size = INFO_SIZE(INFO_PTR(node));
 623         *ptrs = 0;
 624         *type = "BHOLE";
 625         break;
 626
 627 /* most of the following are plausible guesses (particularily VHSs) ADR */
 628       case INFO_BQ_TYPE:
 629 #ifdef CONCURRENT
 630         *vhs = 0;
 631         *size = BQ_CLOSURE_SIZE(node);
 632         *ptrs = BQ_CLOSURE_NoPTRS(node);
 633         *type = "BQ";
 634 #else
 635         printf("Panic: found BQ Infotable in non-threaded system.\n");
 636 #endif
 637         break;
 638
 639       case INFO_IND_TYPE:
 640         *vhs = 0;
 641         *size = IND_CLOSURE_SIZE(node);
 642         *ptrs = IND_CLOSURE_NoPTRS(node);
 643         *type = "IND";
 644         break;
 645
 646       case INFO_CAF_TYPE:
 647         *vhs = 0; /* ?? ADR */
 648         *size = INFO_SIZE(INFO_PTR(node));
 649         *ptrs = 0;
 650         *type = "CAF";
 651         break;
 652
 653       case INFO_FETCHME_TYPE:
 654 #ifdef PAR
 655         *vhs = FETCHME_VHS;
 656         *size = FETCHME_CLOSURE_SIZE(node);
 657         *ptrs = FETCHME_CLOSURE_PTRS(node);
 658         *type = "FETCHME";
 659 #else
 660         printf("Panic: found FETCHME Infotable in sequential system.\n");
 661 #endif
 662         break;
 663
 664       case INFO_FMBQ_TYPE:
 665 #ifdef PAR
 666         *vhs = FMBQ_VHS;
 667         *size = FMBQ_CLOSURE_SIZE(node);
 668         *ptrs = FMBQ_CLOSURE_PTRS(node);
 669         *type = "FMBQ";
 670 #else
 671         printf("Panic: found FMBQ Infotable in sequential system.\n");
 672 #endif
 673         break;
 674
 675       case INFO_BF_TYPE:
 676 #ifdef PAR
 677         *vhs = 0;
 678         *size = 0;
 679         *ptrs = 0;
 680         *type = "BlockedFetch";
 681 #else
 682         printf("Panic: found BlockedFetch Infotable in sequential system.\n");
 683 #endif
 684         break;
 685
 686       case INFO_TSO_TYPE:
 687         /* Conservative underestimate: this will contain a regtable
 688            which comes nowhere near fitting the standard "p ptrs; s-p
 689            non-ptrs" format. ADR */
 690 #ifdef CONCURRENT
 691         *vhs = TSO_VHS;
 692         *size = 0;
 693         *ptrs = 0;
 694         *type = "TSO";
 695 #else
 696         printf("Panic: found TSO Infotable in non-threaded system.\n");
 697 #endif
 698         break;
 699
 700       case INFO_STKO_TYPE:
 701         /* Conservative underestimate: this will contain stuff
 702            which comes nowhere near fitting the standard "p ptrs; s-p
 703            non-ptrs" format. JSM */
 704 #ifdef CONCURRENT
 705         *vhs = STKO_VHS;
 706         *size = 0;
 707         *ptrs = 0;
 708         *type = "STKO";
 709 #else
 710         printf("Panic: found STKO Infotable in non-threaded system.\n");
 711 #endif
 712         break;
 713
 714       /* There are no others in SMInfoTables.lh 11/5/94 ADR*/
 715       default:
 716         printf("Invalid/unknown info type %d\n", INFO_TYPE(INFO_PTR(node)));
 717         break;
 718     }
 719 }
 720
 721 static
 722 void
 723 printWord( W_ word )
 724 {
 725   printf("0x%08lx", word);
 726 }
 727
 728 static
 729 void
 730 printAddress( P_ address )
 731 {
 732 #ifdef PAR
 733   PP_ SpA  = STKO_SpA(SAVE_StkO);
 734   PP_ SuA  = STKO_SuA(SAVE_StkO);
 735   P_  SpB  = STKO_SpB(SAVE_StkO);
 736   P_  SuB  = STKO_SuB(SAVE_StkO);
 737 #else
 738   PP_ SpA  = SAVE_SpA;
 739   PP_ SuA  = SAVE_SuA;
 740   P_  SpB  = SAVE_SpB;
 741   P_  SuB  = SAVE_SuB;
 742 #endif
 743   P_  Hp   = SAVE_Hp;
 744
 745   PP_ botA = stackInfo.botA;
 746   P_ botB  = stackInfo.botB;
 747   P_ HpBot = HP_BOT;
 748
 749   char *name;
 750
 751   /* ToDo: check if it's in text or data segment. */
 752
 753   /* The @-1@s in stack comparisions are because we sometimes use the
 754      address of just below the stack... */
 755
 756   if (lookupForName( address, &name )) {
 757     printZcoded( name );
 758   } else {
 759     if (DEBUG_details > 1) {
 760       printWord( (W_) address );
 761       printf(" : ");
 762     }
 763     if (HpBot <= address && address < Hp) {
 764       printf("Hp[%d]", address - HpBot);
 765     } else if (SUBTRACT_A_STK((PP_)address, botA) >= -1 && SUBTRACT_A_STK(SpA, (PP_)address) >= 0) {
 766       printf("SpA[%d]", SUBTRACT_A_STK((PP_)address, botA));
 767     } else if (SUBTRACT_B_STK(address, botB) >= -1 && SUBTRACT_B_STK(SpB, address) >= 0) {
 768       /* ToDo: check if it's an update frame */
 769       printf("SpB[%d]", SUBTRACT_B_STK(address, botB));
 770     } else {
 771       printWord( (W_) address );
 772     }
 773   }
 774 }
 775
 776 static
 777 void
 778 printIndentation( int indentation )
 779 {
 780   int i;
 781   for (i = 0; i < indentation; ++i) { printf("  "); }
 782 }
 783
 784 /* The weight parameter is used to (eventually) break cycles */
 785 static
 786 void
 787 printStandardShapeClosure(
 788       int indentation,
 789       int weight,
 790       P_ closure, int vhs, int size, int noPtrs
 791 )
 792 {
 793 #ifdef PAR
 794   PP_ SpA  = STKO_SpA(SAVE_StkO);
 795   PP_ SuA  = STKO_SuA(SAVE_StkO);
 796   P_  SpB  = STKO_SpB(SAVE_StkO);
 797   P_  SuB  = STKO_SuB(SAVE_StkO);
 798 #else
 799   PP_ SpA  = SAVE_SpA;
 800   PP_ SuA  = SAVE_SuA;
 801   P_  SpB  = SAVE_SpB;
 802   P_  SuB  = SAVE_SuB;
 803 #endif
 804   P_ Hp    = SAVE_Hp;
 805
 806   extern void printClosure PROTO( (P_, int, int) );
 807   int numValues = size - vhs;
 808   P_ HpBot = HP_BOT;
 809
 810   if (DEBUG_details > 1) {
 811     printAddress( closure );
 812     printf(": ");
 813   }
 814   printName((P_)INFO_PTR(closure));
 815
 816   if ( numValues > 0 ) {
 817     int newWeight = weight-1 ;
 818         /* I've tried dividing the weight by size to share it out amongst
 819            sub-closures - but that didn't work too well. */
 820
 821     if (newWeight > 0) {
 822       int i=0;
 823       printf("(\n");
 824       while (i < numValues) {
 825         P_ data = (P_) closure[_FHS + vhs + i];
 826
 827         printIndentation(indentation+1);
 828         if (i < noPtrs) {
 829           printClosure( data, indentation+1, newWeight);
 830         } else {
 831           printAddress( data );
 832         }
 833         i = i + 1;
 834         if (i < numValues) printf(",\n");
 835       }
 836       printf(")");
 837     } else {
 838       int i;
 839       printf("(_");
 840       for( i = 1; i < size; ++i ) {
 841         printf(",_");
 842       }
 843       printf(")");
 844     }
 845   }
 846 }
 847
 848 /* Should be static but has to be extern to allow mutual recursion */
 849 void
 850 printClosure( P_ closure, int indentation, int weight )
 851 {
 852   int vhs, size, ptrs;
 853   char *type;
 854
 855   /* I'd love to put a test here that this actually _is_ a closure -
 856      but testing that it is in the heap is overly strong. */
 857
 858   getClosureShape(closure, &vhs, &size, &ptrs, &type);
 859
 860   /* The order here precisely reflects that in SMInfoTables.lh to make
 861      it easier to check that this list is complete. */
 862   switch(INFO_TYPE(INFO_PTR(closure))) {
 863   case INFO_SPEC_U_TYPE:
 864   case INFO_SPEC_N_TYPE:
 865   case INFO_GEN_U_TYPE:
 866   case INFO_GEN_N_TYPE:
 867   case INFO_DYN_TYPE:
 868   case INFO_TUPLE_TYPE:
 869   case INFO_DATA_TYPE:
 870   case INFO_MUTUPLE_TYPE:
 871   case INFO_IMMUTUPLE_TYPE:
 872     printStandardShapeClosure(indentation, weight, closure,
 873                               vhs, size, ptrs);
 874     break;
 875
 876   case INFO_STATIC_TYPE:
 877     /* If the STATIC contains Floats or Doubles, we can't print it. */
 878     /* And we can't always rely on the size/ptrs info either */
 879     printAddress( closure );
 880     printf(" STATIC");
 881     break;
 882
 883   case INFO_CONST_TYPE:
 884     if (DEBUG_details > 1) {
 885       printAddress( closure );
 886       printf(": ");
 887     }
 888     printName((P_)INFO_PTR(closure));
 889     break;
 890
 891   case INFO_CHARLIKE_TYPE:
 892     /* ToDo: check for non-printable characters */
 893     if (DEBUG_details > 1) printf("CHARLIKE ");
 894     printf("\'%c\'", (unsigned char) CHARLIKE_VALUE(closure));
 895     break;
 896
 897   case INFO_INTLIKE_TYPE:
 898     if (DEBUG_details > 1) printf("INTLIKE ");
 899     printf("%d",INTLIKE_VALUE(closure));
 900     break;
 901
 902   case INFO_BH_TYPE:
 903     /* Is there anything to say here> */
 904     if (DEBUG_details > 1) {
 905       printAddress( closure );
 906       printf(": ");
 907     }
 908     printName((P_)INFO_PTR(closure));
 909     break;
 910
 911 /* most of the following are just plausible guesses (particularily VHSs) ADR */
 912
 913   case INFO_BQ_TYPE:
 914 #ifdef CONCURRENT
 915     printStandardShapeClosure(indentation, weight, closure,
 916                               vhs, size, ptrs);
 917 #else
 918     printf("Panic: found BQ Infotable in non-threaded system.\n");
 919 #endif
 920     break;
 921
 922   case INFO_IND_TYPE:
 923     if (DEBUG_details > 0) {
 924       printAddress( closure );
 925       printf(" IND: ");
 926     }
 927     printClosure( (P_) IND_CLOSURE_PTR(closure), indentation, weight );
 928     break;
 929
 930   case INFO_CAF_TYPE:
 931     if (DEBUG_details > 0) {
 932       printAddress( closure );
 933       printf(" CAF: ");
 934     }
 935     printClosure( (P_) IND_CLOSURE_PTR(closure), indentation, weight );
 936     break;
 937
 938   case INFO_FETCHME_TYPE:
 939 #ifdef PAR
 940     printStandardShapeClosure(indentation, weight, closure,
 941                               vhs, size, ptrs);
 942 #else
 943     printf("Panic: found FETCHME Infotable in sequential system.\n");
 944 #endif
 945     break;
 946
 947   case INFO_FMBQ_TYPE:
 948 #ifdef PAR
 949     printStandardShapeClosure(indentation, weight, closure,
 950                               vhs, size, ptrs);
 951 #else
 952     printf("Panic: found FMBQ Infotable in sequential system.\n");
 953 #endif
 954     break;
 955
 956   case INFO_BF_TYPE:
 957 #ifdef PAR
 958     printStandardShapeClosure(indentation, weight, closure,
 959                               vhs, size, ptrs);
 960 #else
 961     printf("Panic: found BlockedFetch Infotable in sequential system.\n");
 962 #endif
 963     break;
 964
 965   case INFO_TSO_TYPE:
 966 #ifdef CONCURRENT
 967     /* A TSO contains a regtable... */
 968     printAddress( closure );
 969     printf(" TSO: ...");
 970 #else
 971     printf("Panic: found TSO Infotable in non-threaded system.\n");
 972 #endif
 973     break;
 974
 975     case INFO_STKO_TYPE:
 976 #ifdef CONCURRENT
 977     /* A STKO contains parts of the A and B stacks... */
 978     printAddress( closure );
 979     printf(" STKO: ...");
 980 #else
 981     printf("Panic: found STKO Infotable in non-threaded system.\n");
 982 #endif
 983     break;
 984
 985   /* There are no others in SMInfoTables.lh 11/5/94 ADR*/
 986   default:
 987     printf("Invalid/unknown info type %d\n", INFO_TYPE(INFO_PTR(closure)));
 988     break;
 989   }
 990 }
 991
 992 void
 993 DEBUG_NODE( P_ closure, int size )
 994 {
 995   printClosure( closure, 0, size );
 996   printf("\n");
 997 }
 998 \end{code}
 999
1000 Now some stuff for printing stacks - almost certainly doesn't work
1001 under threads which keep the stack on the heap.
1002
1003 \begin{code}
1004 #ifndef CONCURRENT
1005
1006 static int
1007 minimum(int a, int b)
1008 {
1009   if (a < b) {
1010     return a;
1011   } else {
1012     return b;
1013   }
1014 }
1015
1016 void DEBUG_PrintA( int depth, int weight )
1017 {
1018   PP_ SpA  = SAVE_SpA;
1019   PP_ SuA  = SAVE_SuA;
1020   P_  SpB  = SAVE_SpB;
1021   P_  SuB  = SAVE_SuB;
1022   P_ Hp    = SAVE_Hp;
1023
1024   int i;
1025   I_ size = minimum(depth, SUBTRACT_A_STK(SpA, stackInfo.botA)+1);
1026
1027   printf("Dump of the Address Stack (SpA = 0x%x, SuA = 0x%x)\n", SpA, SuA);
1028
1029   for( i = 0; i < size; ++i ) {
1030     printIndentation(1);
1031     printf("SpA[%ld] (0x%08lx):", i, SpA + AREL(i));
1032     printClosure((P_)*(SpA + AREL(i)), 2, weight);
1033     printf("\n");
1034   }
1035 }
1036
1037 void DEBUG_PrintB( int depth, int weight )
1038 {
1039   PP_ SpA  = SAVE_SpA;
1040   PP_ SuA  = SAVE_SuA;
1041   P_  SpB  = SAVE_SpB;
1042   P_  SuB  = SAVE_SuB;
1043   P_ Hp    = SAVE_Hp;
1044
1045   I_ i;
1046   I_ size = minimum(depth, SUBTRACT_B_STK(SpB, stackInfo.botB)+1);
1047
1048   P_ updateFramePtr;
1049   I_ update_count;
1050
1051   printf("Dump of the Value Stack (SpB = 0x%x, SuB = 0x%x)\n", SpB, SuB);
1052
1053   updateFramePtr = SuB;
1054   update_count = 0;
1055   i = 0;
1056   while (i < size) {
1057     if (updateFramePtr == SpB + BREL(i)) {
1058
1059       printIndentation(1);
1060       printf("SpB[%ld] (0x%08lx): UpdateFrame[%d](",
1061              i,
1062              updateFramePtr,
1063              update_count
1064              );
1065       printName( (P_) *(SpB + BREL(i)) );
1066       printf(", UF[%d] (= SpB[%ld]), SpA[%ld], ",
1067              update_count+1,
1068              SUBTRACT_B_STK(SpB, GRAB_SuB(updateFramePtr)),
1069              SUBTRACT_A_STK(SpA, GRAB_SuA(updateFramePtr))
1070              );
1071       printAddress( GRAB_UPDATEE(updateFramePtr) );
1072       printf(")\n");
1073
1074       printIndentation(2);
1075       printClosure( GRAB_UPDATEE(updateFramePtr), 3, weight );
1076       printf("\n");
1077
1078       updateFramePtr = GRAB_SuB(updateFramePtr);
1079       update_count = update_count + 1;
1080
1081       /* ToDo: GhcConstants.lh reveals that there are two other sizes possible */
1082       i = i + STD_UF_SIZE;
1083     } else {
1084       printIndentation(1);
1085       printf("SpB[%ld] (0x%08lx): ", i, SpB + BREL(i) );
1086       printName((P_) *(SpB + BREL(i)) );
1087       printf("\n");
1088       i = i + 1;
1089     }
1090   }
1091 }
1092 #endif /* not CONCURRENT */
1093 \end{code}
1094
1095 ToDo:
1096
1097    All the following code incorrectly assumes that the only return
1098    addresses are those associated with update frames.
1099
1100    To do a proper job of printing the environment we need to:
1101
1102    1) Recognise vectored and non-vectored returns on the B stack.
1103
1104    2) Know where the local variables are in the A and B stacks for
1105       each return situation.
1106
1107    Until then, we'll just need to look suspiciously at the
1108    "environment" being printed out.
1109
1110    ADR
1111
1112 \begin{code}
1113 /* How many real stacks are there on SpA and SpB? */
1114 static
1115 int numStacks( )
1116 {
1117 #ifdef PAR
1118   PP_ SpA  = STKO_SpA(SAVE_StkO);
1119   PP_ SuA  = STKO_SuA(SAVE_StkO);
1120   P_  SpB  = STKO_SpB(SAVE_StkO);
1121   P_  SuB  = STKO_SuB(SAVE_StkO);
1122 #else
1123   PP_ SpA  = SAVE_SpA;
1124   PP_ SuA  = SAVE_SuA;
1125   P_  SpB  = SAVE_SpB;
1126   P_  SuB  = SAVE_SuB;
1127 #endif
1128   P_  Hp   = SAVE_Hp;
1129
1130   int depth = 1; /* There's always at least one stack */
1131
1132   while (SUBTRACT_B_STK(SuB, stackInfo.botB) >= 0) {
1133     SuB = GRAB_SuB( SuB );
1134     depth = depth + 1;
1135   }
1136   return depth;
1137 }
1138
1139 static
1140 void printLocalAStack( int depth, int indentation, int weight, PP_ SpA, int size )
1141 {
1142   int i;
1143
1144   ASSERT( size >= 0 );
1145
1146   for( i = size-1; i >= 0; --i ) {
1147     printIndentation( indentation );
1148     printf("A[%ld][%ld]", depth, i);
1149     if (DEBUG_details > 1) printf(" (0x%08lx) ", SpA + AREL(i) );
1150     printf("=");
1151     printClosure( *(SpA + AREL(i)), indentation+2, weight );
1152     printf("\n");
1153   }
1154 }
1155
1156 static
1157 void printLocalBStack( int depth, int indentation, int weight, P_ SpB, int size )
1158 {
1159   int i;
1160
1161   ASSERT( size >= 0 );
1162
1163   for( i = size-1; i >= 0; --i) {
1164     printIndentation( indentation );
1165     printf("B[%ld][%ld]", depth, i);
1166     if (DEBUG_details > 1) printf(" (0x%08lx) ", SpB + BREL(i) );
1167     printf("=");
1168     printAddress( (P_) *(SpB + BREL(i)) );
1169     printf("\n");
1170   }
1171 }
1172
1173 static
1174 void printEnvironment( int depth, int indentation, int weight, PP_ SpA, PP_ SuA, P_ SpB, P_ SuB )
1175 {
1176   int sizeA = SUBTRACT_A_STK(SpA, SuA);
1177   int sizeB = SUBTRACT_B_STK(SpB, SuB);
1178
1179   if (sizeA + sizeB > 0) {
1180     printIndentation( indentation );
1181     printf("let\n");
1182
1183     printLocalAStack( depth, indentation+1, weight, SpA, sizeA );
1184     printLocalBStack( depth, indentation+1, weight, SpB, sizeB );
1185
1186     printIndentation( indentation );
1187     printf("in\n");
1188   }
1189 }
1190 \end{code}
1191
1192 Printing the current context is a little tricky.
1193
1194 Ideally, we would work from the bottom of the stack up to the top
1195 recursively printing the stuff nearer the top.
1196
1197 In practice, we have to work from the top down because the top
1198 contains info about how much data is below the current return address.
1199
1200 The result is that we have two recursive passes over the stacks: the
1201 first one prints the "cases" and the second one prints the
1202 continuations (vector tables, etc.)
1203
1204 Note that because we compress chains of update frames, the depth and
1205 indentation do not always change in step.
1206
1207 ToDo:
1208
1209 * detecting non-updating cases too
1210 * printing continuations (from vector tables) properly
1211 * printing sensible names in environment.
1212 * fix bogus nature of lets
1213
1214
1215 \begin{code}
1216 static int maxDepth = 5;
1217
1218 static
1219 int printCases( int depth, int weight, PP_ SpA, PP_ SuA, P_ SpB, P_ SuB )
1220 {
1221   int indentation;
1222
1223   if (depth < maxDepth && SUBTRACT_B_STK(SuB, stackInfo.botB) >= 0) {
1224     PP_ nextSpA, nextSuA;
1225     P_  nextSpB, nextSuB;
1226
1227     /* ToDo: GhcConstants.lh reveals that there are two other sizes of
1228        update frame possible */
1229     /* ToDo: botB is probably wrong in THREAD system */
1230
1231     nextSpB = SuB + BREL(STD_UF_SIZE);
1232     nextSuB = GRAB_SuB( SuB );
1233     nextSpA = SuA;
1234     nextSuA = GRAB_SuA( nextSuB );
1235
1236     indentation = printCases( depth+1, weight, nextSpA, nextSuA, nextSpB, nextSuB );
1237
1238     if (DEBUG_details > 1 || nextSpB != nextSuB) { /* show frame (even if adjacent to another) */
1239       printIndentation( indentation );
1240       printf("case\n");
1241       indentation = indentation + 1;
1242     }
1243     if (SpB != SuB) {
1244       /* next thing on stack is a return vector - no need to show it here. */
1245       SpB = SpB + BREL(1);
1246     }
1247     printEnvironment( depth, indentation, weight, SpA, SuA, SpB, SuB );
1248   } else {
1249     printf("...\n");
1250     indentation = 1;
1251   }
1252
1253   return indentation;
1254 }
1255
1256 /* ToDo: pay more attention to format of vector tables in SMupdate.lh */
1257
1258 static
1259 int isVTBLEntry( P_ entry )
1260 {
1261   char *raw;
1262
1263   if (lookupForName( entry, &raw )) {
1264     if ( strncmp( "_ret", raw, 4 ) == 0 ) {
1265       return 1;
1266     } else if ( strncmp( "_djn", raw, 4 ) == 0) {
1267       return 1;
1268     } else {
1269       return 0;
1270     }
1271   } else {
1272     return 0;
1273   }
1274 }
1275
1276 static
1277 void printVectorTable( int indentation, PP_ vtbl )
1278 {
1279   if (isVTBLEntry( (P_) vtbl )) { /* Direct return */
1280     printName( (P_) vtbl );
1281   } else {
1282     int i = 0;
1283     while( isVTBLEntry( vtbl[RVREL(i)] )) {
1284       printIndentation( indentation );
1285       printf( "%d -> ", i );
1286       printName( vtbl[RVREL(i)] );
1287       printf( "\n" );
1288       i = i + 1;
1289     }
1290   }
1291 }
1292
1293 static
1294 void printContinuations( int depth, int indentation, int weight, PP_ SpA, PP_ SuA, P_ SpB, P_ SuB )
1295 {
1296   if (depth < maxDepth && SUBTRACT_B_STK(SuB, stackInfo.botB) >= 0) {
1297     PP_ nextSpA, nextSuA;
1298     P_  nextSpB, nextSuB;
1299     int nextIndent = indentation; /* Indentation to print next frame at */
1300
1301     /* ToDo: GhcConstants.lh reveals that there are two other sizes of
1302        update frame possible */
1303     /* ToDo: botB is probably wrong in THREAD system */
1304
1305     /* ToDo: ASSERT that SuA == nextSuA */
1306
1307     nextSpB = SuB + BREL(STD_UF_SIZE);
1308     nextSuB = GRAB_SuB( SuB );
1309     nextSpA = SuA;
1310     nextSuA = GRAB_SuA( nextSuB );
1311
1312     if (DEBUG_details > 0) { /* print update information */
1313
1314       if (SpB != SuB) { /* start of chain of update frames */
1315         printIndentation( indentation );
1316         printf("of updatePtr ->\n");
1317         printIndentation( indentation+1 );
1318         printf("update\n");
1319       }
1320       printIndentation( indentation+2 );
1321       printClosure( (P_)*(SuB + BREL(UF_UPDATEE)), indentation+2, weight );
1322       printf(" := ");
1323       printName( (P_) *(SuB + BREL(UF_RET)) );
1324       printf("(updatePtr)\n");
1325
1326       if (nextSpB != nextSuB) { /* end of chain of update frames */
1327         nextIndent = nextIndent-1;
1328         printVectorTable( indentation+1, (PP_) *(nextSpB) );
1329       }
1330     } else {
1331       if (nextSpB != nextSuB) { /* end of chain of update frames */
1332         nextIndent = nextIndent-1;
1333         printVectorTable( indentation, (PP_) *(nextSpB) );
1334       }
1335     }
1336     printContinuations( depth+1, nextIndent, weight, nextSpA, nextSuA, nextSpB, nextSuB );
1337
1338   } else {
1339     printf("...\n");
1340   }
1341 }
1342
1343
1344 void DEBUG_Where( int depth, int weight )
1345 {
1346 #ifdef PAR
1347   PP_ SpA  = STKO_SpA(SAVE_StkO);
1348   PP_ SuA  = STKO_SuA(SAVE_StkO);
1349   P_  SpB  = STKO_SpB(SAVE_StkO);
1350   P_  SuB  = STKO_SuB(SAVE_StkO);
1351 #else
1352   PP_ SpA  = SAVE_SpA;
1353   PP_ SuA  = SAVE_SuA;
1354   P_  SpB  = SAVE_SpB;
1355   P_  SuB  = SAVE_SuB;
1356 #endif
1357   P_ Hp    = SAVE_Hp;
1358   StgRetAddr RetReg = SAVE_Ret;
1359   P_ Node  = SAVE_R1.p;
1360
1361   int indentation;
1362
1363   maxDepth = depth;
1364
1365   printf("WARNING: Non-updating cases may be incorrectly displayed\n");
1366
1367   indentation = printCases( 1, weight, SpA, SuA, SpB, SuB );
1368
1369   printIndentation( indentation );
1370   printf("CASE\n");
1371
1372   printIndentation( indentation+1 );
1373   printName( Node );
1374   printf("\n");
1375   printVectorTable( indentation+1, (PP_) RetReg );
1376
1377   printContinuations( depth, indentation, weight, SpA, SuA, SpB, SuB );
1378 }
1379 \end{code}
1380
1381
1382 \begin{code}
1383 #if defined(RUNTIME_DEBUGGING)
1384
1385 void
1386 DEBUG_INFO_TABLE(node)
1387 P_ node;
1388 {
1389   int vhs, size, ptrs; /* not used */
1390   char *ip_type;
1391   StgPtr info_ptr = (StgPtr) INFO_PTR(node);
1392
1393   getClosureShape(node, &vhs, &size, &ptrs, &ip_type);
1394
1395   fprintf(stderr,
1396           "%s Info Ptr 0x%lx; Entry: 0x%lx; Update: 0x%lx\n",
1397           ip_type, info_ptr,
1398           (W_) ENTRY_CODE(info_ptr), (W_) UPDATE_CODE(info_ptr));
1399   fprintf(stderr,
1400           "Tag: %d; Type: %d; Size: %lu; Ptrs: %lu\n\n",
1401           INFO_TAG(info_ptr), INFO_TYPE(info_ptr),
1402           INFO_SIZE(info_ptr),INFO_NoPTRS(info_ptr));
1403 #if defined(PAR)
1404   fprintf(stderr,"Enter Flush Entry: 0x%lx;\tExit Flush Entry: 0x%lx\n",INFO_FLUSHENT(info_ptr),INFO_FLUSH(info_ptr));
1405 #endif /* PAR */
1406
1407 #if defined(USE_COST_CENTRES)
1408   fprintf(stderr,"Cost Centre:       0x%lx\n",INFO_CAT(info_ptr));
1409 #endif /* USE_COST_CENTRES */
1410
1411 #if defined(_INFO_COPYING)
1412   fprintf(stderr,"Evacuate Entry:    0x%lx;\tScavenge Entry: 0x%lx\n",
1413           INFO_EVAC_2S(info_ptr),INFO_SCAV_2S(info_ptr));
1414 #endif /* INFO_COPYING */
1415
1416 #if defined(_INFO_COMPACTING)
1417   fprintf(stderr,"Scan Link:         0x%lx;\tScan Move:      0x%lx\n",
1418           (W_) INFO_SCAN_LINK_1S(info_ptr), (W_) INFO_SCAN_MOVE_1S(info_ptr));
1419   fprintf(stderr,"Mark:              0x%lx;\tMarked:         0x%lx;\n",
1420           (W_) INFO_MARK_1S(info_ptr), (W_) INFO_MARKED_1S(info_ptr));
1421   if(BASE_INFO_TYPE(info_ptr)==INFO_SPEC_TYPE)
1422     fprintf(stderr,"plus specialised code\n");
1423   else
1424     fprintf(stderr,"Marking:           0x%lx\n",(W_) INFO_MARKING_1S(info_ptr));
1425 #endif /* INFO_COMPACTING */
1426 }
1427
1428 void
1429 DEBUG_REGS()
1430 {
1431 #ifdef PAR
1432   PP_ SpA  = STKO_SpA(SAVE_StkO);
1433   PP_ SuA  = STKO_SuA(SAVE_StkO);
1434   P_  SpB  = STKO_SpB(SAVE_StkO);
1435   P_  SuB  = STKO_SuB(SAVE_StkO);
1436 #else
1437   PP_ SpA  = SAVE_SpA;
1438   PP_ SuA  = SAVE_SuA;
1439   P_  SpB  = SAVE_SpB;
1440   P_  SuB  = SAVE_SuB;
1441 #endif
1442   P_  Hp   = SAVE_Hp;
1443   P_  HpLim= SAVE_HpLim;
1444   I_  TagReg= SAVE_Tag;
1445   StgRetAddr RetReg = SAVE_Ret;
1446   P_  Node = SAVE_R1.p;
1447   StgUnion  R1   = SAVE_R1;
1448   StgUnion  R2   = SAVE_R2;
1449   StgUnion  R3   = SAVE_R3;
1450   StgUnion  R4   = SAVE_R4;
1451   StgUnion  R5   = SAVE_R5;
1452   StgUnion  R6   = SAVE_R6;
1453   StgUnion  R7   = SAVE_R7;
1454   StgUnion  R8   = SAVE_R8;
1455   StgFloat FltReg1 = SAVE_Flt1;
1456   StgFloat FltReg2 = SAVE_Flt2;
1457   StgFloat FltReg3 = SAVE_Flt3;
1458   StgFloat FltReg4 = SAVE_Flt4;
1459   StgDouble DblReg1 = SAVE_Dbl1;
1460   StgDouble DblReg2 = SAVE_Dbl2;
1461
1462   fprintf(stderr,"STG-Machine Register Values:\n\n");
1463   fprintf(stderr,"Node:  %08lx;  Hp:    %08lx;  HpLim: %08lx;  Tag:   %8lu\n",Node,(W_)Hp,(W_)HpLim,TagReg);
1464   fprintf(stderr,"SpA:   %08lx;  SpB:   %08lx;  SuA:   %08lx;  SuB:   %08lx\n",(W_)SpA,(W_)SpB,(W_)SuA,(W_)SuB);
1465   fprintf(stderr,"RetReg: %08lx\n",RetReg);
1466
1467 #if 0
1468 /* These bits need to have the FLUSH_REG_MAP, whereas the surrounding bits
1469    use the MAIN_REG_MAP */
1470
1471   fprintf(stderr, "\n");
1472   fprintf(stderr,"LiveR: %08lx\n", LivenessReg);
1473   fprintf(stderr,"Flush: %08lx;  FStk:  %08lx;  FStkB: %08lx;  FTmp:  %08lx\n",(W_)FlushP,(W_)FStack,(W_)FStackBase,(W_)Temp);
1474 #endif /* 0 */
1475
1476   fprintf(stderr, "\n");
1477
1478   fprintf(stderr,"Gen:   %8lu, %8lu, %8lu, %8lu\n",R1.i,R2.i,R3.i,R4.i);
1479   fprintf(stderr,"       %8lu, %8lu, %8lu, %8lu\n",R5.i,R6.i,R7.i,R8.i);
1480   fprintf(stderr,"Float: %8g, %8g, %8g, %8g\n",FltReg1,FltReg2,FltReg3,FltReg4);
1481   fprintf(stderr,"Dble:  %8g, %8g\n",DblReg1,DblReg2);
1482 }
1483
1484 void
1485 DEBUG_MP()
1486 {
1487   StgPtr mp;
1488   StgInt i;
1489
1490   fprintf(stderr,"MallocPtrList\n\n");
1491
1492   for(mp = StorageMgrInfo.MallocPtrList;
1493       mp != NULL;
1494       mp = MallocPtr_CLOSURE_LINK(mp)) {
1495
1496     fprintf(stderr, "MallocPtr(0x%lx) = 0x%lx\n", mp, MallocPtr_CLOSURE_DATA(mp));
1497
1498 /*
1499     DEBUG_PRINT_NODE(mp);
1500 */
1501   }
1502
1503 #if defined(GCap) || defined(GCgn)
1504   fprintf(stderr,"\nOldMallocPtr List\n\n");
1505
1506   for(mp = StorageMgrInfo.OldMallocPtrList;
1507       mp != NULL;
1508       mp = MallocPtr_CLOSURE_LINK(mp)) {
1509
1510     fprintf(stderr, "  MallocPtr(0x%lx) = 0x%lx\n", mp, MallocPtr_CLOSURE_DATA(mp));
1511 /*
1512    DEBUG_PRINT_NODE(mp);
1513 */
1514   }
1515 #endif /* GCap || GCgn */
1516
1517   fprintf(stderr, "\n");
1518 }
1519
1520 #ifndef PAR
1521 void
1522 DEBUG_SPT(int weight)
1523 {
1524   StgPtr SPTable = StorageMgrInfo.StablePointerTable;
1525   StgInt size = SPT_SIZE(SPTable);
1526   StgInt ptrs = SPT_NoPTRS(SPTable);
1527   StgInt top = SPT_TOP(SPTable);
1528
1529   StgInt i;
1530
1531 /*
1532   DEBUG_PRINT_NODE(SPTable);
1533 */
1534
1535   fprintf(stderr,"SPTable@0x%lx:\n", SPTable);
1536   fprintf(stderr,"  InfoPtr = 0x%lx\n", INFO_PTR(SPTable));
1537   fprintf(stderr,"  size = %d, ptrs = %d, top = %d\n",
1538                     size,      ptrs,      top
1539          );
1540   for( i=0; i < ptrs; i++ ) {
1541     if (i % 10 == 0) {
1542       fprintf(stderr,"\n  ");
1543     }
1544     printClosure(SPT_SPTR(SPTable, i),1,weight);
1545     fprintf(stderr, "\n");
1546   }
1547   fprintf(stderr, "\n");
1548   for( i=0; i < top; i++) {
1549     if (i % 10 == 0) {
1550       fprintf(stderr,"\n  ");
1551     }
1552     fprintf(stderr, " %3d", SPT_FREE(SPTable, i));
1553   }
1554
1555   fprintf(stderr, "\n\n");
1556
1557 }
1558 #endif /* !PAR */
1559
1560
1561 /*
1562   These routines crawl over the A and B stacks, printing
1563   a maximum "lines" lines at the top of the stack.
1564 */
1565
1566
1567 #define STACK_VALUES_PER_LINE   5
1568
1569 #if !defined(PAR)
1570 /* (stack stuff is really different on parallel machines) */
1571
1572 void
1573 DEBUG_ASTACK(lines)
1574 I_ lines;
1575 {
1576   PP_ SpA  = SAVE_SpA;
1577   PP_ SuA  = SAVE_SuA;
1578   P_  SpB  = SAVE_SpB;
1579   P_  SuB  = SAVE_SuB;
1580
1581   PP_   stackptr;
1582   I_ count = 0;
1583
1584   fprintf(stderr,"Dump of the Address Stack, SpA: 0x%08lx, BOS: 0x%08lx\n",
1585                     (W_) SpA, (W_) stackInfo.botA);
1586
1587   for (stackptr = SpA;
1588        SUBTRACT_A_STK(stackptr, stackInfo.botA) >= 0;
1589        stackptr = stackptr + AREL(1))
1590     {
1591       if( count++ % STACK_VALUES_PER_LINE == 0)
1592         {
1593           if(count >= lines * STACK_VALUES_PER_LINE)
1594             break;
1595           fprintf(stderr,"\nSpA[%ld] (0x%08lx): ",count-1,stackptr);
1596         }
1597       fprintf(stderr,"0x%08lx ",(W_) *stackptr);
1598     }
1599   fprintf(stderr, "\n");
1600 }
1601
1602
1603 void
1604 DEBUG_BSTACK(lines)
1605 I_ lines;
1606 {
1607   PP_ SpA  = SAVE_SpA;
1608   PP_ SuA  = SAVE_SuA;
1609   P_  SpB  = SAVE_SpB;
1610   P_  SuB  = SAVE_SuB;
1611
1612   P_    stackptr;
1613   I_ count = 0;
1614
1615   fprintf(stderr,"Dump of the Value Stack, SpB: 0x%08lx, BOS: 0x%08lx\n",
1616                 (W_) SpB, (W_) stackInfo.botB);
1617
1618   for (stackptr = SpB;
1619          SUBTRACT_B_STK(stackptr, stackInfo.botB) > 0;
1620          stackptr = stackptr + BREL(1))
1621       {
1622         if( count++ % STACK_VALUES_PER_LINE == 0)
1623           {
1624             if(count >= lines * STACK_VALUES_PER_LINE)
1625               break;
1626             fprintf(stderr,"\nSpB[%ld] (0x%08lx): ",count-1,stackptr);
1627           }
1628         fprintf(stderr,"0x%08lx ",(W_) *stackptr);
1629       }
1630   fprintf(stderr, "\n");
1631 }
1632 #endif /* not parallel */
1633
1634 /*
1635   This should disentangle update frames from both stacks.
1636 */
1637
1638 #if ! defined(PAR)
1639 void
1640 DEBUG_UPDATES(limit)
1641 I_ limit;
1642 {
1643   PP_ SpA  = SAVE_SpA;
1644   PP_ SuA  = SAVE_SuA;
1645   P_  SpB  = SAVE_SpB;
1646   P_  SuB  = SAVE_SuB;
1647
1648   P_ updatee, retreg;
1649   PP_ sua;
1650   P_ sub;
1651   PP_ spa = SuA;
1652   P_ spb = SuB;
1653   I_ count = 0;
1654
1655   fprintf(stderr,"Update Frame Stack Dump:\n\n");
1656
1657   for(spb = SuB;
1658       SUBTRACT_B_STK(spb, stackInfo.botB) > 0 && count++ < limit;
1659       /* re-init given explicitly */)
1660     {
1661       updatee = GRAB_UPDATEE(spb);         /* Thing to be updated  */
1662       retreg  = (P_) GRAB_RET(spb);        /* Return vector below */
1663
1664       fprintf(stderr,"SuA: 0x%08lx, SuB: 0x%08lx, Updatee 0x%08lx, RetReg 0x%x\n",
1665                      (W_) spa, (W_) spb,
1666                      (W_) updatee, (W_) retreg);
1667
1668       spa = GRAB_SuA(spb);                 /* Next SuA, SuB */
1669       spb = GRAB_SuB(spb);
1670     }
1671 }
1672 #endif /* not parallel */
1673
1674 #endif /* RUNTIME_DEBUGGING */
1675
1676 #endif /* PAR || RUNTIME_DEBUGGING */
1677 \end{code}