[Git][ghc/ghc][wip/stack_cloning] 2 commits: Remove unneccesary primop cloneThreadStack# (#18741)
Sven Tennie
gitlab at gitlab.haskell.org
Sat Oct 3 14:57:15 UTC 2020
Sven Tennie pushed to branch wip/stack_cloning at Glasgow Haskell Compiler / GHC
Commits:
4b5e678a by Sven Tennie at 2020-09-27T17:23:51+02:00
Remove unneccesary primop cloneThreadStack# (#18741)
- - - - -
ff9eb1a2 by Sven Tennie at 2020-10-03T16:56:57+02:00
Add cloneThreadStack and cloneMyStack
- - - - -
20 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/StgToCmm/Prim.hs
- includes/rts/storage/Closures.h
- includes/stg/MiscClosures.h
- libraries/base/GHC/Conc/Sync.hs
- + libraries/base/GHC/Stack/CloneStack.hs
- libraries/base/base.cabal
- + rts/CloneStack.c
- + rts/CloneStack.h
- rts/Messages.c
- rts/PrimOps.cmm
- rts/Printer.c
- rts/Printer.h
- rts/StgMiscClosures.cmm
- rts/Threads.c
- 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:
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -3586,13 +3586,6 @@ primop CloneMyStack "cloneMyStack#" GenPrimOp
has_side_effects = True
out_of_line = True
-primop CloneThreadStack "cloneThreadStack#" GenPrimOp
- ThreadId# -> State# RealWorld -> (# State# RealWorld, StackSnapshot# #)
- { Clones the stack of a Haskell thread. }
- with
- has_side_effects = True
- out_of_line = True
-
------------------------------------------------------------------------
section "Safe coercions"
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -1518,7 +1518,6 @@ emitPrimOp dflags primop = case primop of
TraceMarkerOp -> alwaysExternal
SetThreadAllocationCounter -> alwaysExternal
CloneMyStack -> alwaysExternal
- CloneThreadStack -> 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);
=====================================
libraries/base/GHC/Conc/Sync.hs
=====================================
@@ -624,7 +624,7 @@ data PrimMVar
-- @hs_try_putmvar()@. The RTS wants a 'StablePtr' to the underlying
-- 'MVar#', but a 'StablePtr#' can only refer to lifted types, so we
-- have to cheat by coercing.
-newStablePtrPrimMVar :: MVar () -> IO (StablePtr PrimMVar)
+newStablePtrPrimMVar :: MVar a -> IO (StablePtr PrimMVar)
newStablePtrPrimMVar (MVar m) = IO $ \s0 ->
case makeStablePtr# (unsafeCoerce# m :: PrimMVar) s0 of
-- Coerce unlifted m :: MVar# RealWorld ()
=====================================
libraries/base/GHC/Stack/CloneStack.hs
=====================================
@@ -0,0 +1,40 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnliftedFFITypes#-}
+
+
+module GHC.Stack.CloneStack (
+ cloneThreadStack,
+ cloneMyStack,
+ StackSnapshot(..)
+ ) where
+
+import GHC.Prim (StackSnapshot#, cloneMyStack#, ThreadId#)
+import Control.Concurrent.MVar
+import GHC.Conc.Sync
+import GHC.Stable
+import GHC.IO (IO(..))
+
+foreign import ccall "sendCloneStackMessage" sendCloneStackMessage :: ThreadId# -> StablePtr PrimMVar -> IO ()
+
+data StackSnapshot = StackSnapshot StackSnapshot#
+
+-- | Clone the stack of a thread identified by it's 'ThreadId'
+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
+ print "takeMVar"
+ takeMVar resultVar
+
+-- | Clone the stack of the executing thread
+cloneMyStack :: IO StackSnapshot
+cloneMyStack = IO $ \s ->
+ case (cloneMyStack# s) of (# s1, stack #) -> (# s1, StackSnapshot 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,67 @@
+#include <string.h>
+
+#include "Rts.h"
+#include "rts/Messages.h"
+#include "rts/storage/TSO.h"
+#include "stg/Types.h"
+#include "CloneStack.h"
+
+#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);
+ // TODO: Free? See RtsAPI.c: hs_try_putmvar()
+ 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);
+
+ bool putMVarWasSuccessful = performTryPutMVar(msg->tso->cap, msg->result, newStackClosure);
+
+ if(!putMVarWasSuccessful) {
+ barf("Can't put stack cloning result into MVar.");
+ }
+}
+
+#else // !defined(THREADED_RTS)
+
+void sendCloneStackMessage(StgTSO *tso, HsStablePtr mvar) {
+ barf("Sending CloneStackMessages is only available in threaded RTS!");
+}
+
+#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));
+
+ StgStack* newStackClosure = (StgStack*) allocate(capability, ROUNDUP_BYTES_TO_WDS(closureSizeBytes));
+
+ memcpy(newStackClosure, stack, closureSizeBytes);
+
+ newStackClosure->sp = newStackClosure->stack + spOffset;
+
+#if defined(DEBUG)
+ debugBelch("Cloned stack\n");
+ printStack(newStackClosure);
+ // TODO: Check sanity
+#endif
+
+ return newStackClosure;
+}
=====================================
rts/CloneStack.h
=====================================
@@ -0,0 +1,9 @@
+#pragma once
+
+#if defined(THREADED_RTS)
+void handleCloneStackMessage(MessageCloneStack *msg);
+#endif
+
+void sendCloneStackMessage(StgTSO *tso, HsStablePtr mvar);
+
+StgStack* cloneStack(Capability* capability, StgStack* stack);
=====================================
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
=====================================
@@ -2841,26 +2841,13 @@ stg_setThreadAllocationCounterzh ( I64 counter )
return ();
}
-stg_cloneThreadStackzh () {
- // TODO: Implement me! Consider locks, race-conditions, etc.
- return ();
-}
-
stg_cloneMyStackzh () {
W_ stgStack;
- gcptr p;
- W_ neededMemorySize;
+ W_ clonedStack;
stgStack = StgTSO_stackobj(CurrentTSO);
- neededMemorySize = BYTES_TO_WDS(SIZEOF_StgStack) + StgStack_stack_size(stgStack);
-
- ("ptr" p) = ccall allocateMightFail(MyCapability() "ptr", neededMemorySize);
- if (p == NULL) {
- jump stg_raisezh(base_GHCziIOziException_heapOverflow_closure);
- }
+ ("ptr" clonedStack) = ccall cloneStack(MyCapability() "ptr", stgStack "ptr");
- prim %memcpy(p, stgStack, WDS(neededMemorySize), SIZEOF_W);
-
- return (p);
+ return (clonedStack);
}
=====================================
rts/Printer.c
=====================================
@@ -642,7 +642,8 @@ printStackChunk( StgPtr sp, StgPtr spBottom )
}
}
-static void printStack( StgStack *stack )
+// TODO: Do not merge. Only exported for debugging.
+void printStack( StgStack *stack )
{
printStackChunk( stack->sp, stack->stack + stack->stack_size );
}
@@ -697,7 +698,7 @@ void printLargeAndPinnedObjects()
for (uint32_t cap_idx = 0; cap_idx < n_capabilities; ++cap_idx) {
Capability *cap = capabilities[cap_idx];
- debugBelch("Capability %d: Current pinned object block: %p\n",
+ 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);
=====================================
rts/Printer.h
=====================================
@@ -21,6 +21,7 @@ const char * info_type_by_ip ( const StgInfoTable *ip );
const char * info_update_frame ( const StgClosure *closure );
#if defined(DEBUG)
+extern void printStack( StgStack *stack );
extern void printClosure ( const StgClosure *obj );
extern void printStackChunk ( StgPtr sp, StgPtr spLim );
extern void printTSO ( StgTSO *tso );
=====================================
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/Threads.c
=====================================
@@ -23,6 +23,7 @@
#include "Printer.h"
#include "sm/Sanity.h"
#include "sm/Storage.h"
+#include "Printer.h"
#include <string.h>
=====================================
rts/rts.cabal.in
=====================================
@@ -410,6 +410,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 -debug'])
+
+test('cloneThreadStack', [only_ways(['threaded1']), extra_ways(['threaded1']), extra_files(['cloneStackLib.c'])], compile_and_run, ['cloneStackLib.c -debug -threaded'])
=====================================
testsuite/tests/rts/cloneMyStack.hs
=====================================
@@ -0,0 +1,14 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+
+import GHC.Prim (StackSnapshot#)
+import GHC.Stack.CloneStack
+
+foreign import ccall "printy" printStack:: StackSnapshot# -> IO ()
+
+main :: IO ()
+main = do
+ stackSnapshot <- cloneMyStack
+ let (StackSnapshot stack) = stackSnapshot
+ printStack stack
=====================================
testsuite/tests/rts/cloneStackLib.c
=====================================
@@ -0,0 +1,9 @@
+#include "Rts.h"
+#include "RtsAPI.h"
+
+// TODO: Do not merge. Only exported for debugging.
+extern void printStack( StgStack *stack );
+
+void printy(StgStack *stack) {
+ printStack(stack);
+}
=====================================
testsuite/tests/rts/cloneThreadStack.hs
=====================================
@@ -0,0 +1,23 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+
+import GHC.Prim (StackSnapshot#)
+import GHC.Stack.CloneStack
+import Control.Concurrent
+
+foreign import ccall "printy" printStack:: StackSnapshot# -> IO ()
+
+main :: IO ()
+main = do
+ mVarToBeBlockedOn <- newEmptyMVar
+ threadId <- forkIO $ immediatelyBlocking mVarToBeBlockedOn
+
+ stackSnapshot <- cloneThreadStack threadId
+ let (StackSnapshot stack) = stackSnapshot
+ printStack stack
+
+immediatelyBlocking :: MVar Int -> IO ()
+immediatelyBlocking mVarToBeBlockedOn = do
+ takeMVar mVarToBeBlockedOn
+ return ()
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4cd2c222e8f23d0ec73ca35694baa1cdc35e1c82...ff9eb1a2306a001236d606432e915ff5f27df39a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4cd2c222e8f23d0ec73ca35694baa1cdc35e1c82...ff9eb1a2306a001236d606432e915ff5f27df39a
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/20201003/d05f93cc/attachment-0001.html>
More information about the ghc-commits
mailing list