[project @ 1998-12-02 13:17:09 by simonm]
[ghc-hetmet.git] / ghc / rts / Printer.c
1 /* -*- mode: hugs-c; -*- */
2 /* -----------------------------------------------------------------------------
3  * $Id: Printer.c,v 1.2 1998/12/02 13:28:33 simonm Exp $
4  *
5  * Copyright (c) 1994-1998.
6  *
7  * Heap printer
8  * 
9  * ---------------------------------------------------------------------------*/
10
11 #include "Rts.h"
12
13 #ifdef DEBUG
14
15 #include "RtsUtils.h"
16 #include "RtsFlags.h"
17 #include "Bytecodes.h"  /* for InstrPtr */
18 #include "Disassembler.h"
19
20 #include "Printer.h"
21
22 /* --------------------------------------------------------------------------
23  * local function decls
24  * ------------------------------------------------------------------------*/
25
26 static void    printStdObject( StgClosure *obj, char* tag );
27 static void    reset_table   ( int size );
28 static void    prepare_table ( void );
29 static void    insert        ( unsigned value, const char *name );
30 #if 0 /* unused but might be useful sometime */
31 static rtsBool lookup_name   ( char *name, unsigned *result );
32 static void    enZcode       ( char *in, char *out );
33 #endif
34 static char    unZcode       ( char ch );
35 rtsBool lookupGHCName ( StgPtr addr, const char **result );
36 static void    printZcoded   ( const char *raw );
37
38 /* --------------------------------------------------------------------------
39  * Printer
40  * ------------------------------------------------------------------------*/
41
42 extern void printPtr( StgPtr p )
43 {
44     const char *raw;
45     if (lookupGHCName( p, &raw )) {
46         printZcoded(raw);
47 #ifdef INTERPRETER
48     } else if ((raw = lookupHugsName(p)) != 0) {
49         fprintf(stderr, "%s", raw);
50 #endif
51     } else {
52         fprintf(stderr, "%p", p);
53     }
54 }
55   
56 void printObj( StgClosure *obj )
57 {
58     fprintf(stderr,"Object "); printPtr((StgPtr)obj); fprintf(stderr," = ");
59     printClosure(obj);
60 }
61
62 static void printStdObject( StgClosure *obj, char* tag )
63 {
64     StgWord i, j;
65     const StgInfoTable* info = get_itbl(obj);
66     fprintf(stderr,"%s(",tag);
67     printPtr((StgPtr)info);
68     for (i = 0; i < info->layout.payload.ptrs; ++i) {
69         fprintf(stderr,", ");
70         printPtr(payloadPtr(obj,i));
71     }
72     for (j = 0; j < info->layout.payload.nptrs; ++j) {
73         fprintf(stderr,", %xd#",payloadWord(obj,i+j));
74     }
75     fprintf(stderr,")\n");
76 }
77
78 void printClosure( StgClosure *obj )
79 {
80     switch ( get_itbl(obj)->type ) {
81     case INVALID_OBJECT:
82             barf("Invalid object");
83 #ifdef INTERPRETER
84     case BCO:
85             fprintf(stderr,"BCO\n");
86             disassemble(stgCast(StgBCO*,obj),"\t");
87             break;
88 #endif
89     case AP_UPD:
90         {
91             StgAP_UPD* ap = stgCast(StgAP_UPD*,obj);
92             StgWord i;
93             fprintf(stderr,"AP_UPD("); printPtr((StgPtr)ap->fun);
94             for (i = 0; i < ap->n_args; ++i) {
95                 fprintf(stderr,", ");
96                 printPtr(payloadPtr(ap,i));
97             }
98             fprintf(stderr,")\n");
99             break;
100         }
101     case PAP:
102         {
103             StgPAP* pap = stgCast(StgPAP*,obj);
104             StgWord i;
105             fprintf(stderr,"AP_NUPD("); printPtr((StgPtr)pap->fun);
106             for (i = 0; i < pap->n_args; ++i) {
107                 fprintf(stderr,", ");
108                 printPtr(payloadPtr(pap,i));
109             }
110             fprintf(stderr,")\n");
111             break;
112         }
113     case IND:
114             fprintf(stderr,"IND("); 
115             printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
116             fprintf(stderr,")\n"); 
117             break;
118     case CAF_UNENTERED:
119         {
120             StgCAF* caf = stgCast(StgCAF*,obj);
121             fprintf(stderr,"CAF_UNENTERED("); 
122             printPtr((StgPtr)caf->body);
123             fprintf(stderr,", ");
124             printPtr((StgPtr)caf->value); /* should be null */
125             fprintf(stderr,", ");
126             printPtr((StgPtr)caf->link);  /* should be null */
127             fprintf(stderr,")\n"); 
128             break;
129         }
130     case CAF_ENTERED:
131         {
132             StgCAF* caf = stgCast(StgCAF*,obj);
133             fprintf(stderr,"CAF_ENTERED("); 
134             printPtr((StgPtr)caf->body);
135             fprintf(stderr,", ");
136             printPtr((StgPtr)caf->value);
137             fprintf(stderr,", ");
138             printPtr((StgPtr)caf->link);
139             fprintf(stderr,")\n"); 
140             break;
141         }
142     case CAF_BLACKHOLE:
143             fprintf(stderr,"CAF_BH("); 
144             printPtr((StgPtr)stgCast(StgBlackHole*,obj)->blocking_queue);
145             fprintf(stderr,")\n"); 
146             break;
147     case BLACKHOLE:
148             fprintf(stderr,"BH("); 
149             printPtr((StgPtr)stgCast(StgBlackHole*,obj)->blocking_queue);
150             fprintf(stderr,")\n"); 
151             break;
152     case CONSTR:
153     case CONSTR_INTLIKE:
154     case CONSTR_CHARLIKE:
155     case CONSTR_STATIC:
156     case CONSTR_NOCAF_STATIC:
157         {
158             /* We can't use printStdObject because we want to print the
159              * tag as well.
160              */
161             StgWord i, j;
162             const StgInfoTable* info = get_itbl(obj);
163             fprintf(stderr,"PACK(");
164             printPtr((StgPtr)info);
165             fprintf(stderr,"(tag=%d)",info->srt_len);
166             for (i = 0; i < info->layout.payload.ptrs; ++i) {
167                 fprintf(stderr,", ");
168                 printPtr(payloadPtr(obj,i));
169             }
170             for (j = 0; j < info->layout.payload.nptrs; ++j) {
171                 fprintf(stderr,", %x#",payloadWord(obj,i+j));
172             }
173             fprintf(stderr,")\n");
174             break;
175         }
176     case FUN:
177     case FUN_STATIC:
178             printStdObject(obj,"FUN");
179             break;
180     case THUNK:
181     case THUNK_STATIC:
182             /* ToDo: will this work for THUNK_STATIC too? */
183             printStdObject(obj,"THUNK");
184             break;
185 #if 0
186     case ARR_WORDS:
187         {
188             StgWord i;
189             fprintf(stderr,"ARR_WORDS(\"");
190             /* ToDo: we can't safely assume that this is a string! */
191             for (i = 0; arrWordsGetChar(obj,i); ++i) {
192                 putchar(arrWordsGetChar(obj,i));
193             }
194             fprintf(stderr,"\")\n");
195             break;
196         }
197 #endif
198     case UPDATE_FRAME:
199         {
200             StgUpdateFrame* u = stgCast(StgUpdateFrame*,obj);
201             fprintf(stderr,"UpdateFrame(");
202             printPtr((StgPtr)GET_INFO(u));
203             fprintf(stderr,",");
204             printPtr((StgPtr)u->updatee);
205             fprintf(stderr,",");
206             printPtr((StgPtr)u->link);
207             fprintf(stderr,")\n"); 
208             break;
209         }
210     case CATCH_FRAME:
211         {
212             StgCatchFrame* u = stgCast(StgCatchFrame*,obj);
213             fprintf(stderr,"CatchFrame(");
214             printPtr((StgPtr)GET_INFO(u));
215             fprintf(stderr,",");
216             printPtr((StgPtr)u->handler);
217             fprintf(stderr,",");
218             printPtr((StgPtr)u->link);
219             fprintf(stderr,")\n"); 
220             break;
221         }
222     case SEQ_FRAME:
223         {
224             StgSeqFrame* u = stgCast(StgSeqFrame*,obj);
225             fprintf(stderr,"SeqFrame(");
226             printPtr((StgPtr)GET_INFO(u));
227             fprintf(stderr,",");
228             printPtr((StgPtr)u->link);
229             fprintf(stderr,")\n"); 
230             break;
231         }
232     case STOP_FRAME:
233         {
234             StgStopFrame* u = stgCast(StgStopFrame*,obj);
235             fprintf(stderr,"StopFrame(");
236             printPtr((StgPtr)GET_INFO(u));
237             fprintf(stderr,")\n"); 
238             break;
239         }
240     default:
241             barf("printClosure %d",get_itbl(obj)->type);
242             return;
243     }
244 }
245
246 StgPtr printStackObj( StgPtr sp )
247 {
248     /*fprintf(stderr,"Stack[%d] = ", &stgStack[STACK_SIZE] - sp); */
249
250     if (IS_ARG_TAG(*sp)) {
251
252 #ifdef DEBUG_EXTRA
253         StackTag tag = (StackTag)*sp;
254         switch ( tag ) {
255         case ILLEGAL_TAG:
256                 barf("printStackObj: ILLEGAL_TAG");
257                 break;
258         case REALWORLD_TAG:
259                 fprintf(stderr,"RealWorld#\n");
260                 break;
261         case INT_TAG:
262                 fprintf(stderr,"Int# %d\n", *(StgInt*)(sp+1));
263                 break;
264         case INT64_TAG:
265                 fprintf(stderr,"Int64# %lld\n", *(StgInt64*)(sp+1));
266                 break;
267         case WORD_TAG:
268                 fprintf(stderr,"Word# %d\n", *(StgWord*)(sp+1));
269                 break;
270         case ADDR_TAG:
271                 fprintf(stderr,"Addr# "); printPtr(*(StgAddr*)(sp+1)); fprintf(stderr,"\n");
272                 break;
273         case CHAR_TAG:
274                 fprintf(stderr,"Char# %d\n", *(StgChar*)(sp+1));
275                 break;
276         case FLOAT_TAG:
277                 fprintf(stderr,"Float# %f\n", PK_FLT(sp+1));
278                 break;
279         case DOUBLE_TAG:
280                 fprintf(stderr,"Double# %f\n", PK_DBL(sp+1));
281                 break;
282         default:
283                 barf("printStackObj: unrecognised ARGTAG %d",tag);
284         }
285         sp += 1 + ARG_SIZE(tag);
286
287 #else /* !DEBUG_EXTRA */
288         {
289             StgWord tag = *sp++;
290             nat i;
291             fprintf(stderr,"Tag: %d words\n", tag);
292             for (i = 0; i < tag; i++) {
293                 fprintf(stderr,"Word# %d\n", *sp++);
294             }
295         }
296 #endif
297
298     } else {
299         printPtr((StgPtr)*sp);
300         fprintf(stderr,"\n");
301         sp += 1;
302     }
303     return sp;
304     
305 }
306
307 void printStackChunk( StgPtr sp, StgPtr spBottom )
308 {
309     StgNat32 bitmap;
310     const StgInfoTable *info;
311
312     ASSERT(sp <= spBottom);
313     while (sp < spBottom) {
314       if (!IS_ARG_TAG(*sp) && LOOKS_LIKE_GHC_INFO(*sp)) {
315         info = get_itbl((StgClosure *)sp);
316         switch (info->type) {
317
318         case UPDATE_FRAME:
319             printObj( stgCast(StgClosure*,sp) );
320             sp += sizeofW(StgUpdateFrame);
321             continue;
322
323         case SEQ_FRAME:
324             printObj( stgCast(StgClosure*,sp) );
325             sp += sizeofW(StgSeqFrame);
326             continue;
327
328         case CATCH_FRAME:
329             printObj( stgCast(StgClosure*,sp) );
330             sp += sizeofW(StgCatchFrame);
331             continue;
332
333         case STOP_FRAME:
334             /* not quite: ASSERT(stgCast(StgPtr,su) == spBottom); */
335             printObj( stgCast(StgClosure*,sp) );
336             continue;
337
338         case RET_DYN:
339           fprintf(stderr, "RET_DYN (%p)\n", sp);
340           bitmap = *++sp;
341           ++sp;
342           fprintf(stderr, "Bitmap: 0x%x\n", bitmap);
343           goto small_bitmap;
344
345         case RET_SMALL:
346         case RET_VEC_SMALL:
347           fprintf(stderr, "RET_SMALL (%p)\n", sp);
348           bitmap = info->layout.bitmap;
349           sp++;
350         small_bitmap:
351           while (bitmap != 0) {
352             fprintf(stderr,"Stack[%d] (%p) = ", spBottom-sp, sp);
353             if ((bitmap & 1) == 0) {
354               printPtr((P_)*sp);
355               fprintf(stderr,"\n");
356             } else {
357               fprintf(stderr,"Word# %d\n", *sp++);
358             }         
359             sp++;
360             bitmap = bitmap >> 1;
361             }
362           continue;
363
364         case RET_BIG:
365         case RET_VEC_BIG:
366           barf("todo");
367
368         default:
369           break;
370         }
371       }
372       fprintf(stderr,"Stack[%d] (%p) = ", spBottom-sp, sp);
373       sp = printStackObj(sp);
374     }
375 }
376
377 void printStack( StgPtr sp, StgPtr spBottom, StgUpdateFrame* su )
378 {
379     /* check everything down to the first update frame */
380     printStackChunk( sp, stgCast(StgPtr,su) );
381     while ( stgCast(StgPtr,su) < spBottom) {
382         sp = stgCast(StgPtr,su);
383         switch (get_itbl(su)->type) {
384         case UPDATE_FRAME:
385                 printObj( stgCast(StgClosure*,su) );
386                 sp += sizeofW(StgUpdateFrame);
387                 su = su->link;
388                 break;
389         case SEQ_FRAME:
390                 printObj( stgCast(StgClosure*,su) );
391                 sp += sizeofW(StgSeqFrame);
392                 su = stgCast(StgSeqFrame*,su)->link;
393                 break;
394         case CATCH_FRAME:
395                 printObj( stgCast(StgClosure*,su) );
396                 sp += sizeofW(StgCatchFrame);
397                 su = stgCast(StgCatchFrame*,su)->link;
398                 break;
399         case STOP_FRAME:
400                 /* not quite: ASSERT(stgCast(StgPtr,su) == spBottom); */
401                 printObj( stgCast(StgClosure*,su) );
402                 return;
403         default:
404                 barf("printStack: weird record found on update frame list.");
405         }
406         printStackChunk( sp, stgCast(StgPtr,su) );
407     }
408     ASSERT(stgCast(StgPtr,su) == spBottom);
409 }
410
411 void printTSO( StgTSO *tso )
412 {
413     printStack( tso->sp, tso->stack+tso->stack_size,tso->su);
414     /* printStackChunk( tso->sp, tso->stack+tso->stack_size); */
415 }
416
417
418 /* --------------------------------------------------------------------------
419  * Address printing code
420  *
421  * Uses symbol table in (unstripped executable)
422  * ------------------------------------------------------------------------*/
423
424 /* --------------------------------------------------------------------------
425  * Simple lookup table
426  *
427  * Current implementation is pretty dumb!
428  * ------------------------------------------------------------------------*/
429
430 struct entry {
431     nat value;
432     const char *name;
433 };
434
435 static nat max_table_size;
436 static nat table_size;
437 static struct entry* table;
438
439 static void reset_table( int size )
440 {
441     max_table_size = size;
442     table_size = 0;
443     table = (struct entry *) malloc(size * sizeof(struct entry));
444 }
445
446 static void prepare_table( void )
447 {
448     /* Could sort it...  */
449 }
450
451 static void insert( unsigned value, const char *name )
452 {
453     if ( table_size >= max_table_size ) {
454         barf( "Symbol table overflow\n" );
455     }
456     table[table_size].value = value;
457     table[table_size].name = name;
458     table_size = table_size + 1;
459 }
460
461
462 #if 0
463 static rtsBool lookup_name( char *name, unsigned *result )
464 {
465     int i;
466     for( i = 0; i < table_size && strcmp(name,table[i].name) != 0; ++i ) {
467     }
468     if (i < table_size) {
469         *result = table[i].value;
470         return rtsTrue;
471     } else {
472         return rtsFalse;
473     }
474 }
475 #endif
476
477 /* Code from somewhere inside GHC (circa 1994)
478  * * Z-escapes:
479  *     "std"++xs -> "Zstd"++xs
480  *     char_to_c 'Z'  = "ZZ"
481  *     char_to_c '&'  = "Za"
482  *     char_to_c '|'  = "Zb"
483  *     char_to_c ':'  = "Zc"
484  *     char_to_c '/'  = "Zd"
485  *     char_to_c '='  = "Ze"
486  *     char_to_c '>'  = "Zg"
487  *     char_to_c '#'  = "Zh"
488  *     char_to_c '<'  = "Zl"
489  *     char_to_c '-'  = "Zm"
490  *     char_to_c '!'  = "Zn"
491  *     char_to_c '.'  = "Zo"
492  *     char_to_c '+'  = "Zp"
493  *     char_to_c '\'' = "Zq"
494  *     char_to_c '*'  = "Zt"
495  *     char_to_c '_'  = "Zu"
496  *     char_to_c c    = "Z" ++ show (ord c)
497  */
498 static char unZcode( char ch )
499 {
500     switch (ch) {
501     case 'a'  : return ('&');
502     case 'b'  : return ('|');
503     case 'c'  : return (':');
504     case 'd'  : return ('/');
505     case 'e'  : return ('=');
506     case 'g'  : return ('>');
507     case 'h'  : return ('#');
508     case 'l'  : return ('<');
509     case 'm'  : return ('-');
510     case 'n'  : return ('!');
511     case 'o'  : return ('.');
512     case 'p'  : return ('+');
513     case 'q'  : return ('\'');
514     case 't'  : return ('*');
515     case 'u'  : return ('_');
516     case 'Z'  :
517     case '\0' : return ('Z');
518     default   : return (ch);
519     }
520 }
521
522 #if 0
523 /* Precondition: out big enough to handle output (about twice length of in) */
524 static void enZcode( char *in, char *out )
525 {
526     int i, j;
527
528     j = 0;
529     out[ j++ ] = '_';
530     for( i = 0; in[i] != '\0'; ++i ) {
531         switch (in[i]) {
532         case 'Z'  : 
533                 out[j++] = 'Z';
534                 out[j++] = 'Z';
535                 break;
536         case '&'  : 
537                 out[j++] = 'Z';
538                 out[j++] = 'a';
539                 break;
540         case '|'  : 
541                 out[j++] = 'Z';
542                 out[j++] = 'b';
543                 break;
544         case ':'  : 
545                 out[j++] = 'Z';
546                 out[j++] = 'c';
547                 break;
548         case '/'  : 
549                 out[j++] = 'Z';
550                 out[j++] = 'd';
551                 break;
552         case '='  : 
553                 out[j++] = 'Z';
554                 out[j++] = 'e';
555                 break;
556         case '>'  : 
557                 out[j++] = 'Z';
558                 out[j++] = 'g';
559                 break;
560         case '#'  : 
561                 out[j++] = 'Z';
562                 out[j++] = 'h';
563                 break;
564         case '<'  : 
565                 out[j++] = 'Z';
566                 out[j++] = 'l';
567                 break;
568         case '-'  : 
569                 out[j++] = 'Z';
570                 out[j++] = 'm';
571                 break;
572         case '!'  : 
573                 out[j++] = 'Z';
574                 out[j++] = 'n';
575                 break;
576         case '.'  : 
577                 out[j++] = 'Z';
578                 out[j++] = 'o';
579                 break;
580         case '+'  : 
581                 out[j++] = 'Z';
582                 out[j++] = 'p';
583                 break;
584         case '\'' : 
585                 out[j++] = 'Z';
586                 out[j++] = 'q';
587                 break;
588         case '*'  : 
589                 out[j++] = 'Z';
590                 out[j++] = 't';
591                 break;
592         case '_'  : 
593                 out[j++] = 'Z';
594                 out[j++] = 'u';
595                 break;
596         default :
597                 out[j++] = in[i];
598                 break;
599         }
600     }
601     out[j] = '\0';
602 }
603 #endif
604
605 rtsBool lookupGHCName( StgPtr addr, const char **result )
606 {
607     nat i;
608     for( i = 0; i < table_size && table[i].value != (unsigned) addr; ++i ) {
609     }
610     if (i < table_size) {
611         *result = table[i].name;
612         return rtsTrue;
613     } else {
614         return rtsFalse;
615     }
616 }
617
618 static void printZcoded( const char *raw )
619 {
620     nat j = 0;
621     
622     while ( raw[j] != '\0' ) {
623         if (raw[j] == 'Z') {
624             fputc(unZcode(raw[j+1]),stderr);
625             j = j + 2;
626         } else {
627             fputc(raw[j],stderr);
628             j = j + 1;
629         }
630     }
631 }
632
633 /* --------------------------------------------------------------------------
634  * Symbol table loading
635  * ------------------------------------------------------------------------*/
636
637 #ifdef HAVE_BFD_H
638
639 #include <bfd.h>
640
641 /* Fairly ad-hoc piece of code that seems to filter out a lot of
642  * rubbish like the obj-splitting symbols
643  */
644
645 static rtsBool isReal( flagword flags, const char *name )
646 {
647 #if 0
648     /* ToDo: make this work on BFD */
649     int tp = type & N_TYPE;    
650     if (tp == N_TEXT || tp == N_DATA) {
651         return (name[0] == '_' && name[1] != '_');
652     } else {
653         return rtsFalse;
654     }
655 #else
656     if (*name == '\0'  || 
657         (name[0] == 'g' && name[1] == 'c' && name[2] == 'c') ||
658         (name[0] == 'c' && name[1] == 'c' && name[2] == '.')) {
659         return rtsFalse;
660     }
661     return rtsTrue;
662 #endif
663 }
664
665 extern void DEBUG_LoadSymbols( char *name )
666 {
667     bfd* abfd;
668     char **matching;
669
670     bfd_init();
671     abfd = bfd_openr(name, "default");
672     if (abfd == NULL) {
673         barf("can't open executable %s to get symbol table", name);
674     }
675     if (!bfd_check_format_matches (abfd, bfd_object, &matching)) {
676         barf("mismatch");
677     }
678
679     {
680         long storage_needed;
681         asymbol **symbol_table;
682         long number_of_symbols;
683         long num_real_syms = 0;
684         long i;
685      
686         storage_needed = bfd_get_symtab_upper_bound (abfd);
687      
688         if (storage_needed < 0) {
689             barf("can't read symbol table");
690         }     
691 #if 0
692         if (storage_needed == 0) {
693             belch("no storage needed");
694         }
695 #endif
696         symbol_table = (asymbol **) stgMallocBytes(storage_needed,"DEBUG_LoadSymbols");
697
698         number_of_symbols = bfd_canonicalize_symtab (abfd, symbol_table);
699      
700         if (number_of_symbols < 0) {
701             barf("can't canonicalise symbol table");
702         }
703
704         for( i = 0; i != number_of_symbols; ++i ) {
705             symbol_info info;
706             bfd_get_symbol_info(abfd,symbol_table[i],&info);
707             /*fprintf(stderr,"\t%c\t0x%x      \t%s\n",info.type,(nat)info.value,info.name); */
708             if (isReal(info.type, info.name)) {
709                 num_real_syms += 1;
710             }
711         }
712     
713         IF_DEBUG(evaluator,
714                  fprintf(stderr,"Loaded %ld symbols. Of which %ld are real symbols\n", 
715                          number_of_symbols, num_real_syms)
716                  );
717
718         reset_table( num_real_syms );
719     
720         for( i = 0; i != number_of_symbols; ++i ) {
721             symbol_info info;
722             bfd_get_symbol_info(abfd,symbol_table[i],&info);
723             if (isReal(info.type, info.name)) {
724                 insert( info.value, info.name );
725             }
726         }
727         
728         free(symbol_table);
729     }
730     prepare_table();
731 }
732
733 #else /* HAVE_BFD_H */
734
735 extern void DEBUG_LoadSymbols( char *name )
736 {
737   /* nothing, yet */
738 }
739
740 #endif /* HAVE_BFD_H */
741
742 #endif /* DEBUG */