[Git][ghc/ghc][wip/stack_cloning] Deleted 1 commit: Introduce printing support for StackSnapshot#'s

Sven Tennie gitlab at gitlab.haskell.org
Mon Nov 2 07:37:50 UTC 2020



Sven Tennie pushed to branch wip/stack_cloning at Glasgow Haskell Compiler / GHC


WARNING: The push did not contain any new commits, but force pushed to delete the commits and changes below.


Deleted commits:
4e2fac38 by Sven Tennie at 2020-11-01T23:03:18-05:00
Introduce printing support for StackSnapshot#'s

This refactors the RTS's existing Printer module to allow printing of
StackSnapshot#'s.

- - - - -


7 changed files:

- + includes/rts/PrinterAPI.h
- libraries/base/GHC/Stack/CloneStack.hs
- rts/Disassembler.c
- rts/Disassembler.h
- rts/Printer.c
- rts/Printer.h
- rts/RtsSymbols.c


Changes:

=====================================
includes/rts/PrinterAPI.h
=====================================
@@ -0,0 +1,3 @@
+#pragma once
+
+extern void printStack (StgStack* stack);


=====================================
libraries/base/GHC/Stack/CloneStack.hs
=====================================
@@ -12,7 +12,8 @@
 module GHC.Stack.CloneStack (
   StackSnapshot(..),
   cloneMyStack,
-  cloneThreadStack
+  cloneThreadStack,
+  printStack
   ) where
 
 import GHC.Prim (StackSnapshot#, cloneMyStack#, ThreadId#)
@@ -68,3 +69,8 @@ cloneThreadStack (ThreadId tid#) = do
   freeStablePtr ptr
   takeMVar resultVar
 
+foreign import ccall "PrinterAPI.h printStack" printStack_c :: StackSnapshot# -> IO ()
+
+-- | Print the stack
+printStack :: StackSnapshot -> IO ()
+printStack (StackSnapshot stack) = printStack_c stack


=====================================
rts/Disassembler.c
=====================================
@@ -8,8 +8,6 @@
  * $Date: 2004/09/03 15:28:19 $
  * ---------------------------------------------------------------------------*/
 
-#if defined(DEBUG)
-
 #include "PosixSource.h"
 #include "Rts.h"
 #include "RtsAPI.h"
@@ -358,5 +356,3 @@ void disassemble( StgBCO *bco )
 
    debugBelch("\n");
 }
-
-#endif /* DEBUG */


=====================================
rts/Disassembler.h
=====================================
@@ -8,9 +8,5 @@
 
 #pragma once
 
-#if defined(DEBUG)
-
 RTS_PRIVATE int  disInstr   ( StgBCO *bco, int pc );
 RTS_PRIVATE void disassemble( StgBCO *bco );
-
-#endif


=====================================
rts/Printer.c
=====================================
@@ -17,6 +17,7 @@
 #include "sm/GCThread.h"
 #include "Hash.h"
 #include "Printer.h"
+#include "rts/PrinterAPI.h"
 #include "RtsUtils.h"
 
 #if defined(PROFILING)
@@ -25,9 +26,10 @@
 
 #include <string.h>
 
+#include "Disassembler.h"
+
 #if defined(DEBUG)
 
-#include "Disassembler.h"
 #include "Apply.h"
 
 /* --------------------------------------------------------------------------
@@ -58,402 +60,337 @@ void printObj( StgClosure *obj )
     printClosure(obj);
 }
 
-STATIC_INLINE void
-printStdObjHdr( const StgClosure *obj, char* tag )
+void
+printMutableList(bdescr *bd)
 {
-    debugBelch("%s(",tag);
-    printPtr((StgPtr)obj->header.info);
-#if defined(PROFILING)
-    debugBelch(", %s", obj->header.prof.ccs->cc->label);
-#endif
-}
+    StgPtr p;
 
-static void
-printStdObjPayload( const StgClosure *obj )
-{
-    StgWord i, j;
-    const StgInfoTable* info;
+    debugBelch("mutable list %p: ", bd);
 
-    info = get_itbl(obj);
-    for (i = 0; i < info->layout.payload.ptrs; ++i) {
-        debugBelch(", ");
-        printPtr((StgPtr)obj->payload[i]);
-    }
-    for (j = 0; j < info->layout.payload.nptrs; ++j) {
-        debugBelch(", %pd#",obj->payload[i+j]);
+    for (; bd != NULL; bd = bd->link) {
+        for (p = bd->start; p < bd->free; p++) {
+            debugBelch("%p (%s), ", (void *)*p, info_type((StgClosure *)*p));
+        }
     }
-    debugBelch(")\n");
+    debugBelch("\n");
 }
 
-static void
-printThunkPayload( StgThunk *obj )
+void printTSO( StgTSO *tso )
 {
-    StgWord i, j;
-    const StgInfoTable* info;
-
-    info = get_itbl((StgClosure *)obj);
-    for (i = 0; i < info->layout.payload.ptrs; ++i) {
-        debugBelch(", ");
-        printPtr((StgPtr)obj->payload[i]);
-    }
-    for (j = 0; j < info->layout.payload.nptrs; ++j) {
-        debugBelch(", %pd#",obj->payload[i+j]);
-    }
-    debugBelch(")\n");
+    printStack( tso->stackobj );
 }
 
-static void
-printThunkObject( StgThunk *obj, char* tag )
+void printStaticObjects( StgClosure *p )
 {
-    printStdObjHdr( (StgClosure *)obj, tag );
-    printThunkPayload( obj );
+    while (p != END_OF_STATIC_OBJECT_LIST) {
+        p = UNTAG_STATIC_LIST_PTR(p);
+        printClosure(p);
+
+        const StgInfoTable *info = get_itbl(p);
+        p = *STATIC_LINK(info, p);
+    }
 }
 
-void
-printClosure( const StgClosure *obj )
+void printWeakLists()
 {
-    debugBelch("%p: ", obj);
-    obj = UNTAG_CONST_CLOSURE(obj);
-    const StgInfoTable* info = get_itbl(obj);
+    debugBelch("======= WEAK LISTS =======\n");
 
-    while (IS_FORWARDING_PTR(info)) {
-        obj = (StgClosure*)UN_FORWARDING_PTR(info);
-        debugBelch("(forwarding to %p) ", (void*)obj);
-        info = get_itbl(obj);
+    for (uint32_t cap_idx = 0; cap_idx < n_capabilities; ++cap_idx) {
+        debugBelch("Capability %d:\n", cap_idx);
+        Capability *cap = capabilities[cap_idx];
+        for (StgWeak *weak = cap->weak_ptr_list_hd; weak; weak = weak->link) {
+            printClosure((StgClosure*)weak);
+        }
     }
 
-    switch ( info->type ) {
-    case INVALID_OBJECT:
-            barf("Invalid object");
-
-    case CONSTR:
-    case CONSTR_1_0: case CONSTR_0_1:
-    case CONSTR_1_1: case CONSTR_0_2: case CONSTR_2_0:
-    case CONSTR_NOCAF:
-        {
-            StgWord i, j;
-            const StgConInfoTable *con_info = get_con_itbl (obj);
-
-            debugBelch("%s(", GET_CON_DESC(con_info));
-            for (i = 0; i < info->layout.payload.ptrs; ++i) {
-                if (i != 0) debugBelch(", ");
-                printPtr((StgPtr)obj->payload[i]);
-            }
-            for (j = 0; j < info->layout.payload.nptrs; ++j) {
-                if (i != 0 || j != 0) debugBelch(", ");
-                debugBelch("%p#", obj->payload[i+j]);
-            }
-            debugBelch(")\n");
-            break;
+    for (uint32_t gen_idx = 0; gen_idx <= oldest_gen->no; ++gen_idx) {
+        generation *gen = &generations[gen_idx];
+        debugBelch("Generation %d current weaks:\n", gen_idx);
+        for (StgWeak *weak = gen->weak_ptr_list; weak; weak = weak->link) {
+            printClosure((StgClosure*)weak);
         }
+        debugBelch("Generation %d old weaks:\n", gen_idx);
+        for (StgWeak *weak = gen->old_weak_ptr_list; weak; weak = weak->link) {
+            printClosure((StgClosure*)weak);
+        }
+    }
 
-    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:
-        debugBelch("FUN/%d(",(int)itbl_to_fun_itbl(info)->f.arity);
-        printPtr((StgPtr)obj->header.info);
-#if defined(PROFILING)
-        debugBelch(", %s", obj->header.prof.ccs->cc->label);
-#endif
-        printStdObjPayload(obj);
-        break;
-
-    case PRIM:
-        debugBelch("PRIM(");
-        printPtr((StgPtr)obj->header.info);
-        printStdObjPayload(obj);
-        break;
-
-    case MUT_PRIM:
-        debugBelch("MUT_PRIM(");
-        printPtr((StgPtr)obj->header.info);
-        printStdObjPayload(obj);
-        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? */
-#if defined(PROFILING)
-            printThunkObject((StgThunk *)obj,GET_PROF_DESC(info));
-#else
-            printThunkObject((StgThunk *)obj,"THUNK");
-#endif
-            break;
+    debugBelch("=========================\n");
+}
 
