Ensure runhaskell is rebuild in stage2

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

diff --git a/rts/Printer.c b/rts/Printer.c
index 6da32fc..3e80bd1 100644 (file)
--- a/rts/Printer.c
+++ b/rts/Printer.c
@@ -136,8 +136,9 @@ printClosure( StgClosure *obj )
     case CONSTR_NOCAF_STATIC:
         {
             StgWord i, j;
+
 #ifdef PROFILING
-           debugBelch("%s(", info->prof.closure_desc);
+           debugBelch("%s(", GET_PROF_DESC(info));
            debugBelch("%s", obj->header.prof.ccs->cc->label);
 #else
             debugBelch("CONSTR(");
@@ -173,7 +174,7 @@ printClosure( StgClosure *obj )
     case THUNK_STATIC:
             /* ToDo: will this work for THUNK_STATIC too? */
 #ifdef PROFILING
-           printThunkObject((StgThunk *)obj,info->prof.closure_desc);
+            printThunkObject((StgThunk *)obj,GET_PROF_DESC(info));
 #else
             printThunkObject((StgThunk *)obj,"THUNK");
 #endif
@@ -339,7 +340,8 @@ printClosure( StgClosure *obj )
        debugBelch("MUT_ARR_PTRS_FROZEN(size=%lu)\n", (lnat)((StgMutArrPtrs *)obj)->ptrs);
        break;
 
-    case MVAR:
+    case MVAR_CLEAN:
+    case MVAR_DIRTY:
         {
          StgMVar* mv = (StgMVar*)obj;
          debugBelch("MVAR(head=%p, tail=%p, value=%p)\n", mv->head, mv->tail, mv->value);
@@ -1063,11 +1065,37 @@ extern void DEBUG_LoadSymbols( char *name STG_UNUSED )
 
 void findPtr(P_ p, int);               /* keep gcc -Wall happy */
 
+int searched = 0;
+
+static int
+findPtrBlocks (StgPtr p, bdescr *bd, StgPtr arr[], int arr_size, int i)
+{
+    StgPtr q, r;
+    for (; bd; bd = bd->link) {
+        searched++;
+        for (q = bd->start; q < bd->free; q++) {
+            if (UNTAG_CLOSURE((StgClosure*)*q) == (StgClosure *)p) {
+                if (i < arr_size) {
+                    r = q;
+                    while (HEAP_ALLOCED((StgPtr)*r) || !LOOKS_LIKE_INFO_PTR(*r) || (P_)*r == NULL) {
+                        r--;
+                    }
+                    debugBelch("%p = ", r);
+                    printClosure((StgClosure *)r);
+                    arr[i++] = r;
+                } else {
+                    return i;
+                }
+            }
+        }
+    }
+    return i;
+}
+
 void
 findPtr(P_ p, int follow)
 {
   nat s, g;
-  P_ q, r;
   bdescr *bd;
 #if defined(__GNUC__)
   const int arr_size = 1024;
@@ -1076,27 +1104,15 @@ findPtr(P_ p, int follow)
 #endif
   StgPtr arr[arr_size];
   int i = 0;
+  searched = 0;
 
   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
       for (s = 0; s < generations[g].n_steps; s++) {
          bd = generations[g].steps[s].blocks;
-         for (; bd; bd = bd->link) {
-             for (q = bd->start; q < bd->free; q++) {
-                 if (*q == (W_)p) {
-                     if (i < arr_size) {
-                         r = q;
-                         while (!LOOKS_LIKE_INFO_PTR(*r) || (P_)*r == NULL) {
-                             r--;
-                         }
-                         debugBelch("%p = ", r);
-                         printClosure((StgClosure *)r);
-                         arr[i++] = r;
-                     } else {
-                         return;
-                     }
-                 }
-             }
-         }
+          i = findPtrBlocks(p,bd,arr,arr_size,i);
+         bd = generations[g].steps[s].large_objects;
+          i = findPtrBlocks(p,bd,arr,arr_size,i);
+          if (i >= arr_size) return;
       }
   }
   if (follow && i == 1) {
@@ -1105,6 +1121,88 @@ findPtr(P_ p, int follow)
   }
 }
 
+/* prettyPrintClosure() is for printing out a closure using the data constructor
+   names found in the info tables. Closures are printed in a fashion that resembles
+   their Haskell representation. Useful during debugging.
+
+   Todo: support for more closure types, and support for non pointer fields in the
+   payload.
+*/ 
+
+void prettyPrintClosure_ (StgClosure *);
+
+void prettyPrintClosure (StgClosure *obj)
+{
+   prettyPrintClosure_ (obj);
+   debugBelch ("\n");
+}
+
+void prettyPrintClosure_ (StgClosure *obj)
+{
+    StgInfoTable *info;
+    StgConInfoTable *con_info;
+
+    /* collapse any indirections */
+    unsigned int type;
+    type = get_itbl(obj)->type;
+           
+    while (type == IND ||
+           type == IND_STATIC ||
+           type == IND_OLDGEN ||
+           type == IND_PERM ||
+           type == IND_OLDGEN_PERM) 
+    {
+      obj = ((StgInd *)obj)->indirectee;
+      type = get_itbl(obj)->type;
+    }
+
+    /* find the info table for this object */
+    info = get_itbl(obj);
+
+    /* determine what kind of object we have */
+    switch (info->type) 
+    {
+        /* full applications of data constructors */
+        case CONSTR:
+        case CONSTR_1_0: 
+        case CONSTR_0_1:
+        case CONSTR_1_1: 
+        case CONSTR_0_2: 
+        case CONSTR_2_0:
+        case CONSTR_STATIC:
+        case CONSTR_NOCAF_STATIC: 
+        {
+           nat i; 
+           char *descriptor;
+
+           /* find the con_info for the constructor */
+           con_info = get_con_itbl (obj);
+
+           /* obtain the name of the constructor */
+           descriptor = GET_CON_DESC(con_info);
+
+           debugBelch ("(%s", descriptor);
+
+           /* process the payload of the closure */
+           /* we don't handle non pointers at the moment */
+           for (i = 0; i < info->layout.payload.ptrs; i++)
+           {
+              debugBelch (" ");
+              prettyPrintClosure_ ((StgClosure *) obj->payload[i]);
+           }
+           debugBelch (")");
+           break;
+        }
+
+        /* if it isn't a constructor then just print the closure type */
+        default:
+        {
+           debugBelch ("<%s>", info_type(obj));
+           break;
+        }
+    }
+}
+
 #else /* DEBUG */
 void printPtr( StgPtr p )
 {
@@ -1115,4 +1213,6 @@ void printObj( StgClosure *obj )
 {
     debugBelch("obj 0x%p (enable -DDEBUG for more info) " , obj );
 }
+
+
 #endif /* DEBUG */