[Git][ghc/ghc][wip/stack_cloning] 3 commits: Introduce snapshotting of thread's own stack
Matthew Pickering
gitlab at gitlab.haskell.org
Tue Nov 10 17:36:21 UTC 2020
Matthew Pickering pushed to branch wip/stack_cloning at Glasgow Haskell Compiler / GHC
Commits:
9e30aabe by Sven Tennie at 2020-11-10T17:26:36+00: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].
Co-authored-by: Ben Gamari <bgamari.foss at gmail.com>
Co-authored-by: Matthew Pickering <matthewtpickering at gmail.com>
- - - - -
3874b577 by Sven Tennie at 2020-11-10T17:27:40+00: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].
Co-authored-by: Ben Gamari <bgamari.foss at gmail.com>
- - - - -
6b09e577 by Matthew Pickering at 2020-11-10T17:35:36+00:00
Add another test for stack cloning
This test triggers at least one GC, which showed up the problem with the
stale sp field.
- - - - -
22 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/storage/Closures.h
- includes/stg/MiscClosures.h
- + libraries/base/GHC/Stack/CloneStack.hs
- libraries/base/base.cabal
- + rts/CloneStack.c
- + rts/CloneStack.h
- rts/Messages.c
- rts/PrimOps.cmm
- 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/cloneMyStack2.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/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,70 @@
+{-# 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
+ ) 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
+
=====================================
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 *underFlowFrame = ((StgUnderflowFrame *) top);
+ StgUnderflowFrame *frame = underFlowFrame--;
+ if (frame->info == &stg_stack_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);
+
+void sendCloneStackMessage(StgTSO *tso, HsStablePtr mvar);
+
+#include "BeginPrivate.h"
+
+#if defined(THREADED_RTS)
+void handleCloneStackMessage(MessageCloneStack *msg);
+#endif
+
+#include "EndPrivate.h"
=====================================
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);
+ StgStack_sp(stgStack) = Sp;
+
+ ("ptr" clonedStack) = ccall cloneStack(MyCapability() "ptr", stgStack "ptr");
+
+ return (clonedStack);
+}
=====================================
rts/RtsSymbols.c
=====================================
@@ -12,6 +12,7 @@
#include "Rts.h"
#include "TopHandler.h"
#include "HsFFI.h"
+#include "CloneStack.h"
#include "sm/Storage.h"
#include "sm/NonMovingMark.h"
@@ -979,6 +980,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 +1000,7 @@
SymI_HasProto(cas) \
SymI_HasProto(_assertFail) \
SymI_HasProto(keepCAFs) \
+ SymI_HasProto(sendCloneStackMessage) \
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,8 @@ 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('cloneMyStack2', ignore_stdout, compile_and_run, [''])
+
+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/cloneMyStack2.hs
=====================================
@@ -0,0 +1,15 @@
+{-# LANGUAGE BangPatterns #-}
+module Main where
+
+import GHC.Stack.CloneStack
+
+main = foo 100
+
+{-# NOINLINE foo #-}
+foo 0 = () <$ getStack
+foo n = print "x" >> foo (n - 1) >> print "x"
+
+-- This shouldn't segfault
+getStack = do
+ !s <- cloneMyStack
+ return ()
=====================================
testsuite/tests/rts/cloneStackLib.c
=====================================
@@ -0,0 +1,55 @@
+#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->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 expectStackToBeNotDirty(StgStack *stack) {
+ if(stack->dirty != 0) {
+ barf("Expected stack to be not dirty. But dirty flag was set to %u", stack->dirty);
+ }
+}
+
+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,49 @@
+{-# 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 ()
+
+foreign import ccall "expectStackToBeNotDirty" expectStackToBeNotDirty:: StackSnapshot# -> 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#
+ expectStackToBeNotDirty stack
+
+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/bcc93393857b1014bb0127f5ab9743211ed82678...6b09e577cf7afb73a423db02a62a3eff150f8dde
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bcc93393857b1014bb0127f5ab9743211ed82678...6b09e577cf7afb73a423db02a62a3eff150f8dde
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/20201110/a8a5aa99/attachment-0001.html>
More information about the ghc-commits
mailing list