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

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