[Git][ghc/ghc][wip/stack_cloning] Fix MVar putting and implement tests
Sven Tennie
gitlab at gitlab.haskell.org
Sun Oct 11 16:13:36 UTC 2020
Sven Tennie pushed to branch wip/stack_cloning at Glasgow Haskell Compiler / GHC
Commits:
31272415 by Sven Tennie at 2020-10-11T18:13:16+02:00
Fix MVar putting and implement tests
- - - - -
9 changed files:
- libraries/base/GHC/Stack/CloneStack.hs
- rts/CloneStack.c
- rts/CloneStack.h
- 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
Changes:
=====================================
libraries/base/GHC/Stack/CloneStack.hs
=====================================
@@ -21,6 +21,19 @@ foreign import ccall "sendCloneStackMessage" sendCloneStackMessage :: ThreadId#
data StackSnapshot = StackSnapshot StackSnapshot#
+{- Note [Stack Cloning]
+"Cloning" a stack means that it's StgStack closure is copied including the
+stack memory (stack[]). The stack pointer (sp) of the clone is adjusted to be
+valid.
+The clone is "offline"/"cold", i.e. it won't be evaluated any further. This is
+useful for further analyses like stack unwinding or traversal.
+
+There are two different ways to clone a stack:
+1. By the corresponding thread via a primop call (cloneMyStack#).
+2. By sending a RTS message (Messages.c) with a MVar to the corresponding
+ thread and receiving the stack by taking it out of this MVar.
+-}
+
-- | Clone the stack of a thread identified by it's 'ThreadId'
cloneThreadStack :: ThreadId -> IO StackSnapshot
cloneThreadStack (ThreadId tid#) = do
@@ -31,7 +44,6 @@ cloneThreadStack (ThreadId tid#) = do
-- into resultVar.
sendCloneStackMessage tid# ptr
freeStablePtr ptr
- print "takeMVar"
takeMVar resultVar
-- | Clone the stack of the executing thread
=====================================
rts/CloneStack.c
=====================================
@@ -27,7 +27,12 @@ void sendCloneStackMessage(StgTSO *tso, HsStablePtr mvar) {
void handleCloneStackMessage(MessageCloneStack *msg){
StgStack* newStackClosure = cloneStack(msg->tso->cap, msg->tso->stackobj);
- bool putMVarWasSuccessful = performTryPutMVar(msg->tso->cap, msg->result, newStackClosure);
+ // 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.");
@@ -43,11 +48,6 @@ void sendCloneStackMessage(StgTSO *tso, HsStablePtr mvar) {
#endif // end !defined(THREADED_RTS)
StgStack* cloneStack(Capability* capability, StgStack* stack){
-#if defined(DEBUG)
- debugBelch("Stack to clone\n");
- printStack(stack);
-#endif
-
StgWord spOffset = stack->sp - stack->stack;
StgWord closureSizeBytes = sizeof(StgStack) + (stack->stack_size * sizeof(StgWord));
@@ -58,9 +58,7 @@ StgStack* cloneStack(Capability* capability, StgStack* stack){
newStackClosure->sp = newStackClosure->stack + spOffset;
#if defined(DEBUG)
- debugBelch("Cloned stack\n");
- printStack(newStackClosure);
- // TODO: Check sanity
+ checkClosure(newStackClosure);
#endif
return newStackClosure;
=====================================
rts/CloneStack.h
=====================================
@@ -7,3 +7,6 @@ void handleCloneStackMessage(MessageCloneStack *msg);
void sendCloneStackMessage(StgTSO *tso, HsStablePtr mvar);
StgStack* cloneStack(Capability* capability, StgStack* stack);
+
+extern StgClosure DLL_IMPORT_DATA_VARNAME(base_GHCziStackziCloneStack_StackSnapshot_closure);
+#define StackSnapshot_constructor_closure DLL_IMPORT_DATA_REF(base_GHCziStackziCloneStack_StackSnapshot_closure)
=====================================
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,
=====================================
testsuite/tests/rts/all.T
=====================================
@@ -419,6 +419,6 @@ test('T17088',
test('T15427', normal, compile_and_run, [''])
-test('cloneMyStack', [extra_files(['cloneStackLib.c'])], compile_and_run, ['cloneStackLib.c -debug'])
+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 -debug -threaded'])
+test('cloneThreadStack', [only_ways(['threaded1']), extra_ways(['threaded1']), extra_files(['cloneStackLib.c'])], compile_and_run, ['cloneStackLib.c -threaded'])
=====================================
testsuite/tests/rts/cloneMyStack.hs
=====================================
@@ -4,11 +4,17 @@
import GHC.Prim (StackSnapshot#)
import GHC.Stack.CloneStack
+import Foreign
+import Foreign.C.Types (CUInt)
-foreign import ccall "printy" printStack:: StackSnapshot# -> IO ()
+foreign import ccall "expectClosureTypes" expectClosureTypes:: StackSnapshot# -> Ptr CUInt -> Int -> IO ()
main :: IO ()
main = do
stackSnapshot <- cloneMyStack
+
let (StackSnapshot stack) = stackSnapshot
- printStack stack
+ let expectedClosureTypes = [34 -- CATCH_FRAME
+ ,36 -- STOP_FRAME
+ ]
+ withArray expectedClosureTypes (\ptr -> expectClosureTypes stack ptr (length expectedClosureTypes))
=====================================
testsuite/tests/rts/cloneStackLib.c
=====================================
@@ -1,9 +1,53 @@
#include "Rts.h"
#include "RtsAPI.h"
+#include "rts/Messages.h"
-// TODO: Do not merge. Only exported for debugging.
-extern void printStack( StgStack *stack );
-void printy(StgStack *stack) {
- printStack(stack);
+void checkClonedStack(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
=====================================
@@ -2,22 +2,45 @@
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnliftedFFITypes #-}
-import GHC.Prim (StackSnapshot#)
+import GHC.Prim (StackSnapshot#, ThreadId#)
+import GHC.Conc.Sync (ThreadId(..))
import GHC.Stack.CloneStack
import Control.Concurrent
+import GHC.Conc
-foreign import ccall "printy" printStack:: StackSnapshot# -> IO ()
+foreign import ccall "checkClonedStack" checkClonedStack:: StackSnapshot# -> ThreadId# -> IO ()
main :: IO ()
main = do
mVarToBeBlockedOn <- newEmptyMVar
threadId <- forkIO $ immediatelyBlocking mVarToBeBlockedOn
+ waitUntilBlocked threadId
+
stackSnapshot <- cloneThreadStack threadId
+
let (StackSnapshot stack) = stackSnapshot
- printStack stack
+ let (ThreadId tid#) = threadId
+ checkClonedStack 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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/31272415c6286ca0af812bdbc72504e28df6def6
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/31272415c6286ca0af812bdbc72504e28df6def6
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/20201011/e1e681e6/attachment-0001.html>
More information about the ghc-commits
mailing list