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

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