[project @ 1999-07-14 13:44:19 by simonmar]

[ghc-hetmet.git] / ghc / rts / Printer.c

diff --git a/ghc/rts/Printer.c b/ghc/rts/Printer.c
index e22e6ed..8be29aa 100644 (file)
--- a/ghc/rts/Printer.c
+++ b/ghc/rts/Printer.c
@@ -1,14 +1,15 @@
-/* -*- mode: hugs-c; -*- */
+
 /* -----------------------------------------------------------------------------
- * $Id: Printer.c,v 1.3 1999/01/15 17:57:09 simonm Exp $
+ * $Id: Printer.c,v 1.15 1999/07/14 13:44:19 simonmar Exp $
  *
- * Copyright (c) 1994-1998.
+ * Copyright (c) 1994-1999.
  *
  * Heap printer
  * 
  * ---------------------------------------------------------------------------*/
 
 #include "Rts.h"
+#include "Printer.h"
 
 #ifdef DEBUG
 
@@ -17,8 +18,6 @@
 #include "Bytecodes.h"  /* for InstrPtr */
 #include "Disassembler.h"
 
-#include "Printer.h"
-
 /* --------------------------------------------------------------------------
  * local function decls
  * ------------------------------------------------------------------------*/
@@ -39,14 +38,32 @@ static void    printZcoded   ( const char *raw );
  * Printer
  * ------------------------------------------------------------------------*/
 
