[Git][ghc/ghc][wip/stack_cloning] 3 commits: Introduce snapshotting of thread's own stack

Ben Gamari gitlab at gitlab.haskell.org
Sat Oct 31 18:28:09 UTC 2020



Ben Gamari pushed to branch wip/stack_cloning at Glasgow Haskell Compiler / GHC


Commits:
f2402e6d by Sven Tennie at 2020-10-31T14:27:34-04:00
Introduce snapshotting of thread's own stack

Introduce `StackSnapshot#` type and the `cloneMyStack#` primop, allowing
the user to reify the state of the calling thread's stack for later
inspection.

The stack snapshot is offline/cold, i.e. it isn't evaluated any further.

For technical details, please see note [Stack Cloning].

- - - - -
415ca6c6 by Sven Tennie at 2020-10-31T14:27:38-04:00
Introduce cloning of other threads' stacks

Introduce `cloneThreadStack` function, allowing threads to request
snapshots of other threads' stacks.

For technical details, please see note [Stack Cloning].

- - - - -
276e19f7 by Sven Tennie at 2020-10-31T14:27:38-04:00
Introduce printing support for StackSnapshot#'s

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

- - - - -


26 changed files:

- compiler/GHC/Builtin/Names.hs
- compiler/GHC/Builtin/Types/Prim.hs
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/StgToCmm/Prim.hs
- + includes/rts/PrinterAPI.h
- includes/rts/storage/Closures.h
- includes/stg/MiscClosures.h
- + libraries/base/GHC/Stack/CloneStack.hs
- libraries/base/base.cabal
- + rts/CloneStack.c
- + rts/CloneStack.h
- rts/Disassembler.c
- rts/Disassembler.h
- rts/Messages.c
- rts/PrimOps.cmm
- rts/Printer.c
- rts/Printer.h
- rts/RtsSymbols.c
- rts/StgMiscClosures.cmm
- rts/package.conf.in
- rts/rts.cabal.in
- testsuite/tests/rts/all.T
- + testsuite/tests/rts/cloneMyStack.hs
- + testsuite/tests/rts/cloneStackLib.c
- + testsuite/tests/rts/cloneThreadStack.hs
- utils/genprimopcode/Main.hs


Changes:

=====================================
compiler/GHC/Builtin/Names.hs
=====================================
@@ -1770,7 +1770,7 @@ statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey,
     typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey,
     funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey,
     eqReprPrimTyConKey, eqPhantPrimTyConKey,
-    compactPrimTyConKey :: Unique
+    compactPrimTyConKey, stackSnapshotPrimTyConKey :: Unique
 statePrimTyConKey                       = mkPreludeTyConUnique 50
 stableNamePrimTyConKey                  = mkPreludeTyConUnique 51
 stableNameTyConKey                      = mkPreludeTyConUnique 52
@@ -1801,6 +1801,7 @@ ptrTyConKey                             = mkPreludeTyConUnique 77
 funPtrTyConKey                          = mkPreludeTyConUnique 78
 tVarPrimTyConKey                        = mkPreludeTyConUnique 79
 compactPrimTyConKey                     = mkPreludeTyConUnique 80
+stackSnapshotPrimTyConKey               = mkPreludeTyConUnique 81
 
 eitherTyConKey :: Unique
 eitherTyConKey                          = mkPreludeTyConUnique 84


