[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 19:04:46 UTC 2020
Ben Gamari pushed to branch wip/stack_cloning at Glasgow Haskell Compiler / GHC
Commits:
36e3225f by Sven Tennie at 2020-10-31T15:02:37-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].
- - - - -
e54314f2 by Sven Tennie at 2020-10-31T15:02:49-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].
- - - - -
78c2c2f8 by Sven Tennie at 2020-10-31T15:02:53-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,76 @@
+{-# 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.
+
+A StackSnapshot# is really a pointer to an immutable StgStack closure with
+the invariant that stack->sp points to a valid frame.
+-}
+
+-- | 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,104 @@
+/* ---------------------------------------------------------------------------
+ *
+ * (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
+
+static StgStack* cloneStackChunk(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;
+}
+
+StgStack* cloneStack(Capability* capability, const StgStack* stack)
+{
+ StgStack *top_stack = cloneStackChunk(capability, stack);
+ StgStack last_stack = top_stack;
+ while (true) {
+ // check whether the stack ends in an underflow frame
+ StgPtr top = last_stack->stack + last_stack->stack_size
+ StgUnderflowFrame *frame = ((StgUnderflowFrame *)top)[-1];
+ if (frame->header.info == &stg_UNDERFLOW_FRAME_info) {
+ StgStack *s = cloneStackChunk(capability, frame->next_chunk);
+ frame->next_chunk = s;
+ last_stack = s;
+ } else {
+ break;
+ }
+ }
+ return top_stack;
+}
+
+#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, const 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/276e19f7809f7ece2db516d990347555a3436f25...78c2c2f85fbe2f47442a6820d809b2a68c0af772
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/276e19f7809f7ece2db516d990347555a3436f25...78c2c2f85fbe2f47442a6820d809b2a68c0af772
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/c373dda6/attachment-0001.html>
More information about the ghc-commits
mailing list