-extern void printPtr( StgPtr p )
+
+#ifdef INTERPRETER
+extern void* itblNames[];
+extern int   nItblNames;
+char* lookupHugsItblName ( void* v )
+{
+   int i;
+   for (i = 0; i < nItblNames; i += 2)
+      if (itblNames[i] == v) return itblNames[i+1];
+   return NULL;
+}
+#endif
+
+void printPtr( StgPtr p )
 {
+#ifdef INTERPRETER
+    char* str;
+#endif
     const char *raw;
     if (lookupGHCName( p, &raw )) {
         printZcoded(raw);
 #ifdef INTERPRETER
     } else if ((raw = lookupHugsName(p)) != 0) {
         fprintf(stderr, "%s", raw);
+    } else if ((str = lookupHugsItblName(p)) != 0) {
+        fprintf(stderr, "%p=%s", p, str);
 #endif
     } else {
         fprintf(stderr, "%p", p);
@@ -64,7 +81,7 @@ static void printStdObject( StgClosure *obj, char* tag )
     StgWord i, j;
     const StgInfoTable* info = get_itbl(obj);
     fprintf(stderr,"%s(",tag);
-    printPtr((StgPtr)info);
+    printPtr((StgPtr)obj->header.info);
     for (i = 0; i < info->layout.payload.ptrs; ++i) {
         fprintf(stderr,", ");
         printPtr(payloadPtr(obj,i));
@@ -86,6 +103,7 @@ void printClosure( StgClosure *obj )
             disassemble(stgCast(StgBCO*,obj),"\t");
             break;
 #endif
+
     case AP_UPD:
         {
            StgAP_UPD* ap = stgCast(StgAP_UPD*,obj);
@@ -98,11 +116,12 @@ void printClosure( StgClosure *obj )
             fprintf(stderr,")\n");
             break;
         }
+
     case PAP:
         {
            StgPAP* pap = stgCast(StgPAP*,obj);
             StgWord i;
-            fprintf(stderr,"AP_NUPD("); printPtr((StgPtr)pap->fun);
+            fprintf(stderr,"PAP("); printPtr((StgPtr)pap->fun);
             for (i = 0; i < pap->n_args; ++i) {
                 fprintf(stderr,", ");
                 printPtr(payloadPtr(pap,i));
@@ -110,11 +129,25 @@ void printClosure( StgClosure *obj )
             fprintf(stderr,")\n");
             break;
         }
+
     case IND:
             fprintf(stderr,"IND("); 
             printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
             fprintf(stderr,")\n"); 
             break;
+
+    case IND_STATIC:
+            fprintf(stderr,"IND_STATIC("); 
+            printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
+            fprintf(stderr,")\n"); 
+            break;
+
+    case IND_OLDGEN:
+            fprintf(stderr,"IND_OLDGEN("); 
+            printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
+            fprintf(stderr,")\n"); 
+            break;
+
     case CAF_UNENTERED:
         {
            StgCAF* caf = stgCast(StgCAF*,obj);
@@ -127,6 +160,7 @@ void printClosure( StgClosure *obj )
             fprintf(stderr,")\n"); 
             break;
         }
+
     case CAF_ENTERED:
         {
            StgCAF* caf = stgCast(StgCAF*,obj);
@@ -139,20 +173,34 @@ void printClosure( StgClosure *obj )
             fprintf(stderr,")\n"); 
             break;
         }
+
     case CAF_BLACKHOLE:
             fprintf(stderr,"CAF_BH("); 
-            printPtr((StgPtr)stgCast(StgBlackHole*,obj)->blocking_queue);
+            printPtr((StgPtr)stgCast(StgBlockingQueue*,obj)->blocking_queue);
             fprintf(stderr,")\n"); 
             break;
+
+    case SE_BLACKHOLE:
+            fprintf(stderr,"SE_BH\n"); 
+            break;
+
+    case SE_CAF_BLACKHOLE:
+            fprintf(stderr,"SE_CAF_BH\n"); 
+            break;
+
     case BLACKHOLE:
             fprintf(stderr,"BH\n"); 
             break;
+
     case BLACKHOLE_BQ:
             fprintf(stderr,"BQ("); 
-            printPtr((StgPtr)stgCast(StgBlackHole*,obj)->blocking_queue);
+            printPtr((StgPtr)stgCast(StgBlockingQueue*,obj)->blocking_queue);
             fprintf(stderr,")\n"); 
             break;
+
     case CONSTR:
+    case CONSTR_1_0: case CONSTR_0_1:
+    case CONSTR_1_1: case CONSTR_0_2: case CONSTR_2_0:
     case CONSTR_INTLIKE:
     case CONSTR_CHARLIKE:
     case CONSTR_STATIC:
@@ -164,7 +212,7 @@ void printClosure( StgClosure *obj )
             StgWord i, j;
             const StgInfoTable* info = get_itbl(obj);
             fprintf(stderr,"PACK(");
-            printPtr((StgPtr)info);
+            printPtr((StgPtr)obj->header.info);
             fprintf(stderr,"(tag=%d)",info->srt_len);
             for (i = 0; i < info->layout.payload.ptrs; ++i) {
                 fprintf(stderr,", ");
@@ -176,11 +224,17 @@ void printClosure( StgClosure *obj )
             fprintf(stderr,")\n");
             break;
         }
+
     case FUN:
+    case FUN_1_0: case FUN_0_1: 
+    case FUN_1_1: case FUN_0_2: case FUN_2_0:
     case FUN_STATIC:
             printStdObject(obj,"FUN");
             break;
+
     case THUNK:
+    case THUNK_1_0: case THUNK_0_1:
+    case THUNK_1_1: case THUNK_0_2: case THUNK_2_0:
     case THUNK_STATIC:
             /* ToDo: will this work for THUNK_STATIC too? */
             printStdObject(obj,"THUNK");
@@ -210,6 +264,7 @@ void printClosure( StgClosure *obj )
             fprintf(stderr,")\n"); 
             break;
         }
+
     case CATCH_FRAME:
         {
             StgCatchFrame* u = stgCast(StgCatchFrame*,obj);
@@ -222,6 +277,7 @@ void printClosure( StgClosure *obj )
             fprintf(stderr,")\n"); 
             break;
         }
+
     case SEQ_FRAME:
         {
             StgSeqFrame* u = stgCast(StgSeqFrame*,obj);
@@ -232,6 +288,7 @@ void printClosure( StgClosure *obj )
             fprintf(stderr,")\n"); 
             break;
         }
+
     case STOP_FRAME:
         {
             StgStopFrame* u = stgCast(StgStopFrame*,obj);
@@ -241,7 +298,8 @@ void printClosure( StgClosure *obj )
             break;
         }
     default:
-            barf("printClosure %d",get_itbl(obj)->type);
+            //barf("printClosure %d",get_itbl(obj)->type);
+            fprintf(stderr, "*** printClosure: unknown type %d ****\n",get_itbl(obj)->type );
             return;
     }
 }
@@ -299,8 +357,26 @@ StgPtr printStackObj( StgPtr sp )
 #endif
 
     } else {
+        StgClosure* c = (StgClosure*)(*sp);
         printPtr((StgPtr)*sp);
-        fprintf(stderr,"\n");
+#ifdef INTERPRETER
+        if (c == &ret_bco_info) {
+           fprintf(stderr, "\t\t");
+           fprintf(stderr, "ret_bco_info\n" );
+       } else
+        if (IS_HUGS_CONSTR_INFO(GET_INFO(c))) {
+           fprintf(stderr, "\t\t\t");
+           fprintf(stderr, "ConstrInfoTable\n" );
+        } else
+#endif
+        if (get_itbl(c)->type == BCO) {
+           fprintf(stderr, "\t\t\t");
+           fprintf(stderr, "BCO(...)\n"); 
+        }
+        else {
+           fprintf(stderr, "\t\t\t");
+           printClosure ( (StgClosure*)(*sp));
+        }
         sp += 1;
     }
     return sp;