=====================================
compiler/GHC/Builtin/Types/Prim.hs
=====================================
@@ -69,6 +69,7 @@ module GHC.Builtin.Types.Prim(
         bcoPrimTyCon,                   bcoPrimTy,
         weakPrimTyCon,                  mkWeakPrimTy,
         threadIdPrimTyCon,              threadIdPrimTy,
+        stackSnapshotPrimTyCon,         stackSnapshotPrimTy,
 
         int8PrimTyCon,          int8PrimTy, int8PrimTyConName,
         word8PrimTyCon,         word8PrimTy, word8PrimTyConName,
@@ -189,6 +190,7 @@ exposedPrimTyCons
     , word16PrimTyCon
     , word32PrimTyCon
     , word64PrimTyCon
+    , stackSnapshotPrimTyCon
 
     , tYPETyCon
     , funTyCon
@@ -211,7 +213,7 @@ mkBuiltInPrimTc fs unique tycon
                   BuiltInSyntax
 
 
-charPrimTyConName, intPrimTyConName, int8PrimTyConName, int16PrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word8PrimTyConName, word16PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, ioPortPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName :: Name
+charPrimTyConName, intPrimTyConName, int8PrimTyConName, int16PrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word8PrimTyConName, word16PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, ioPortPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName, stackSnapshotPrimTyConName :: Name
 charPrimTyConName             = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon
 intPrimTyConName              = mkPrimTc (fsLit "Int#") intPrimTyConKey  intPrimTyCon
 int8PrimTyConName             = mkPrimTc (fsLit "Int8#") int8PrimTyConKey int8PrimTyCon
@@ -247,6 +249,7 @@ tVarPrimTyConName             = mkPrimTc (fsLit "TVar#") tVarPrimTyConKey tVarPr
 stablePtrPrimTyConName        = mkPrimTc (fsLit "StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon
 stableNamePrimTyConName       = mkPrimTc (fsLit "StableName#") stableNamePrimTyConKey stableNamePrimTyCon
 compactPrimTyConName          = mkPrimTc (fsLit "Compact#") compactPrimTyConKey compactPrimTyCon
+stackSnapshotPrimTyConName    = mkPrimTc (fsLit "StackSnapshot#") stackSnapshotPrimTyConKey stackSnapshotPrimTyCon
 bcoPrimTyConName              = mkPrimTc (fsLit "BCO") bcoPrimTyConKey bcoPrimTyCon
 weakPrimTyConName             = mkPrimTc (fsLit "Weak#") weakPrimTyConKey weakPrimTyCon
 threadIdPrimTyConName         = mkPrimTc (fsLit "ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon
@@ -1087,6 +1090,21 @@ compactPrimTyCon = pcPrimTyCon0 compactPrimTyConName UnliftedRep
 compactPrimTy :: Type
 compactPrimTy = mkTyConTy compactPrimTyCon
 
+{-
+************************************************************************
+*                                                                      *
+   The @StackSnapshot#@ type
+*                                                                      *
+************************************************************************
+-}
+
+stackSnapshotPrimTyCon :: TyCon
+stackSnapshotPrimTyCon = pcPrimTyCon0 stackSnapshotPrimTyConName UnliftedRep
+
+stackSnapshotPrimTy :: Type
+stackSnapshotPrimTy = mkTyConTy stackSnapshotPrimTyCon
+
+
 {-
 ************************************************************************
 *                                                                      *


=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -3151,6 +3151,16 @@ primop  SetThreadAllocationCounter "setThreadAllocationCounter#" GenPrimOp
    has_side_effects = True
    out_of_line      = True
 
+primtype StackSnapshot#
+
+primop  CloneMyStack "cloneMyStack#" GenPrimOp
+   State# RealWorld -> (# State# RealWorld, StackSnapshot# #)
+   { Clones the stack of the current Haskell thread. }
+   with
+   has_side_effects = True
+   out_of_line      = True
+
+
 ------------------------------------------------------------------------
 section "Safe coercions"
 ------------------------------------------------------------------------


=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -1521,6 +1521,7 @@ emitPrimOp dflags primop = case primop of
   TraceEventBinaryOp -> alwaysExternal
   TraceMarkerOp -> alwaysExternal
   SetThreadAllocationCounter -> alwaysExternal
+  CloneMyStack -> alwaysExternal
 
  where
   profile = targetProfile dflags


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


=====================================
includes/rts/storage/Closures.h
=====================================
@@ -431,6 +431,14 @@ typedef struct MessageBlackHole_ {
     StgClosure *bh;
 } MessageBlackHole;
 
+typedef struct MessageCloneStack_ {
+    StgHeader header;
+    Message   *link;
+    StgMVar   *result;
+    StgTSO    *tso;
+} MessageCloneStack;
+
+
 /* ----------------------------------------------------------------------------
    Compact Regions
    ------------------------------------------------------------------------- */


=====================================
includes/stg/MiscClosures.h
=====================================
@@ -129,6 +129,7 @@ RTS_ENTRY(stg_STM_AWOKEN);
 RTS_ENTRY(stg_MSG_TRY_WAKEUP);
 RTS_ENTRY(stg_MSG_THROWTO);
 RTS_ENTRY(stg_MSG_BLACKHOLE);
+RTS_ENTRY(stg_MSG_CLONE_STACK);
 RTS_ENTRY(stg_MSG_NULL);
 RTS_ENTRY(stg_MVAR_TSO_QUEUE);
 RTS_ENTRY(stg_catch);
@@ -492,6 +493,7 @@ RTS_FUN_DECL(stg_traceBinaryEventzh);
 RTS_FUN_DECL(stg_traceMarkerzh);
 RTS_FUN_DECL(stg_getThreadAllocationCounterzh);
 RTS_FUN_DECL(stg_setThreadAllocationCounterzh);
+RTS_FUN_DECL(stg_cloneMyStackzh);
 
 
 /* Other misc stuff */


=====================================
libraries/base/GHC/Stack/CloneStack.hs
=====================================
@@ -0,0 +1,72 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE MagicHash        #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnliftedFFITypes#-}
+
+-- |
+-- This module exposes an interface for capturing the state of a thread's
+-- execution stack for diagnostics purposes.
+--
+-- @since 2.16.0.0
+module GHC.Stack.CloneStack (
+  StackSnapshot(..),
+  cloneMyStack,
+  cloneThreadStack,
+  printStack
+  ) where
+
+import GHC.Prim (StackSnapshot#, cloneMyStack#, ThreadId#)
+import Control.Concurrent.MVar
+import GHC.Conc.Sync
+import GHC.Stable
+import GHC.IO (IO(..))
+
+-- | A frozen snapshot of the state of an execution stack.
+--
+-- @since 2.16.0.0
+data StackSnapshot = StackSnapshot !StackSnapshot#
+
+{-
+Note [Stack Cloning]
+~~~~~~~~~~~~~~~~~~~~
+"Cloning" a stack means that it's StgStack closure is copied including the
+stack memory (stack[]). The stack pointer (sp) of the clone is adjusted to be
+valid.
+The clone is "offline"/"cold", i.e. it won't be evaluated any further. This is
+useful for further analyses like stack unwinding or traversal.
+
+There are two different ways to clone a stack:
+1. By the corresponding thread via a primop call (cloneMyStack#).
+2. By sending a RTS message (Messages.c) with a MVar to the corresponding
+   thread and receiving the stack by taking it out of this MVar.
+-}
+
+-- | Clone the stack of the executing thread
+--
+-- @since 2.16.0.0
+cloneMyStack :: IO StackSnapshot
+cloneMyStack = IO $ \s ->
+   case (cloneMyStack# s) of (# s1, stack #) -> (# s1, StackSnapshot stack #)
+
+foreign import ccall "sendCloneStackMessage" sendCloneStackMessage :: ThreadId# -> StablePtr PrimMVar -> IO ()
+
+-- | Clone the stack of a thread identified by its 'ThreadId'
+--
+-- @since 2.16.0.0
+cloneThreadStack :: ThreadId -> IO StackSnapshot
+cloneThreadStack (ThreadId tid#) = do
+  resultVar <- newEmptyMVar @StackSnapshot
+  ptr <- newStablePtrPrimMVar resultVar
+  -- Use the RTS's "message" mechanism to request that
+  -- the thread captures its stack, saving the result
+  -- into resultVar.
+  sendCloneStackMessage tid# ptr
+  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


=====================================
libraries/base/base.cabal
=====================================
@@ -264,6 +264,7 @@ Library
         GHC.ResponseFile
         GHC.RTS.Flags
         GHC.ST
+        GHC.Stack.CloneStack
         GHC.StaticPtr
         GHC.STRef
         GHC.Show


=====================================
rts/CloneStack.c
=====================================
@@ -0,0 +1,84 @@
+/* ---------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2001-2021
+ *
+ * Stack snapshotting.
+ */
+
+#include <string.h>
+
+#include "Rts.h"
+#include "rts/Messages.h"
+#include "Messages.h"
+#include "rts/storage/TSO.h"
+#include "stg/Types.h"
+#include "CloneStack.h"
+#include "StablePtr.h"
+#include "Threads.h"
+
+#if defined(DEBUG)
+#include "sm/Sanity.h"
+#endif
+
+StgStack* cloneStack(Capability* capability, const StgStack* stack){
+  StgWord spOffset = stack->sp - stack->stack;
+  StgWord closureSizeBytes = sizeof(StgStack) + (stack->stack_size * sizeof(StgWord));
+
+  StgStack* newStackClosure = (StgStack*) allocate(capability, ROUNDUP_BYTES_TO_WDS(closureSizeBytes));
+
+  memcpy(newStackClosure, stack, closureSizeBytes);
+
+  newStackClosure->sp = newStackClosure->stack + spOffset;
+  // The new stack is not on the mutable list; clear the dirty flag such that
+  // we don't claim that it is.
+  newStackClosure->dirty = 0;
+
+#if defined(DEBUG)
+  checkClosure((StgClosure*) newStackClosure);
+#endif
+
+  return newStackClosure;
+}
+
+#if defined(THREADED_RTS)
+
+// ThreadId# in Haskell is a StgTSO* in RTS.
+void sendCloneStackMessage(StgTSO *tso, HsStablePtr mvar) {
+  Capability *srcCapability = rts_unsafeGetMyCapability();
+
+  MessageCloneStack *msg;
+  msg = (MessageCloneStack *)allocate(srcCapability, sizeofW(MessageCloneStack));
+  msg->tso = tso;
+  msg->result = (StgMVar*)deRefStablePtr(mvar);
+  freeStablePtr(mvar);
+  SET_HDR(msg, &stg_MSG_CLONE_STACK_info, CCS_SYSTEM);
+  // Ensure that writes constructing Message are committed before sending.
+  write_barrier();
+
+  sendMessage(srcCapability, tso->cap, (Message *)msg);
+}
+
+void handleCloneStackMessage(MessageCloneStack *msg){
+  StgStack* newStackClosure = cloneStack(msg->tso->cap, msg->tso->stackobj);
+
+  // Lift StackSnapshot# to StackSnapshot by applying it's constructor.
+  // This is necessary because performTryPutMVar() puts the closure onto the
+  // stack for evaluation and stacks can not be evaluated (entered).
+  HaskellObj result = rts_apply(msg->tso->cap, StackSnapshot_constructor_closure, (HaskellObj) newStackClosure);
+
+  bool putMVarWasSuccessful = performTryPutMVar(msg->tso->cap, msg->result, result);
+
+  if(!putMVarWasSuccessful) {
+    barf("Can't put stack cloning result into MVar.");
+  }
+}
+
+#else // !defined(THREADED_RTS)
+
+GNU_ATTRIBUTE(__noreturn__)
+void  sendCloneStackMessage(StgTSO *tso STG_UNUSED, HsStablePtr mvar STG_UNUSED) {
+  barf("Sending CloneStackMessages is only available in threaded RTS!");
+}
+
+#endif // end !defined(THREADED_RTS)
+


=====================================
rts/CloneStack.h
=====================================
@@ -0,0 +1,23 @@
+/* ---------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2001-2021
+ *
+ * Stack snapshotting.
+ */
+
+#pragma once
+
+extern StgClosure DLL_IMPORT_DATA_VARNAME(base_GHCziStackziCloneStack_StackSnapshot_closure);
+#define StackSnapshot_constructor_closure DLL_IMPORT_DATA_REF(base_GHCziStackziCloneStack_StackSnapshot_closure)
+
+StgStack* cloneStack(Capability* capability, StgStack* stack);
+
+#include "BeginPrivate.h"
+
+#if defined(THREADED_RTS)
+void handleCloneStackMessage(MessageCloneStack *msg);
+#endif
+
+void sendCloneStackMessage(StgTSO *tso, HsStablePtr mvar);
+
+#include "EndPrivate.h"


=====================================
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/Messages.c
=====================================
@@ -14,6 +14,7 @@
 #include "Threads.h"
 #include "RaiseAsync.h"
 #include "sm/Storage.h"
+#include "CloneStack.h"
 
 /* ----------------------------------------------------------------------------
    Send a message to another Capability
@@ -32,7 +33,8 @@ void sendMessage(Capability *from_cap, Capability *to_cap, Message *msg)
             i != &stg_MSG_BLACKHOLE_info &&
             i != &stg_MSG_TRY_WAKEUP_info &&
             i != &stg_IND_info && // can happen if a MSG_BLACKHOLE is revoked
-            i != &stg_WHITEHOLE_info) {
+            i != &stg_WHITEHOLE_info &&
+            i != &stg_MSG_CLONE_STACK_info) {
             barf("sendMessage: %p", i);
         }
     }
@@ -131,6 +133,10 @@ loop:
 #endif
         goto loop;
     }
+    else if(i == &stg_MSG_CLONE_STACK_info){
+        MessageCloneStack *cloneStackMessage = (MessageCloneStack*) m;
+        handleCloneStackMessage(cloneStackMessage);
+    }
     else
     {
         barf("executeMessage: %p", i);


=====================================
rts/PrimOps.cmm
=====================================
@@ -2840,3 +2840,14 @@ stg_setThreadAllocationCounterzh ( I64 counter )
     StgTSO_alloc_limit(CurrentTSO) = counter + TO_I64(offset);
     return ();
 }
+
+stg_cloneMyStackzh () {
+    W_ stgStack;
+    W_ clonedStack;
+
+    stgStack = StgTSO_stackobj(CurrentTSO);
+
+    ("ptr" clonedStack) = ccall cloneStack(MyCapability() "ptr", stgStack "ptr");
+
+    return (clonedStack);
+}


=====================================
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
=====================================
@@ -12,6 +12,8 @@
 #include "Rts.h"
 #include "TopHandler.h"
 #include "HsFFI.h"
+#include "CloneStack.h"
+#include "rts/PrinterAPI.h"
 
 #include "sm/Storage.h"
 #include "sm/NonMovingMark.h"
@@ -979,6 +981,7 @@
       SymI_HasProto(stg_traceBinaryEventzh)                             \
       SymI_HasProto(stg_getThreadAllocationCounterzh)                   \
       SymI_HasProto(stg_setThreadAllocationCounterzh)                   \
+      SymI_HasProto(stg_cloneMyStackzh)                                 \
       SymI_HasProto(getMonotonicNSec)                                   \
       SymI_HasProto(lockFile)                                           \
       SymI_HasProto(unlockFile)                                         \
@@ -998,6 +1001,8 @@
       SymI_HasProto(cas)                                                \
       SymI_HasProto(_assertFail)                                        \
       SymI_HasProto(keepCAFs)                                           \
+      SymI_HasProto(sendCloneStackMessage)                              \
+      SymI_HasProto(printStack)                                         \
       RTS_USER_SIGNALS_SYMBOLS                                          \
       RTS_INTCHAR_SYMBOLS
 


=====================================
rts/StgMiscClosures.cmm
=====================================
@@ -573,6 +573,9 @@ INFO_TABLE_CONSTR(stg_MSG_BLACKHOLE,3,0,0,PRIM,"MSG_BLACKHOLE","MSG_BLACKHOLE")
 INFO_TABLE_CONSTR(stg_MSG_NULL,1,0,0,PRIM,"MSG_NULL","MSG_NULL")
 { foreign "C" barf("MSG_NULL object (%p) entered!", R1) never returns; }
 
+INFO_TABLE_CONSTR(stg_MSG_CLONE_STACK,3,0,0,PRIM,"MSG_CLONE_STACK","MSG_CLONE_STACK")
+{ foreign "C" barf("stg_MSG_CLONE_STACK object (%p) entered!", R1) never returns; }
+
 /* ----------------------------------------------------------------------------
    END_TSO_QUEUE
 


=====================================
rts/package.conf.in
=====================================
@@ -194,6 +194,7 @@ ld-options:
            * so we need to force it to be included in the binary. */
          , "-Wl,-u,_findPtr"
 #endif
+         , "-Wl,-u,_base_GHCziStackziCloneStack_StackSnapshot_closure"
 #else
            "-Wl,-u,base_GHCziTopHandler_runIO_closure"
          , "-Wl,-u,base_GHCziTopHandler_runNonIO_closure"
@@ -308,6 +309,7 @@ ld-options:
            * so we need to force it to be included in the binary. */
          , "-Wl,-u,findPtr"
 #endif
+         , "-Wl,-u,base_GHCziStackziCloneStack_StackSnapshot_closure"
 #endif
 
 /*  Pick up static libraries in preference over dynamic if in earlier search


=====================================
rts/rts.cabal.in
=====================================
@@ -286,6 +286,7 @@ library
          "-Wl,-u,_hs_atomicwrite8"
          "-Wl,-u,_hs_atomicwrite16"
          "-Wl,-u,_hs_atomicwrite32"
+         "-Wl,-u,_base_GHCziStackziCloneStack_StackSnapshot_closure"
 
       if flag(find-ptr)
         -- This symbol is useful in gdb, but not referred to anywhere,
@@ -367,6 +368,7 @@ library
          "-Wl,-u,hs_atomicwrite8"
          "-Wl,-u,hs_atomicwrite16"
          "-Wl,-u,hs_atomicwrite32"
+         "-Wl,-u,base_GHCziStackziCloneStack_StackSnapshot_closure"
 
       if flag(find-ptr)
         -- This symbol is useful in gdb, but not referred to anywhere,
@@ -410,6 +412,7 @@ library
                Arena.c
                Capability.c
                CheckUnload.c
+               CloneStack.c
                ClosureFlags.c
                Disassembler.c
                FileLock.c


=====================================
testsuite/tests/rts/all.T
=====================================
@@ -418,3 +418,7 @@ test('T17088',
      compile_and_run, ['-rtsopts -O2'])
 
 test('T15427', normal, compile_and_run, [''])
+
+test('cloneMyStack', [extra_files(['cloneStackLib.c'])], compile_and_run, ['cloneStackLib.c'])
+
+test('cloneThreadStack', [only_ways(['threaded1']), extra_ways(['threaded1']), extra_files(['cloneStackLib.c'])], compile_and_run, ['cloneStackLib.c -threaded'])


=====================================
testsuite/tests/rts/cloneMyStack.hs
=====================================
@@ -0,0 +1,20 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+
+import GHC.Prim (StackSnapshot#)
+import GHC.Stack.CloneStack
+import Foreign
+import Foreign.C.Types (CUInt)
+
+foreign import ccall "expectClosureTypes" expectClosureTypes:: StackSnapshot# -> Ptr CUInt -> Int -> IO ()
+
+main :: IO ()
+main = do
+    stackSnapshot <- cloneMyStack
+
+    let (StackSnapshot stack) = stackSnapshot
+    let expectedClosureTypes = [34 -- CATCH_FRAME
+                               ,36 -- STOP_FRAME
+                               ]
+    withArray expectedClosureTypes (\ptr -> expectClosureTypes stack ptr (length expectedClosureTypes))


=====================================
testsuite/tests/rts/cloneStackLib.c
=====================================
@@ -0,0 +1,53 @@
+#include "Rts.h"
+#include "RtsAPI.h"
+#include "rts/Messages.h"
+
+
+void expectStacksToBeEqual(StgStack *clonedStack, StgTSO *tso) {
+    StgStack *liveStack = tso->stackobj;
+
+    if(liveStack->header.info != clonedStack->header.info){
+        barf("info table pointer not equal! Expected same pointer address, but got %p and %p", liveStack->header.info, clonedStack->header.info);
+    }
+
+    StgInfoTable *info = INFO_PTR_TO_STRUCT(liveStack->header.info);
+
+    if (info->type != STACK) {
+        barf("Expected a closure of type STACK!");
+    }
+
+    if(liveStack->stack_size != clonedStack->stack_size){
+        barf("Expected same stack_size!");
+    }
+
+    if(liveStack->dirty != clonedStack->dirty){
+        barf("Expected same dirty flags!");
+    }
+
+    if(liveStack->marking != clonedStack->marking){
+        barf("Expected same marking flags!");
+    }
+
+    for(StgWord i = liveStack->stack_size - 1; (liveStack->stack + i) >= liveStack->sp; i--){
+        if(liveStack->stack[i] != clonedStack->stack[i]){
+            barf("Expected stack word %lu to be equal on both stacks.", i);
+        }
+    }
+}
+
+void expectClosureTypes(StgStack *stack, unsigned int types[], size_t typesSize){
+    StgPtr sp = stack->sp;
+    StgPtr spBottom = stack->stack + stack->stack_size;
+
+    for (StgWord i = 0; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp), i++) {
+        const StgInfoTable *info = get_itbl((StgClosure *)sp);
+
+        if(i >= typesSize) {
+            barf("Stack size exceeds expectation!");
+        }
+
+        if(info->type != types[i]) {
+            barf("Wrong closure type on stack! Expected %u but got %u", types[i], info->type);
+        }
+    }
+}


=====================================
testsuite/tests/rts/cloneThreadStack.hs
=====================================
@@ -0,0 +1,46 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+
+import GHC.Prim (StackSnapshot#, ThreadId#)
+import GHC.Conc.Sync (ThreadId(..))
+import GHC.Stack.CloneStack
+import Control.Concurrent
+import GHC.Conc
+
+foreign import ccall "expectStacksToBeEqual" expectStacksToBeEqual:: StackSnapshot# -> ThreadId# -> IO ()
+
+main :: IO ()
+main = do
+    mVarToBeBlockedOn <- newEmptyMVar
+    threadId <- forkIO $ immediatelyBlocking mVarToBeBlockedOn
+
+    waitUntilBlocked threadId
+
+    stackSnapshot <- cloneThreadStack threadId
+
+    let (StackSnapshot stack) = stackSnapshot
+    let (ThreadId tid#) = threadId
+    expectStacksToBeEqual stack tid#
+
+immediatelyBlocking :: MVar Int -> IO ()
+immediatelyBlocking mVarToBeBlockedOn = do
+    takeMVar mVarToBeBlockedOn
+    return ()
+
+waitUntilBlocked :: ThreadId -> IO ()
+waitUntilBlocked tid = do
+    blocked <- isBlocked tid
+    if blocked then
+        return ()
+    else
+        do
+            threadDelay 100000
+            waitUntilBlocked tid
+
+isBlocked:: ThreadId -> IO Bool
+isBlocked = fmap isThreadStatusBlocked . threadStatus
+
+isThreadStatusBlocked :: ThreadStatus -> Bool
+isThreadStatusBlocked (ThreadBlocked _) = True
+isThreadStatusBlocked _ = False


=====================================
utils/genprimopcode/Main.hs
=====================================
@@ -878,6 +878,7 @@ ppType (TyApp (TyCon "ThreadId#")   []) = "threadIdPrimTy"
 ppType (TyApp (TyCon "ForeignObj#") []) = "foreignObjPrimTy"
 ppType (TyApp (TyCon "BCO")         []) = "bcoPrimTy"
 ppType (TyApp (TyCon "Compact#")    []) = "compactPrimTy"
+ppType (TyApp (TyCon "StackSnapshot#") []) = "stackSnapshotPrimTy"
 ppType (TyApp (TyCon "()")          []) = "unitTy"      -- unitTy is GHC.Builtin.Types's name for ()
 
 ppType (TyVar "a")                      = "alphaTy"



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5e88f5097f60b24330d4397afcb5aa5d996fbb0a...276e19f7809f7ece2db516d990347555a3436f25

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5e88f5097f60b24330d4397afcb5aa5d996fbb0a...276e19f7809f7ece2db516d990347555a3436f25
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/20201031/13ba27a4/attachment-0001.html>


More information about the ghc-commits mailing list