-    case THUNK_SELECTOR:
-        printStdObjHdr(obj, "THUNK_SELECTOR");
-        debugBelch(", %p)\n", ((StgSelector *)obj)->selectee);
-        break;
+void printLargeAndPinnedObjects()
+{
+    debugBelch("====== PINNED OBJECTS ======\n");
 
-    case BCO:
-            disassemble( (StgBCO*)obj );
-            break;
+    for (uint32_t cap_idx = 0; cap_idx < n_capabilities; ++cap_idx) {
+        Capability *cap = capabilities[cap_idx];
 
-    case AP:
-        {
-            StgAP* ap = (StgAP*)obj;
-            StgWord i;
-            debugBelch("AP("); printPtr((StgPtr)ap->fun);
-            for (i = 0; i < ap->n_args; ++i) {
-                debugBelch(", ");
-                printPtr((P_)ap->payload[i]);
-            }
-            debugBelch(")\n");
-            break;
+        debugBelch("Capability %d: Current pinned object block: %p\n",
+                   cap_idx, (void*)cap->pinned_object_block);
+        for (bdescr *bd = cap->pinned_object_blocks; bd; bd = bd->link) {
+            debugBelch("%p\n", (void*)bd);
         }
+    }
 
-    case PAP:
-        {
-            StgPAP* pap = (StgPAP*)obj;
-            StgWord i;
-            debugBelch("PAP/%d(",(int)pap->arity);
-            printPtr((StgPtr)pap->fun);
-            for (i = 0; i < pap->n_args; ++i) {
-                debugBelch(", ");
-                printPtr((StgPtr)pap->payload[i]);
-            }
-            debugBelch(")\n");
-            break;
+    debugBelch("====== LARGE OBJECTS =======\n");
+    for (uint32_t gen_idx = 0; gen_idx <= oldest_gen->no; ++gen_idx) {
+        generation *gen = &generations[gen_idx];
+        debugBelch("Generation %d current large objects:\n", gen_idx);
+        for (bdescr *bd = gen->large_objects; bd; bd = bd->link) {
+            debugBelch("%p: ", (void*)bd);
+            printClosure((StgClosure*)bd->start);
         }
 
-    case AP_STACK:
-        {
-            StgAP_STACK* ap = (StgAP_STACK*)obj;
-            StgWord i;
-            debugBelch("AP_STACK("); printPtr((StgPtr)ap->fun);
-            for (i = 0; i < ap->size; ++i) {
-                debugBelch(", ");
-                printPtr((P_)ap->payload[i]);
-            }
-            debugBelch(")\n");
-            break;
+        debugBelch("Generation %d scavenged large objects:\n", gen_idx);
+        for (bdescr *bd = gen->scavenged_large_objects; bd; bd = bd->link) {
+            debugBelch("%p: ", (void*)bd);
+            printClosure((StgClosure*)bd->start);
         }
+    }
 
-    case IND:
-            debugBelch("IND(");
-            printPtr((StgPtr)((StgInd*)obj)->indirectee);
-            debugBelch(")\n");
-            break;
-
-    case IND_STATIC:
-            debugBelch("IND_STATIC(");
-            printPtr((StgPtr)((StgInd*)obj)->indirectee);
-            debugBelch(")\n");
-            break;
+    debugBelch("============================\n");
+}
 
-    case BLACKHOLE:
-            debugBelch("BLACKHOLE(");
-            printPtr((StgPtr)((StgInd*)obj)->indirectee);
-            debugBelch(")\n");
-            break;
+/* --------------------------------------------------------------------------
+ * Address printing code
+ *
+ * Uses symbol table in (unstripped executable)
+ * ------------------------------------------------------------------------*/
 
-    /* Cannot happen -- use default case.
-    case RET_BCO:
-    case RET_SMALL:
-    case RET_BIG:
-    case RET_FUN:
-    */
+/* --------------------------------------------------------------------------
+ * Simple lookup table
+ * address -> function name
+ * ------------------------------------------------------------------------*/
 
-    case UPDATE_FRAME:
-        {
-            StgUpdateFrame* u = (StgUpdateFrame*)obj;
-            debugBelch("%s(", info_update_frame(obj));
-            printPtr((StgPtr)GET_INFO((StgClosure *)u));
-            debugBelch(",");
-            printPtr((StgPtr)u->updatee);
-            debugBelch(")\n");
-            break;
-        }
+static HashTable * add_to_fname_table = NULL;
 
-    case CATCH_FRAME:
-        {
-            StgCatchFrame* u = (StgCatchFrame*)obj;
-            debugBelch("CATCH_FRAME(");
-            printPtr((StgPtr)GET_INFO((StgClosure *)u));
-            debugBelch(",");
-            printPtr((StgPtr)u->handler);
-            debugBelch(")\n");
-            break;
-        }
-
-    case UNDERFLOW_FRAME:
-        {
-            StgUnderflowFrame* u = (StgUnderflowFrame*)obj;
-            debugBelch("UNDERFLOW_FRAME(");
-            printPtr((StgPtr)u->next_chunk);
-            debugBelch(")\n");
-            break;
-        }
-
-    case STOP_FRAME:
-        {
-            StgStopFrame* u = (StgStopFrame*)obj;
-            debugBelch("STOP_FRAME(");
-            printPtr((StgPtr)GET_INFO((StgClosure *)u));
-            debugBelch(")\n");
-            break;
-        }
-
-    case ARR_WORDS:
-        {
-            StgWord i;
-            debugBelch("ARR_WORDS(\"");
-            for (i=0; i<arr_words_words((StgArrBytes *)obj); i++)
-              debugBelch("%" FMT_Word, (W_)((StgArrBytes *)obj)->payload[i]);
-            debugBelch("\")\n");
-            break;
-        }
-
-    case MUT_ARR_PTRS_CLEAN:
-        debugBelch("MUT_ARR_PTRS_CLEAN(size=%" FMT_Word ")\n", (W_)((StgMutArrPtrs *)obj)->ptrs);
-        break;
-
-    case MUT_ARR_PTRS_DIRTY:
-        debugBelch("MUT_ARR_PTRS_DIRTY(size=%" FMT_Word ")\n", (W_)((StgMutArrPtrs *)obj)->ptrs);
-        break;
+const char *lookupGHCName( void *addr )
+{
+    if (add_to_fname_table == NULL)
+        return NULL;
 
-    case MUT_ARR_PTRS_FROZEN_CLEAN:
-        debugBelch("MUT_ARR_PTRS_FROZEN_CLEAN(size=%" FMT_Word ")\n", (W_)((StgMutArrPtrs *)obj)->ptrs);
-        break;
+    return lookupHashTable(add_to_fname_table, (StgWord)addr);
+}
 
-    case SMALL_MUT_ARR_PTRS_CLEAN:
-        debugBelch("SMALL_MUT_ARR_PTRS_CLEAN(size=%" FMT_Word ")\n",
-                   (W_)((StgSmallMutArrPtrs *)obj)->ptrs);
-        break;
+/* --------------------------------------------------------------------------
+ * Symbol table loading
+ * ------------------------------------------------------------------------*/
 
-    case SMALL_MUT_ARR_PTRS_DIRTY:
-        debugBelch("SMALL_MUT_ARR_PTRS_DIRTY(size=%" FMT_Word ")\n",
-                   (W_)((StgSmallMutArrPtrs *)obj)->ptrs);
-        break;
+/* Causing linking trouble on Win32 plats, so I'm
+   disabling this for now.
+*/
+#if defined(USING_LIBBFD)
+#    define PACKAGE 1
+#    define PACKAGE_VERSION 1
+/* Those PACKAGE_* defines are workarounds for bfd:
+ *     https://sourceware.org/bugzilla/show_bug.cgi?id=14243
+ * ghc's build system filter PACKAGE_* values out specifically to avoid clashes
+ * with user's autoconf-based Cabal packages.
+ * It's a shame <bfd.h> checks for unrelated fields instead of actually used
+ * macros.
+ */
+#    include <bfd.h>
 
-    case SMALL_MUT_ARR_PTRS_FROZEN_CLEAN:
-        debugBelch("SMALL_MUT_ARR_PTRS_FROZEN_CLEAN(size=%" FMT_Word ")\n",
-                   (W_)((StgSmallMutArrPtrs *)obj)->ptrs);
-        break;
+/* Fairly ad-hoc piece of code that seems to filter out a lot of
+ * rubbish like the obj-splitting symbols
+ */
 
-    case MVAR_CLEAN:
-    case MVAR_DIRTY:
-        {
-          StgMVar* mv = (StgMVar*)obj;
+static bool isReal( flagword flags STG_UNUSED, const char *name )
+{
+#if 0
+    /* ToDo: make this work on BFD */
+    int tp = type & N_TYPE;
+    if (tp == N_TEXT || tp == N_DATA) {
+        return (name[0] == '_' && name[1] != '_');
+    } else {
+        return false;
+    }
+#else
+    if (*name == '\0'  ||
+        (name[0] == 'g' && name[1] == 'c' && name[2] == 'c') ||
+        (name[0] == 'c' && name[1] == 'c' && name[2] == '.')) {
+        return false;
+    }
+    return true;
+#endif
+}
 
-          debugBelch("MVAR(head=");
-          if ((StgClosure*)mv->head == &stg_END_TSO_QUEUE_closure) {
-              debugBelch("END_TSO_QUEUE");
-          } else {
-              debugBelch("%p", mv->head);
-          }
+extern void DEBUG_LoadSymbols( const char *name )
+{
+    bfd* abfd;
+    char **matching;
 
-          debugBelch(", tail=");
-          if ((StgClosure*)mv->tail == &stg_END_TSO_QUEUE_closure) {
-              debugBelch("END_TSO_QUEUE");
-          } else {
-              debugBelch("%p", mv->tail);
-          }
+    bfd_init();
+    abfd = bfd_openr(name, "default");
+    if (abfd == NULL) {
+        barf("can't open executable %s to get symbol table", name);
+    }
+    if (!bfd_check_format_matches (abfd, bfd_object, &matching)) {
+        barf("mismatch");
+    }
 
-          debugBelch(", value=");
-          if ((StgClosure*)mv->value == &stg_END_TSO_QUEUE_closure) {
-              debugBelch("END_TSO_QUEUE");
-          } else {
-              debugBelch("%p", mv->value);
-          }
-          debugBelch(")\n");
+    {
+        long storage_needed;
+        asymbol **symbol_table;
+        long number_of_symbols;
+        long num_real_syms = 0;
+        long i;
 
-          break;
-        }
+        storage_needed = bfd_get_symtab_upper_bound (abfd);
 
-    case TVAR:
-        {
-          StgTVar* tv = (StgTVar*)obj;
-          debugBelch("TVAR(value=%p, wq=%p, num_updates=%" FMT_Word ")\n", tv->current_value, tv->first_watch_queue_entry, tv->num_updates);
-          break;
+        if (storage_needed < 0) {
+            barf("can't read symbol table");
         }
+        symbol_table = (asymbol **) stgMallocBytes(storage_needed,"DEBUG_LoadSymbols");
 
-    case MUT_VAR_CLEAN:
-        {
-          StgMutVar* mv = (StgMutVar*)obj;
-          debugBelch("MUT_VAR_CLEAN(var=%p)\n", mv->var);
-          break;
-        }
+        number_of_symbols = bfd_canonicalize_symtab (abfd, symbol_table);
 
-    case MUT_VAR_DIRTY:
-        {
-          StgMutVar* mv = (StgMutVar*)obj;
-          debugBelch("MUT_VAR_DIRTY(var=%p)\n", mv->var);
-          break;
+        if (number_of_symbols < 0) {
+            barf("can't canonicalise symbol table");
         }
 
-    case WEAK:
-            debugBelch("WEAK(");
-            debugBelch("key=%p value=%p finalizer=%p",
-                    (StgPtr)(((StgWeak*)obj)->key),
-                    (StgPtr)(((StgWeak*)obj)->value),
-                    (StgPtr)(((StgWeak*)obj)->finalizer));
-            debugBelch(")\n");
-            /* ToDo: chase 'link' ? */
-            break;
-
-    case TSO:
-      debugBelch("TSO(");
-      debugBelch("%lu (%p)",(unsigned long)(((StgTSO*)obj)->id), (StgTSO*)obj);
-      debugBelch(")\n");
-      break;
-
-    case STACK:
-      debugBelch("STACK\n");
-      break;
-
-#if 0
-      /* Symptomatic of a problem elsewhere, have it fall-through & fail */
-    case EVACUATED:
-      debugBelch("EVACUATED(");
-      printClosure((StgEvacuated*)obj->evacuee);
-      debugBelch(")\n");
-      break;
-#endif
+        if (add_to_fname_table == NULL)
+            add_to_fname_table = allocHashTable();
 
-    case COMPACT_NFDATA:
-        debugBelch("COMPACT_NFDATA(size=%" FMT_Word ")\n",
-                   (W_)((StgCompactNFData *)obj)->totalW * (W_)sizeof(W_));
-        break;
+        for( i = 0; i != number_of_symbols; ++i ) {
+            symbol_info info;
+            bfd_get_symbol_info(abfd,symbol_table[i],&info);
+            if (isReal(info.type, info.name)) {
+                insertHashTable(add_to_fname_table,
+                                info.value, (void*)info.name);
+                num_real_syms += 1;
+            }
+        }
 
-    case TREC_CHUNK:
-        debugBelch("TREC_CHUNK\n");
-        break;
+        IF_DEBUG(interpreter,
+                 debugBelch("Loaded %ld symbols. Of which %ld are real symbols\n",
+                         number_of_symbols, num_real_syms)
+                 );
 
-    default:
-            //barf("printClosure %d",get_itbl(obj)->type);
-            debugBelch("*** printClosure: unknown type %d ****\n",
-                    (int)get_itbl(obj)->type );
-            barf("printClosure %d",get_itbl(obj)->type);
-            return;
+        stgFree(symbol_table);
     }
 }
 
-void
-printMutableList(bdescr *bd)
+#else /* USING_LIBBFD */
+
+extern void DEBUG_LoadSymbols( const char *name STG_UNUSED )
 {
-    StgPtr p;
+  /* nothing, yet */
+}
 
-    debugBelch("mutable list %p: ", bd);
+#endif /* USING_LIBBFD */
 
-    for (; bd != NULL; bd = bd->link) {
-        for (p = bd->start; p < bd->free; p++) {
-            debugBelch("%p (%s), ", (void *)*p, info_type((StgClosure *)*p));
-        }
-    }
-    debugBelch("\n");
-}
+void findPtr(P_ p, int);                /* keep gcc -Wall happy */
 
-// If you know you have an UPDATE_FRAME, but want to know exactly which.
-const char *info_update_frame(const StgClosure *closure)
+int searched = 0;
+
+static int
+findPtrBlocks (StgPtr p, bdescr *bd, StgPtr arr[], int arr_size, int i)
 {
-    // Note: We intentionally don't take the info table pointer as
-    // an argument. As it will be confusing whether one should pass
-    // it pointing to the code or struct members when compiling with
-    // TABLES_NEXT_TO_CODE.
+    StgPtr q, r, end;
+    for (; bd; bd = bd->link) {
+        searched++;
+        for (q = bd->start; q < bd->free; q++) {
+            if (UNTAG_CONST_CLOSURE((StgClosure*)*q) == (const StgClosure *)p) {
+                if (i < arr_size) {
+                    for (r = bd->start; r < bd->free; r = end) {
+                        // skip over zeroed-out slop
+                        while (*r == 0) r++;
+                        if (!LOOKS_LIKE_CLOSURE_PTR(r)) {
+                            debugBelch("%p found at %p, no closure at %p\n",
+                                       p, q, r);
+                            break;
+                        }
+                        end = r + closure_sizeW((StgClosure*)r);
+                        if (q < end) {
+                            debugBelch("%p = ", r);
+                            printClosure((StgClosure *)r);
+                            arr[i++] = r;
+                            break;
+                        }
+                    }
+                    if (r >= bd->free) {
+                        debugBelch("%p found at %p, closure?", p, q);
+                    }
+                } else {
+                    return i;
+                }
+            }
+        }
+    }
+    return i;
+}
+
+void
+findPtr(P_ p, int follow)
+{
+  uint32_t g, n;
+  bdescr *bd;
+  const int arr_size = 1024;
+  StgPtr arr[arr_size];
+  int i = 0;
+  searched = 0;
+
+#if 0
+  // We can't search the nursery, because we don't know which blocks contain
+  // valid data, because the bd->free pointers in the nursery are only reset
+  // just before a block is used.
+  for (n = 0; n < n_capabilities; n++) {
+      bd = nurseries[i].blocks;
+      i = findPtrBlocks(p,bd,arr,arr_size,i);
+      if (i >= arr_size) return;
+  }
+#endif
+
+  for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
+      bd = generations[g].blocks;
+      i = findPtrBlocks(p,bd,arr,arr_size,i);
+      bd = generations[g].large_objects;
+      i = findPtrBlocks(p,bd,arr,arr_size,i);
+      if (i >= arr_size) return;
+      for (n = 0; n < n_capabilities; n++) {
+          i = findPtrBlocks(p, gc_threads[n]->gens[g].part_list,
+                            arr, arr_size, i);
+          i = findPtrBlocks(p, gc_threads[n]->gens[g].todo_bd,
+                            arr, arr_size, i);
+      }
+      if (i >= arr_size) return;
+  }
+  if (follow && i == 1) {
+      debugBelch("-->\n");
+      findPtr(arr[0], 1);
+  }
+}
+
+const char *what_next_strs[] = {
+  [0]               = "(unknown)",
+  [ThreadRunGHC]    = "ThreadRunGHC",
+  [ThreadInterpret] = "ThreadInterpret",
+  [ThreadKilled]    = "ThreadKilled",
+  [ThreadComplete]  = "ThreadComplete"
+};
+
+#else /* DEBUG */
+void printPtr( StgPtr p )
+{
+    debugBelch("ptr 0x%p (enable -DDEBUG for more info) " , p );
+}
+
+void printObj( StgClosure *obj )
+{
+    debugBelch("obj 0x%p (enable -DDEBUG for more info) " , obj );
+}
+
+
+#endif /* DEBUG */
+
+// If you know you have an UPDATE_FRAME, but want to know exactly which.
+const char *info_update_frame(const StgClosure *closure)
+{
+    // Note: We intentionally don't take the info table pointer as
+    // an argument. As it will be confusing whether one should pass
+    // it pointing to the code or struct members when compiling with
+    // TABLES_NEXT_TO_CODE.
     const StgInfoTable *info = closure->header.info;
     if (info == &stg_upd_frame_info) {
         return "NORMAL_UPDATE_FRAME";
@@ -467,501 +404,567 @@ const char *info_update_frame(const StgClosure *closure)
 }
 
 static void
-printSmallBitmap( StgPtr spBottom, StgPtr payload, StgWord bitmap,
-                    uint32_t size )
+printThunkPayload( StgThunk *obj )
 {
-    uint32_t i;
+    StgWord i, j;
+    const StgInfoTable* info;
 
-    for(i = 0; i < size; i++, bitmap >>= 1 ) {
-        debugBelch("   stk[%ld] (%p) = ", (long)(spBottom-(payload+i)), payload+i);
-        if ((bitmap & 1) == 0) {
-            printPtr((P_)payload[i]);
-            debugBelch(" -- ");
-            printObj((StgClosure*) payload[i]);
-        } else {
-            debugBelch("Word# %" FMT_Word "\n", (W_)payload[i]);
-        }
+    info = get_itbl((StgClosure *)obj);
+    for (i = 0; i < info->layout.payload.ptrs; ++i) {
+        debugBelch(", ");
+        printPtr((StgPtr)obj->payload[i]);
+    }
+    for (j = 0; j < info->layout.payload.nptrs; ++j) {
+        debugBelch(", %pd#",obj->payload[i+j]);
     }
+    debugBelch(")\n");
+}
+
+STATIC_INLINE void
+printStdObjHdr( const StgClosure *obj, char* tag )
+{
+    debugBelch("%s(",tag);
+    printPtr((StgPtr)obj->header.info);
+#if defined(PROFILING)
+    debugBelch(", %s", obj->header.prof.ccs->cc->label);
+#endif
 }
 
 static void
-printLargeBitmap( StgPtr spBottom, StgPtr payload, StgLargeBitmap* large_bitmap,
-                    uint32_t size )
+printThunkObject( StgThunk *obj, char* tag )
 {
-    StgWord bmp;
-    uint32_t i, j;
+    printStdObjHdr( (StgClosure *)obj, tag );
+    printThunkPayload( obj );
+}
 
-    i = 0;
-    for (bmp=0; i < size; bmp++) {
-        StgWord bitmap = large_bitmap->bitmap[bmp];
-        j = 0;
-        for(; i < size && j < BITS_IN(W_); j++, i++, bitmap >>= 1 ) {
-            debugBelch("   stk[%" FMT_Word "] (%p) = ", (W_)(spBottom-(payload+i)), payload+i);
-            if ((bitmap & 1) == 0) {
-                printPtr((P_)payload[i]);
-                debugBelch(" -- ");
-                printObj((StgClosure*) payload[i]);
-            } else {
-                debugBelch("Word# %" FMT_Word "\n", (W_)payload[i]);
-            }
-        }
+static void
+printStdObjPayload( const StgClosure *obj )
+{
+    StgWord i, j;
+    const StgInfoTable* info;
+
+    info = get_itbl(obj);
+    for (i = 0; i < info->layout.payload.ptrs; ++i) {
+        debugBelch(", ");
+        printPtr((StgPtr)obj->payload[i]);
+    }
+    for (j = 0; j < info->layout.payload.nptrs; ++j) {
+        debugBelch(", %pd#",obj->payload[i+j]);
     }
+    debugBelch(")\n");
 }
 
 void
-printStackChunk( StgPtr sp, StgPtr spBottom )
+printClosure( const StgClosure *obj )
 {
-    const StgInfoTable *info;
+    debugBelch("%p: ", obj);
+    obj = UNTAG_CONST_CLOSURE(obj);
+    const StgInfoTable* info = get_itbl(obj);
 
-    ASSERT(sp <= spBottom);
-    for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) {
+    while (IS_FORWARDING_PTR(info)) {
+        obj = (StgClosure*)UN_FORWARDING_PTR(info);
+        debugBelch("(forwarding to %p) ", (void*)obj);
+        info = get_itbl(obj);
+    }
 
-        info = get_itbl((StgClosure *)sp);
+    switch ( info->type ) {
+    case INVALID_OBJECT:
+            barf("Invalid object");
 
-        switch (info->type) {
+    case CONSTR:
+    case CONSTR_1_0: case CONSTR_0_1:
+    case CONSTR_1_1: case CONSTR_0_2: case CONSTR_2_0:
+    case CONSTR_NOCAF:
+        {
+            StgWord i, j;
+            const StgConInfoTable *con_info = get_con_itbl (obj);
 
-        case UPDATE_FRAME:
-        case CATCH_FRAME:
-        case UNDERFLOW_FRAME:
-        case STOP_FRAME:
-            printClosure((StgClosure*)sp);
-            continue;
+            debugBelch("%s(", GET_CON_DESC(con_info));
+            for (i = 0; i < info->layout.payload.ptrs; ++i) {
+                if (i != 0) debugBelch(", ");
+                printPtr((StgPtr)obj->payload[i]);
+            }
+            for (j = 0; j < info->layout.payload.nptrs; ++j) {
+                if (i != 0 || j != 0) debugBelch(", ");
+                debugBelch("%p#", obj->payload[i+j]);
+            }
+            debugBelch(")\n");
+            break;
+        }
 
-        case RET_SMALL: {
-            StgWord c = *sp;
-            if (c == (StgWord)&stg_ctoi_R1p_info) {
-                debugBelch("tstg_ctoi_ret_R1p_info\n" );
-            } else if (c == (StgWord)&stg_ctoi_R1n_info) {
-                debugBelch("stg_ctoi_ret_R1n_info\n" );
-            } else if (c == (StgWord)&stg_ctoi_F1_info) {
-                debugBelch("stg_ctoi_ret_F1_info\n" );
-            } else if (c == (StgWord)&stg_ctoi_D1_info) {
-                debugBelch("stg_ctoi_ret_D1_info\n" );
-            } else if (c == (StgWord)&stg_ctoi_V_info) {
-                debugBelch("stg_ctoi_ret_V_info\n" );
-            } else if (c == (StgWord)&stg_ap_v_info) {
-                debugBelch("stg_ap_v_info\n" );
-            } else if (c == (StgWord)&stg_ap_f_info) {
-                debugBelch("stg_ap_f_info\n" );
-            } else if (c == (StgWord)&stg_ap_d_info) {
-                debugBelch("stg_ap_d_info\n" );
-            } else if (c == (StgWord)&stg_ap_l_info) {
-                debugBelch("stg_ap_l_info\n" );
-            } else if (c == (StgWord)&stg_ap_n_info) {
-                debugBelch("stg_ap_n_info\n" );
-            } else if (c == (StgWord)&stg_ap_p_info) {
-                debugBelch("stg_ap_p_info\n" );
-            } else if (c == (StgWord)&stg_ap_pp_info) {
-                debugBelch("stg_ap_pp_info\n" );
-            } else if (c == (StgWord)&stg_ap_ppp_info) {
-                debugBelch("stg_ap_ppp_info\n" );
-            } else if (c == (StgWord)&stg_ap_pppp_info) {
-                debugBelch("stg_ap_pppp_info\n" );
-            } else if (c == (StgWord)&stg_ap_ppppp_info) {
-                debugBelch("stg_ap_ppppp_info\n" );
-            } else if (c == (StgWord)&stg_ap_pppppp_info) {
-                debugBelch("stg_ap_pppppp_info\n" );
-            } else if (c == (StgWord)&stg_ret_v_info) {
-                debugBelch("stg_ret_v_info\n" );
-            } else if (c == (StgWord)&stg_ret_p_info) {
-                debugBelch("stg_ret_p_info\n" );
-            } else if (c == (StgWord)&stg_ret_n_info) {
-                debugBelch("stg_ret_n_info\n" );
-            } else if (c == (StgWord)&stg_ret_f_info) {
-                debugBelch("stg_ret_f_info\n" );
-            } else if (c == (StgWord)&stg_ret_d_info) {
-                debugBelch("stg_ret_d_info\n" );
-            } else if (c == (StgWord)&stg_ret_l_info) {
-                debugBelch("stg_ret_l_info\n" );
+    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:
+        debugBelch("FUN/%d(",(int)itbl_to_fun_itbl(info)->f.arity);
+        printPtr((StgPtr)obj->header.info);
 #if defined(PROFILING)
-            } else if (c == (StgWord)&stg_restore_cccs_info) {
-                debugBelch("stg_restore_cccs_info\n" );
-                fprintCCS(stderr, (CostCentreStack*)sp[1]);
-                debugBelch("\n" );
-                continue;
-            } else if (c == (StgWord)&stg_restore_cccs_eval_info) {
-                debugBelch("stg_restore_cccs_eval_info\n" );
-                fprintCCS(stderr, (CostCentreStack*)sp[1]);
-                debugBelch("\n" );
-                continue;
+        debugBelch(", %s", obj->header.prof.ccs->cc->label);
 #endif
-            } else {
-                debugBelch("RET_SMALL (%p)\n", info);
-            }
-            StgWord bitmap = info->layout.bitmap;
-            printSmallBitmap(spBottom, sp+1,
-                             BITMAP_BITS(bitmap), BITMAP_SIZE(bitmap));
-            continue;
-        }
+        printStdObjPayload(obj);
+        break;
 
-        case RET_BCO: {
-            StgBCO *bco;
+    case PRIM:
+        debugBelch("PRIM(");
+        printPtr((StgPtr)obj->header.info);
+        printStdObjPayload(obj);
+        break;
 
-            bco = ((StgBCO *)sp[1]);
+    case MUT_PRIM:
+        debugBelch("MUT_PRIM(");
+        printPtr((StgPtr)obj->header.info);
+        printStdObjPayload(obj);
+        break;
 
-            debugBelch("RET_BCO (%p)\n", sp);
-            printLargeBitmap(spBottom, sp+2,
-                             BCO_BITMAP(bco), BCO_BITMAP_SIZE(bco));
-            continue;
-        }
+    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? */
+#if defined(PROFILING)
+            printThunkObject((StgThunk *)obj,GET_PROF_DESC(info));
+#else
+            printThunkObject((StgThunk *)obj,"THUNK");
+#endif
+            break;
 
-        case RET_BIG:
-            debugBelch("RET_BIG (%p)\n", sp);
-            StgLargeBitmap* bitmap = GET_LARGE_BITMAP(info);
-            printLargeBitmap(spBottom,
-                            (StgPtr)((StgClosure *) sp)->payload,
-                            bitmap,
-                            bitmap->size);
-            continue;
-        case RET_FUN:
+    case THUNK_SELECTOR:
+        printStdObjHdr(obj, "THUNK_SELECTOR");
+        debugBelch(", %p)\n", ((StgSelector *)obj)->selectee);
+        break;
+
+    case BCO:
+            disassemble( (StgBCO*)obj );
+            break;
+
+    case AP:
         {
-            const StgFunInfoTable *fun_info;
-            StgRetFun *ret_fun;
+            StgAP* ap = (StgAP*)obj;
+            StgWord i;
+            debugBelch("AP("); printPtr((StgPtr)ap->fun);
+            for (i = 0; i < ap->n_args; ++i) {
+                debugBelch(", ");
+                printPtr((P_)ap->payload[i]);
+            }
+            debugBelch(")\n");
+            break;
+        }
 
-            ret_fun = (StgRetFun *)sp;
-            fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
-            debugBelch("RET_FUN (%p) (type=%d)\n", ret_fun->fun, (int)fun_info->f.fun_type);
-            switch (fun_info->f.fun_type) {
-            case ARG_GEN:
-                printSmallBitmap(spBottom, sp+2,
-                                 BITMAP_BITS(fun_info->f.b.bitmap),
-                                 BITMAP_SIZE(fun_info->f.b.bitmap));
-                break;
-            case ARG_GEN_BIG:
-                printLargeBitmap(spBottom, sp+2,
-                                 GET_FUN_LARGE_BITMAP(fun_info),
-                                 GET_FUN_LARGE_BITMAP(fun_info)->size);
-                break;
-            default:
-                printSmallBitmap(spBottom, sp+2,
-                                 BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]),
-                                 BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]));
-                break;
+    case PAP:
+        {
+            StgPAP* pap = (StgPAP*)obj;
+            StgWord i;
+            debugBelch("PAP/%d(",(int)pap->arity);
+            printPtr((StgPtr)pap->fun);
+            for (i = 0; i < pap->n_args; ++i) {
+                debugBelch(", ");
+                printPtr((StgPtr)pap->payload[i]);
             }
-            continue;
+            debugBelch(")\n");
+            break;
         }
 
-        default:
-            debugBelch("unknown object %d\n", (int)info->type);
-            barf("printStackChunk");
+    case AP_STACK:
+        {
+            StgAP_STACK* ap = (StgAP_STACK*)obj;
+            StgWord i;
+            debugBelch("AP_STACK("); printPtr((StgPtr)ap->fun);
+            for (i = 0; i < ap->size; ++i) {
+                debugBelch(", ");
+                printPtr((P_)ap->payload[i]);
+            }
+            debugBelch(")\n");
+            break;
         }
-    }
-}
 
-static void printStack( StgStack *stack )
-{
-    printStackChunk( stack->sp, stack->stack + stack->stack_size );
-}
+    case IND:
+            debugBelch("IND(");
+            printPtr((StgPtr)((StgInd*)obj)->indirectee);
+            debugBelch(")\n");
+            break;
 
-void printTSO( StgTSO *tso )
-{
-    printStack( tso->stackobj );
-}
+    case IND_STATIC:
+            debugBelch("IND_STATIC(");
+            printPtr((StgPtr)((StgInd*)obj)->indirectee);
+            debugBelch(")\n");
+            break;
 
-void printStaticObjects( StgClosure *p )
-{
-    while (p != END_OF_STATIC_OBJECT_LIST) {
-        p = UNTAG_STATIC_LIST_PTR(p);
-        printClosure(p);
+    case BLACKHOLE:
+            debugBelch("BLACKHOLE(");
+            printPtr((StgPtr)((StgInd*)obj)->indirectee);
+            debugBelch(")\n");
+            break;
 
-        const StgInfoTable *info = get_itbl(p);
-        p = *STATIC_LINK(info, p);
-    }
-}
+    /* Cannot happen -- use default case.
+    case RET_BCO:
+    case RET_SMALL:
+    case RET_BIG:
+    case RET_FUN:
+    */
 
-void printWeakLists()
-{
-    debugBelch("======= WEAK LISTS =======\n");
+    case UPDATE_FRAME:
+        {
+            StgUpdateFrame* u = (StgUpdateFrame*)obj;
+            debugBelch("%s(", info_update_frame(obj));
+            printPtr((StgPtr)GET_INFO((StgClosure *)u));
+            debugBelch(",");
+            printPtr((StgPtr)u->updatee);
+            debugBelch(")\n");
+            break;
+        }
 
-    for (uint32_t cap_idx = 0; cap_idx < n_capabilities; ++cap_idx) {
-        debugBelch("Capability %d:\n", cap_idx);
-        Capability *cap = capabilities[cap_idx];
-        for (StgWeak *weak = cap->weak_ptr_list_hd; weak; weak = weak->link) {
-            printClosure((StgClosure*)weak);
+    case CATCH_FRAME:
+        {
+            StgCatchFrame* u = (StgCatchFrame*)obj;
+            debugBelch("CATCH_FRAME(");
+            printPtr((StgPtr)GET_INFO((StgClosure *)u));
+            debugBelch(",");
+            printPtr((StgPtr)u->handler);
+            debugBelch(")\n");
+            break;
         }
-    }
 
-    for (uint32_t gen_idx = 0; gen_idx <= oldest_gen->no; ++gen_idx) {
-        generation *gen = &generations[gen_idx];
-        debugBelch("Generation %d current weaks:\n", gen_idx);
-        for (StgWeak *weak = gen->weak_ptr_list; weak; weak = weak->link) {
-            printClosure((StgClosure*)weak);
+    case UNDERFLOW_FRAME:
+        {
+            StgUnderflowFrame* u = (StgUnderflowFrame*)obj;
+            debugBelch("UNDERFLOW_FRAME(");
+            printPtr((StgPtr)u->next_chunk);
+            debugBelch(")\n");
+            break;
         }
-        debugBelch("Generation %d old weaks:\n", gen_idx);
-        for (StgWeak *weak = gen->old_weak_ptr_list; weak; weak = weak->link) {
-            printClosure((StgClosure*)weak);
+
+    case STOP_FRAME:
+        {
+            StgStopFrame* u = (StgStopFrame*)obj;
+            debugBelch("STOP_FRAME(");
+            printPtr((StgPtr)GET_INFO((StgClosure *)u));
+            debugBelch(")\n");
+            break;
         }
-    }
 
-    debugBelch("=========================\n");
-}
+    case ARR_WORDS:
+        {
+            StgWord i;
+            debugBelch("ARR_WORDS(\"");
+            for (i=0; i<arr_words_words((StgArrBytes *)obj); i++)
+              debugBelch("%" FMT_Word, (W_)((StgArrBytes *)obj)->payload[i]);
+            debugBelch("\")\n");
+            break;
+        }
 
-void printLargeAndPinnedObjects()
-{
-    debugBelch("====== PINNED OBJECTS ======\n");
+    case MUT_ARR_PTRS_CLEAN:
+        debugBelch("MUT_ARR_PTRS_CLEAN(size=%" FMT_Word ")\n", (W_)((StgMutArrPtrs *)obj)->ptrs);
+        break;
 
-    for (uint32_t cap_idx = 0; cap_idx < n_capabilities; ++cap_idx) {
-        Capability *cap = capabilities[cap_idx];
+    case MUT_ARR_PTRS_DIRTY:
+        debugBelch("MUT_ARR_PTRS_DIRTY(size=%" FMT_Word ")\n", (W_)((StgMutArrPtrs *)obj)->ptrs);
+        break;
 
-        debugBelch("Capability %d: Current pinned object block: %p\n",
-                   cap_idx, (void*)cap->pinned_object_block);
-        for (bdescr *bd = cap->pinned_object_blocks; bd; bd = bd->link) {
-            debugBelch("%p\n", (void*)bd);
-        }
-    }
+    case MUT_ARR_PTRS_FROZEN_CLEAN:
+        debugBelch("MUT_ARR_PTRS_FROZEN_CLEAN(size=%" FMT_Word ")\n", (W_)((StgMutArrPtrs *)obj)->ptrs);
+        break;
 
-    debugBelch("====== LARGE OBJECTS =======\n");
-    for (uint32_t gen_idx = 0; gen_idx <= oldest_gen->no; ++gen_idx) {
-        generation *gen = &generations[gen_idx];
-        debugBelch("Generation %d current large objects:\n", gen_idx);
-        for (bdescr *bd = gen->large_objects; bd; bd = bd->link) {
-            debugBelch("%p: ", (void*)bd);
-            printClosure((StgClosure*)bd->start);
-        }
+    case SMALL_MUT_ARR_PTRS_CLEAN:
+        debugBelch("SMALL_MUT_ARR_PTRS_CLEAN(size=%" FMT_Word ")\n",
+                   (W_)((StgSmallMutArrPtrs *)obj)->ptrs);
+        break;
 
-        debugBelch("Generation %d scavenged large objects:\n", gen_idx);
-        for (bdescr *bd = gen->scavenged_large_objects; bd; bd = bd->link) {
-            debugBelch("%p: ", (void*)bd);
-            printClosure((StgClosure*)bd->start);
-        }
-    }
+    case SMALL_MUT_ARR_PTRS_DIRTY:
+        debugBelch("SMALL_MUT_ARR_PTRS_DIRTY(size=%" FMT_Word ")\n",
+                   (W_)((StgSmallMutArrPtrs *)obj)->ptrs);
+        break;
 
-    debugBelch("============================\n");
-}
+    case SMALL_MUT_ARR_PTRS_FROZEN_CLEAN:
+        debugBelch("SMALL_MUT_ARR_PTRS_FROZEN_CLEAN(size=%" FMT_Word ")\n",
+                   (W_)((StgSmallMutArrPtrs *)obj)->ptrs);
+        break;
 
-/* --------------------------------------------------------------------------
- * Address printing code
- *
- * Uses symbol table in (unstripped executable)
- * ------------------------------------------------------------------------*/
+    case MVAR_CLEAN:
+    case MVAR_DIRTY:
+        {
+          StgMVar* mv = (StgMVar*)obj;
 
-/* --------------------------------------------------------------------------
- * Simple lookup table
- * address -> function name
- * ------------------------------------------------------------------------*/
+          debugBelch("MVAR(head=");
+          if ((StgClosure*)mv->head == &stg_END_TSO_QUEUE_closure) {
+              debugBelch("END_TSO_QUEUE");
+          } else {
+              debugBelch("%p", mv->head);
+          }
 
-static HashTable * add_to_fname_table = NULL;
+          debugBelch(", tail=");
+          if ((StgClosure*)mv->tail == &stg_END_TSO_QUEUE_closure) {
+              debugBelch("END_TSO_QUEUE");
+          } else {
+              debugBelch("%p", mv->tail);
+          }
 
-const char *lookupGHCName( void *addr )
-{
-    if (add_to_fname_table == NULL)
-        return NULL;
+          debugBelch(", value=");
+          if ((StgClosure*)mv->value == &stg_END_TSO_QUEUE_closure) {
+              debugBelch("END_TSO_QUEUE");
+          } else {
+              debugBelch("%p", mv->value);
+          }
+          debugBelch(")\n");
 
-    return lookupHashTable(add_to_fname_table, (StgWord)addr);
-}
+          break;
+        }
 
-/* --------------------------------------------------------------------------
- * Symbol table loading
- * ------------------------------------------------------------------------*/
+    case TVAR:
+        {
+          StgTVar* tv = (StgTVar*)obj;
+          debugBelch("TVAR(value=%p, wq=%p, num_updates=%" FMT_Word ")\n", tv->current_value, tv->first_watch_queue_entry, tv->num_updates);
+          break;
+        }
 
-/* Causing linking trouble on Win32 plats, so I'm
-   disabling this for now.
-*/
-#if defined(USING_LIBBFD)
-#    define PACKAGE 1
-#    define PACKAGE_VERSION 1
-/* Those PACKAGE_* defines are workarounds for bfd:
- *     https://sourceware.org/bugzilla/show_bug.cgi?id=14243
- * ghc's build system filter PACKAGE_* values out specifically to avoid clashes
- * with user's autoconf-based Cabal packages.
- * It's a shame <bfd.h> checks for unrelated fields instead of actually used
- * macros.
- */
-#    include <bfd.h>
+    case MUT_VAR_CLEAN:
+        {
+          StgMutVar* mv = (StgMutVar*)obj;
+          debugBelch("MUT_VAR_CLEAN(var=%p)\n", mv->var);
+          break;
+        }
 
-/* Fairly ad-hoc piece of code that seems to filter out a lot of
- * rubbish like the obj-splitting symbols
- */
+    case MUT_VAR_DIRTY:
+        {
+          StgMutVar* mv = (StgMutVar*)obj;
+          debugBelch("MUT_VAR_DIRTY(var=%p)\n", mv->var);
+          break;
+        }
 
-static bool isReal( flagword flags STG_UNUSED, const char *name )
-{
-#if 0
-    /* ToDo: make this work on BFD */
-    int tp = type & N_TYPE;
-    if (tp == N_TEXT || tp == N_DATA) {
-        return (name[0] == '_' && name[1] != '_');
-    } else {
-        return false;
-    }
-#else
-    if (*name == '\0'  ||
-        (name[0] == 'g' && name[1] == 'c' && name[2] == 'c') ||
-        (name[0] == 'c' && name[1] == 'c' && name[2] == '.')) {
-        return false;
-    }
-    return true;
-#endif
-}
+    case WEAK:
+            debugBelch("WEAK(");
+            debugBelch("key=%p value=%p finalizer=%p",
+                    (StgPtr)(((StgWeak*)obj)->key),
+                    (StgPtr)(((StgWeak*)obj)->value),
+                    (StgPtr)(((StgWeak*)obj)->finalizer));
+            debugBelch(")\n");
+            /* ToDo: chase 'link' ? */
+            break;
 
-extern void DEBUG_LoadSymbols( const char *name )
-{
-    bfd* abfd;
-    char **matching;
+    case TSO:
+      debugBelch("TSO(");
+      debugBelch("%lu (%p)",(unsigned long)(((StgTSO*)obj)->id), (StgTSO*)obj);
+      debugBelch(")\n");
+      break;
 
-    bfd_init();
-    abfd = bfd_openr(name, "default");
-    if (abfd == NULL) {
-        barf("can't open executable %s to get symbol table", name);
-    }
-    if (!bfd_check_format_matches (abfd, bfd_object, &matching)) {
-        barf("mismatch");
-    }
+    case STACK:
+      debugBelch("STACK\n");
+      break;
 
-    {
-        long storage_needed;
-        asymbol **symbol_table;
-        long number_of_symbols;
-        long num_real_syms = 0;
-        long i;
+#if 0
+      /* Symptomatic of a problem elsewhere, have it fall-through & fail */
+    case EVACUATED:
+      debugBelch("EVACUATED(");
+      printClosure((StgEvacuated*)obj->evacuee);
+      debugBelch(")\n");
+      break;
+#endif
 
-        storage_needed = bfd_get_symtab_upper_bound (abfd);
+    case COMPACT_NFDATA:
+        debugBelch("COMPACT_NFDATA(size=%" FMT_Word ")\n",
+                   (W_)((StgCompactNFData *)obj)->totalW * (W_)sizeof(W_));
+        break;
 
-        if (storage_needed < 0) {
-            barf("can't read symbol table");
-        }
-        symbol_table = (asymbol **) stgMallocBytes(storage_needed,"DEBUG_LoadSymbols");
+    case TREC_CHUNK:
+        debugBelch("TREC_CHUNK\n");
+        break;
 
-        number_of_symbols = bfd_canonicalize_symtab (abfd, symbol_table);
+    default:
+            //barf("printClosure %d",get_itbl(obj)->type);
+            debugBelch("*** printClosure: unknown type %d ****\n",
+                    (int)get_itbl(obj)->type );
+            barf("printClosure %d",get_itbl(obj)->type);
+            return;
+    }
+}
 
-        if (number_of_symbols < 0) {
-            barf("can't canonicalise symbol table");
+static void
+printSmallBitmap( StgPtr spBottom, StgPtr payload, StgWord bitmap,
+                    uint32_t size )
+{
+    uint32_t i;
+
+    for(i = 0; i < size; i++, bitmap >>= 1 ) {
+        debugBelch("   stk[%ld] (%p) = ", (long)(spBottom-(payload+i)), payload+i);
+        if ((bitmap & 1) == 0) {
+            printPtr((P_)payload[i]);
+            debugBelch(" -- ");
+            printObj((StgClosure*) payload[i]);
+        } else {
+            debugBelch("Word# %" FMT_Word "\n", (W_)payload[i]);
         }
+    }
+}
 
-        if (add_to_fname_table == NULL)
-            add_to_fname_table = allocHashTable();
+static void
+printLargeBitmap( StgPtr spBottom, StgPtr payload, StgLargeBitmap* large_bitmap,
+                    uint32_t size )
+{
+    StgWord bmp;
+    uint32_t i, j;
 
-        for( i = 0; i != number_of_symbols; ++i ) {
-            symbol_info info;
-            bfd_get_symbol_info(abfd,symbol_table[i],&info);
-            if (isReal(info.type, info.name)) {
-                insertHashTable(add_to_fname_table,
-                                info.value, (void*)info.name);
-                num_real_syms += 1;
+    i = 0;
+    for (bmp=0; i < size; bmp++) {
+        StgWord bitmap = large_bitmap->bitmap[bmp];
+        j = 0;
+        for(; i < size && j < BITS_IN(W_); j++, i++, bitmap >>= 1 ) {
+            debugBelch("   stk[%" FMT_Word "] (%p) = ", (W_)(spBottom-(payload+i)), payload+i);
+            if ((bitmap & 1) == 0) {
+                printPtr((P_)payload[i]);
+                debugBelch(" -- ");
+                printObj((StgClosure*) payload[i]);
+            } else {
+                debugBelch("Word# %" FMT_Word "\n", (W_)payload[i]);
             }
         }
-
-        IF_DEBUG(interpreter,
-                 debugBelch("Loaded %ld symbols. Of which %ld are real symbols\n",
-                         number_of_symbols, num_real_syms)
-                 );
-
-        stgFree(symbol_table);
     }
 }
 
-#else /* USING_LIBBFD */
-
-extern void DEBUG_LoadSymbols( const char *name STG_UNUSED )
+void
+printStackChunk( StgPtr sp, StgPtr spBottom )
 {
-  /* nothing, yet */
-}
+    const StgInfoTable *info;
 
-#endif /* USING_LIBBFD */
+    ASSERT(sp <= spBottom);
+    for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) {
 
-void findPtr(P_ p, int);                /* keep gcc -Wall happy */
+        info = get_itbl((StgClosure *)sp);
 
-int searched = 0;
+        switch (info->type) {
 
-static int
-findPtrBlocks (StgPtr p, bdescr *bd, StgPtr arr[], int arr_size, int i)
-{
-    StgPtr q, r, end;
-    for (; bd; bd = bd->link) {
-        searched++;
-        for (q = bd->start; q < bd->free; q++) {
-            if (UNTAG_CONST_CLOSURE((StgClosure*)*q) == (const StgClosure *)p) {
-                if (i < arr_size) {
-                    for (r = bd->start; r < bd->free; r = end) {
-                        // skip over zeroed-out slop
-                        while (*r == 0) r++;
-                        if (!LOOKS_LIKE_CLOSURE_PTR(r)) {
-                            debugBelch("%p found at %p, no closure at %p\n",
-                                       p, q, r);
-                            break;
-                        }
-                        end = r + closure_sizeW((StgClosure*)r);
-                        if (q < end) {
-                            debugBelch("%p = ", r);
-                            printClosure((StgClosure *)r);
-                            arr[i++] = r;
-                            break;
-                        }
-                    }
-                    if (r >= bd->free) {
-                        debugBelch("%p found at %p, closure?", p, q);
-                    }
-                } else {
-                    return i;
-                }
+        case UPDATE_FRAME:
+        case CATCH_FRAME:
+        case UNDERFLOW_FRAME:
+        case STOP_FRAME:
+            printClosure((StgClosure*)sp);
+            continue;
+
+        case RET_SMALL: {
+            StgWord c = *sp;
+            if (c == (StgWord)&stg_ctoi_R1p_info) {
+                debugBelch("tstg_ctoi_ret_R1p_info\n" );
+            } else if (c == (StgWord)&stg_ctoi_R1n_info) {
+                debugBelch("stg_ctoi_ret_R1n_info\n" );
+            } else if (c == (StgWord)&stg_ctoi_F1_info) {
+                debugBelch("stg_ctoi_ret_F1_info\n" );
+            } else if (c == (StgWord)&stg_ctoi_D1_info) {
+                debugBelch("stg_ctoi_ret_D1_info\n" );
+            } else if (c == (StgWord)&stg_ctoi_V_info) {
+                debugBelch("stg_ctoi_ret_V_info\n" );
+            } else if (c == (StgWord)&stg_ap_v_info) {
+                debugBelch("stg_ap_v_info\n" );
+            } else if (c == (StgWord)&stg_ap_f_info) {
+                debugBelch("stg_ap_f_info\n" );
+            } else if (c == (StgWord)&stg_ap_d_info) {
+                debugBelch("stg_ap_d_info\n" );
+            } else if (c == (StgWord)&stg_ap_l_info) {
+                debugBelch("stg_ap_l_info\n" );
+            } else if (c == (StgWord)&stg_ap_n_info) {
+                debugBelch("stg_ap_n_info\n" );
+            } else if (c == (StgWord)&stg_ap_p_info) {
+                debugBelch("stg_ap_p_info\n" );
+            } else if (c == (StgWord)&stg_ap_pp_info) {
+                debugBelch("stg_ap_pp_info\n" );
+            } else if (c == (StgWord)&stg_ap_ppp_info) {
+                debugBelch("stg_ap_ppp_info\n" );
+            } else if (c == (StgWord)&stg_ap_pppp_info) {
+                debugBelch("stg_ap_pppp_info\n" );
+            } else if (c == (StgWord)&stg_ap_ppppp_info) {
+                debugBelch("stg_ap_ppppp_info\n" );
+            } else if (c == (StgWord)&stg_ap_pppppp_info) {
+                debugBelch("stg_ap_pppppp_info\n" );
+            } else if (c == (StgWord)&stg_ret_v_info) {
+                debugBelch("stg_ret_v_info\n" );
+            } else if (c == (StgWord)&stg_ret_p_info) {
+                debugBelch("stg_ret_p_info\n" );
+            } else if (c == (StgWord)&stg_ret_n_info) {
+                debugBelch("stg_ret_n_info\n" );
+            } else if (c == (StgWord)&stg_ret_f_info) {
+                debugBelch("stg_ret_f_info\n" );
+            } else if (c == (StgWord)&stg_ret_d_info) {
+                debugBelch("stg_ret_d_info\n" );
+            } else if (c == (StgWord)&stg_ret_l_info) {
+                debugBelch("stg_ret_l_info\n" );
+#if defined(PROFILING)
+            } else if (c == (StgWord)&stg_restore_cccs_info) {
+                debugBelch("stg_restore_cccs_info\n" );
+                fprintCCS(stderr, (CostCentreStack*)sp[1]);
+                debugBelch("\n" );
+                continue;
+            } else if (c == (StgWord)&stg_restore_cccs_eval_info) {
+                debugBelch("stg_restore_cccs_eval_info\n" );
+                fprintCCS(stderr, (CostCentreStack*)sp[1]);
+                debugBelch("\n" );
+                continue;
+#endif
+            } else {
+                debugBelch("RET_SMALL (%p)\n", info);
             }
+            StgWord bitmap = info->layout.bitmap;
+            printSmallBitmap(spBottom, sp+1,
+                             BITMAP_BITS(bitmap), BITMAP_SIZE(bitmap));
+            continue;
         }
-    }
-    return i;
-}
 
-void
-findPtr(P_ p, int follow)
-{
-  uint32_t g, n;
-  bdescr *bd;
-  const int arr_size = 1024;
-  StgPtr arr[arr_size];
-  int i = 0;
-  searched = 0;
+        case RET_BCO: {
+            StgBCO *bco;
 
-#if 0
-  // We can't search the nursery, because we don't know which blocks contain
-  // valid data, because the bd->free pointers in the nursery are only reset
-  // just before a block is used.
-  for (n = 0; n < n_capabilities; n++) {
-      bd = nurseries[i].blocks;
-      i = findPtrBlocks(p,bd,arr,arr_size,i);
-      if (i >= arr_size) return;
-  }
-#endif
+            bco = ((StgBCO *)sp[1]);
 
-  for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
-      bd = generations[g].blocks;
-      i = findPtrBlocks(p,bd,arr,arr_size,i);
-      bd = generations[g].large_objects;
-      i = findPtrBlocks(p,bd,arr,arr_size,i);
-      if (i >= arr_size) return;
-      for (n = 0; n < n_capabilities; n++) {
-          i = findPtrBlocks(p, gc_threads[n]->gens[g].part_list,
-                            arr, arr_size, i);
-          i = findPtrBlocks(p, gc_threads[n]->gens[g].todo_bd,
-                            arr, arr_size, i);
-      }
-      if (i >= arr_size) return;
-  }
-  if (follow && i == 1) {
-      debugBelch("-->\n");
-      findPtr(arr[0], 1);
-  }
-}
+            debugBelch("RET_BCO (%p)\n", sp);
+            printLargeBitmap(spBottom, sp+2,
+                             BCO_BITMAP(bco), BCO_BITMAP_SIZE(bco));
+            continue;
+        }
 
-const char *what_next_strs[] = {
-  [0]               = "(unknown)",
-  [ThreadRunGHC]    = "ThreadRunGHC",
-  [ThreadInterpret] = "ThreadInterpret",
-  [ThreadKilled]    = "ThreadKilled",
-  [ThreadComplete]  = "ThreadComplete"
-};
+        case RET_BIG:
+            debugBelch("RET_BIG (%p)\n", sp);
+            StgLargeBitmap* bitmap = GET_LARGE_BITMAP(info);
+            printLargeBitmap(spBottom,
+                            (StgPtr)((StgClosure *) sp)->payload,
+                            bitmap,
+                            bitmap->size);
+            continue;
+        case RET_FUN:
+        {
+            const StgFunInfoTable *fun_info;
+            StgRetFun *ret_fun;
 
-#else /* DEBUG */
-void printPtr( StgPtr p )
-{
-    debugBelch("ptr 0x%p (enable -DDEBUG for more info) " , p );
+            ret_fun = (StgRetFun *)sp;
+            fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
+            debugBelch("RET_FUN (%p) (type=%d)\n", ret_fun->fun, (int)fun_info->f.fun_type);
+            switch (fun_info->f.fun_type) {
+            case ARG_GEN:
+                printSmallBitmap(spBottom, sp+2,
+                                 BITMAP_BITS(fun_info->f.b.bitmap),
+                                 BITMAP_SIZE(fun_info->f.b.bitmap));
+                break;
+            case ARG_GEN_BIG:
+                printLargeBitmap(spBottom, sp+2,
+                                 GET_FUN_LARGE_BITMAP(fun_info),
+                                 GET_FUN_LARGE_BITMAP(fun_info)->size);
+                break;
+            default:
+                printSmallBitmap(spBottom, sp+2,
+                                 BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]),
+                                 BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]));
+                break;
+            }
+            continue;
+        }
+
+        default:
+            debugBelch("unknown object %d\n", (int)info->type);
+            barf("printStackChunk");
+        }
+    }
 }
 
-void printObj( StgClosure *obj )
+void printStack( StgStack *stack )
 {
-    debugBelch("obj 0x%p (enable -DDEBUG for more info) " , obj );
+    printStackChunk( stack->sp, stack->stack + stack->stack_size );
 }
 
 
-#endif /* DEBUG */
-
 /* -----------------------------------------------------------------------------
    Closure types
 


=====================================
rts/Printer.h
=====================================
@@ -20,9 +20,10 @@ const char  *      info_type       ( const StgClosure *closure );
 const char  *      info_type_by_ip ( const StgInfoTable *ip );
 const char  *      info_update_frame ( const StgClosure *closure );
 
-#if defined(DEBUG)
 extern void        printClosure    ( const StgClosure *obj );
 extern void        printStackChunk ( StgPtr sp, StgPtr spLim );
+
+#if defined(DEBUG)
 extern void        printTSO        ( StgTSO *tso );
 extern void        printMutableList( bdescr *bd );
 extern void        printStaticObjects ( StgClosure *obj );


=====================================
rts/RtsSymbols.c
=====================================
@@ -13,6 +13,7 @@
 #include "TopHandler.h"
 #include "HsFFI.h"
 #include "CloneStack.h"
+#include "rts/PrinterAPI.h"
 
 #include "sm/Storage.h"
 #include "sm/NonMovingMark.h"
@@ -1001,6 +1002,7 @@
       SymI_HasProto(_assertFail)                                        \
       SymI_HasProto(keepCAFs)                                           \
       SymI_HasProto(sendCloneStackMessage)                              \
+      SymI_HasProto(printStack)                                         \
       RTS_USER_SIGNALS_SYMBOLS                                          \
       RTS_INTCHAR_SYMBOLS
 



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4e2fac38419a9f76ba1aadd081c58009e8a7ca9a

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4e2fac38419a9f76ba1aadd081c58009e8a7ca9a
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20201102/85e67b7e/attachment-0001.html>


More information about the ghc-commits mailing list