@@ -309,7 +385,7 @@ StgPtr printStackObj( StgPtr sp )
 
 void printStackChunk( StgPtr sp, StgPtr spBottom )
 {
-    StgNat32 bitmap;
+    StgWord32 bitmap;
     const StgInfoTable *info;
 
     ASSERT(sp <= spBottom);
@@ -637,7 +713,10 @@ static void printZcoded( const char *raw )
  * Symbol table loading
  * ------------------------------------------------------------------------*/
 
-#ifdef HAVE_BFD_H
+/* Causing linking trouble on Win32 plats, so I'm
+   disabling this for now. 
+*/
+#if defined(HAVE_BFD_H) && !defined(_WIN32)
 
 #include <bfd.h>
 
@@ -656,6 +735,7 @@ static rtsBool isReal( flagword flags, const char *name )
         return rtsFalse;
     }
 #else
+    (void)flags;   /* keep gcc -Wall happy */
     if (*name == '\0'  || 
        (name[0] == 'g' && name[1] == 'c' && name[2] == 'c') ||
        (name[0] == 'c' && name[1] == 'c' && name[2] == '.')) {
@@ -742,4 +822,36 @@ extern void DEBUG_LoadSymbols( char *name )
 
 #endif /* HAVE_BFD_H */
 
+#include "StoragePriv.h"
+
+void
+findPtr(P_ p)
+{
+  nat s, g;
+  P_ q;
+  bdescr *bd;
+
+  for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
+    for (s = 0; s < generations[g].n_steps; s++) {
+      for (bd = generations[g].steps[s].blocks; bd; bd = bd->link) {
+       for (q = bd->start; q < bd->free; q++) {
+         if (*q == (W_)p) {
+           printf("%p\n", q);
+         }
+       }
+      }
+    }
+  }
+}
+
+#else /* DEBUG */
+void printPtr( StgPtr p )
+{
+    fprintf(stderr, "ptr 0x%p (enable -DDEBUG for more info) " , p );
+}
+  
+void printObj( StgClosure *obj )
+{
+    fprintf(stderr, "obj 0x%p (enable -DDEBUG for more info) " , obj );
+}
 #endif /* DEBUG */