[Git][ghc/ghc][wip/ghc-debug] Return a Capability from rts_pause to allow use of other RtsAPI.h functions
David Eichmann
gitlab at gitlab.haskell.org
Tue Sep 22 22:05:50 UTC 2020
David Eichmann pushed to branch wip/ghc-debug at Glasgow Haskell Compiler / GHC
Commits:
daddf2b1 by David Eichmann at 2020-09-22T23:05:36+01:00
Return a Capability from rts_pause to allow use of other RtsAPI.h functions
- - - - -
9 changed files:
- includes/RtsAPI.h
- libraries/ghc-heap/tests/list_threads_and_misc_roots_c.c
- rts/RtsAPI.c
- testsuite/tests/rts/ghc-debug/all.T
- testsuite/tests/rts/ghc-debug/ghc_debug.c
- testsuite/tests/rts/ghc-debug/ghc_debug.h
- + testsuite/tests/rts/ghc-debug/ghc_debug_03.stdout
- + testsuite/tests/rts/ghc-debug/ghc_debug_04.hs
- + testsuite/tests/rts/ghc-debug/ghc_debug_04.stdout
Changes:
=====================================
includes/RtsAPI.h
=====================================
@@ -335,11 +335,12 @@ extern void (*exitFn)(int);
/* ----------------------------------------------------------------------------
Locking.
- You have to surround all access to the RtsAPI with these calls.
+ You have to surround all access to the RtsAPI with rts_lock and rts_unlock
+ or with rts_pause and rts_resume.
------------------------------------------------------------------------- */
-// acquires a token which may be used to create new objects and
-// evaluate them.
+// acquires a token which may be used to create new objects and evaluate them.
+// Calling rts_lock in between rts_pause/rts_resume will cause a deadlock.
Capability *rts_lock (void);
// releases the token acquired with rts_lock().
@@ -486,18 +487,22 @@ void rts_checkSchedStatus (char* site, Capability *);
SchedulerStatus rts_getSchedStatus (Capability *cap);
// Halt execution of all Haskell threads by acquiring all capabilities (safe FFI
-// calls may continue). This is different to rts_lock() which only pauses a
-// single capability. rts_resume() must later be called on the same thread to
+// calls may continue). rts_resume() must later be called on the same thread to
// resume the RTS. Only one thread at a time can keep the rts paused. The
// rts_pause function will block until the current thread is given exclusive
// permission to pause the RTS. If the RTS was already paused by the current OS
-// thread, then rts_pause will return immediately and have no effect.
-void rts_pause (void);
+// thread, then rts_pause will return immediately and have no effect. Returns a
+// token which may be used to create new objects and evaluate them (like
+// rts_lock) .This is different to rts_lock() which only pauses a single
+// capability. Calling rts_pause in between rts_lock/rts_unlock will cause a
+// deadlock.
+Capability * rts_pause (void);
// Counterpart of rts_pause: Continue from a pause. All capabilities are
// released. Must be done while RTS is paused and on the same thread as
// rts_pause().
-void rts_resume (void);
+// [in] cap: the token returned by rts_pause.
+void rts_resume (Capability * cap);
// Tells the current state of the RTS regarding rts_pause() and rts_resume().
bool rts_isPaused(void);
=====================================
libraries/ghc-heap/tests/list_threads_and_misc_roots_c.c
=====================================
@@ -23,10 +23,10 @@ void collectMiscRootsCallback(void *user, StgClosure* closure){
}
void* listThreads_thread(void* unused){
- rts_pause();
+ Capability * cap = rts_pause();
rts_listThreads(&collectTSOsCallback, NULL);
rts_listMiscRoots(&collectMiscRootsCallback, NULL);
- rts_resume();
+ rts_resume(cap);
return NULL;
}
=====================================
rts/RtsAPI.c
=====================================
@@ -652,14 +652,14 @@ rts_unlock (Capability *cap)
Task * rts_pausing_task = NULL;
// See RtsAPI.h
-void rts_pause (void)
+Capability * rts_pause (void)
{
// Return immediately if this thread already paused the RTS. If another
// thread has paused the RTS, then rts_pause will block until rts_resume is
// called (and compete with other threads calling rts_pause). The blocking
// behavior is implied by the use of `stopAllCapabilities`.
Task * task = getMyTask();
- if (rts_pausing_task == task) return;
+ if (rts_pausing_task == task) return task->cap;
// The current task must not own a capability. This is true when a new
// thread is stareted, or when making a safe FFI call. If
@@ -740,10 +740,13 @@ void rts_pause (void)
// Now we own all capabilities so we own rts_pausing_task.
rts_pausing_task = task;
+
+ return task->cap;
}
-// See RtsAPI.h
-void rts_resume (void)
+// See RtsAPI.h The cap argument is here just for symmetry with rts_pause and to
+// match the pattern of rts_lock/rts_unlock.
+void rts_resume (Capability * cap STG_UNUSED)
{
Task * task = getMyTask(); // This thread has ownership over its Task.
@@ -845,14 +848,14 @@ void rts_listMiscRoots (ListRootsCb cb, void *user)
}
#else
-void rts_pause (void)
+Capability * rts_pause (void)
{
errorBelch("Warning: Pausing the RTS is only possible for "
"multithreaded RTS.");
stg_exit(EXIT_FAILURE);
}
-void rts_resume (void)
+void rts_resume (Capability * cap)
{
errorBelch("Warning: Unpausing the RTS is only possible for "
"multithreaded RTS.");
=====================================
testsuite/tests/rts/ghc-debug/all.T
=====================================
@@ -1,18 +1,8 @@
-test('ghc_debug_01',
- [ extra_files(['ghc_debug.c','ghc_debug.h']),
- ignore_stdout,
- ignore_stderr
- ],
+test('ghc_debug_01', [extra_files(['ghc_debug.c','ghc_debug.h'])],
multi_compile_and_run, ['ghc_debug_01', [('ghc_debug.c','')], '-threaded '])
-test('ghc_debug_02',
- [ extra_files(['ghc_debug.c','ghc_debug.h']),
- ignore_stdout,
- ignore_stderr
- ],
+test('ghc_debug_02', [extra_files(['ghc_debug.c','ghc_debug.h'])],
multi_compile_and_run, ['ghc_debug_02', [('ghc_debug.c','')], '-threaded '])
-test('ghc_debug_03',
- [ extra_files(['ghc_debug.c','ghc_debug.h']),
- ignore_stdout,
- ignore_stderr
- ],
+test('ghc_debug_03', [extra_files(['ghc_debug.c','ghc_debug.h'])],
multi_compile_and_run, ['ghc_debug_03', [('ghc_debug.c','')], '-threaded '])
+test('ghc_debug_04', [extra_files(['ghc_debug.c','ghc_debug.h'])],
+ multi_compile_and_run, ['ghc_debug_04', [('ghc_debug.c','')], '-threaded '])
=====================================
testsuite/tests/rts/ghc-debug/ghc_debug.c
=====================================
@@ -1,3 +1,4 @@
+#include <assert.h>
#include <stdio.h>
#include <unistd.h>
@@ -29,8 +30,17 @@ void pauseAndResume
}
// Pause and assert.
- rts_pause();
- rts_pause(); // This should have no effect and return immediately.
+ Capability * cap = rts_pause();
+ if(cap == NULL) {
+ errorBelch("rts_pause() returned NULL.");
+ exit(1);
+ }
+ Capability * cap2 = rts_pause(); // This should have no effect and return immediately.
+ if(cap != cap2) {
+ errorBelch("A second call to rts_pause() returned a different Capability.");
+ exit(1);
+ }
+
if(!rts_isPaused()) {
errorBelch("Expected the RTS to be paused.");
exit(1);
@@ -39,7 +49,7 @@ void pauseAndResume
expectNoChange("RTS should be paused", count);
// Resume.
- rts_resume();
+ rts_resume(cap);
// Assert the RTS is resumed.
if (assertNotPaused)
@@ -52,6 +62,125 @@ void pauseAndResume
}
}
+int addOne(int a)
+{
+ return a + 1;
+}
+
+// Pause tht RTS and call all RtsAPI.h functions.
+void pauseAndUseRtsAPIAndResume
+ ( HaskellObj haskellFn // [in] A Haskell function (StablePtr (a -> a))
+ , HaskellObj haskellFnArgument // [in] An argument to apply to haskellFn (a)
+ , HaskellObj obj1 // [in] arbitrary haskell value to evaluate of arbitrary type.
+ , HaskellObj obj2 // [in] arbitrary haskell value to evaluate of arbitrary type.
+ , HsStablePtr stablePtrIO // [in] arbitrary haskell IO action to execute (StablePtr (IO t))
+ )
+{
+ // Pause the RTS.
+ printf("Pause the RTS...");
+ Capability * cap = rts_pause();
+ printf("Paused\n");
+
+ // Note the original capability. We assert that cap is not changed by
+ // functions that take &cap.
+ Capability *const cap0 = cap;
+
+ // Call RtsAPI.h functions
+
+ // TODO print out what funciton is running to give better debug output if one of these deadlocks
+
+ printf("getRTSStats...\n");
+ RTSStats s;
+ getRTSStats (&s);
+ printf("getRTSStatsEnabled...\n");
+ getRTSStatsEnabled();
+ printf("getAllocations...\n");
+ getAllocations();
+ printf("rts_getSchedStatus...\n");
+ rts_getSchedStatus(cap);
+ printf("rts_getChar, rts_mkChar...\n");
+ rts_getChar (rts_mkChar ( cap, 0 ));
+ printf("rts_getInt, rts_mkInt...\n");
+ rts_getInt (rts_mkInt ( cap, 0 ));
+ printf("rts_getInt8, rts_mkInt8...\n");
+ rts_getInt8 (rts_mkInt8 ( cap, 0 ));
+ printf("rts_getInt16, rts_mkInt16...\n");
+ rts_getInt16 (rts_mkInt16 ( cap, 0 ));
+ printf("rts_getInt32, rts_mkInt32...\n");
+ rts_getInt32 (rts_mkInt32 ( cap, 0 ));
+ printf("rts_getInt64, rts_mkInt64...\n");
+ rts_getInt64 (rts_mkInt64 ( cap, 0 ));
+ printf("rts_getWord, rts_mkWord...\n");
+ rts_getWord (rts_mkWord ( cap, 0 ));
+ printf("rts_getWord8, rts_mkWord8...\n");
+ rts_getWord8 (rts_mkWord8 ( cap, 0 ));
+ printf("rts_getWord16, rts_mkWord16...\n");
+ rts_getWord16 (rts_mkWord16 ( cap, 0 ));
+ printf("rts_getWord32, rts_mkWord32...\n");
+ rts_getWord32 (rts_mkWord32 ( cap, 0 ));
+ printf("rts_getWord64, rts_mkWord64...\n");
+ rts_getWord64 (rts_mkWord64 ( cap, 0 ));
+ printf("rts_getPtr, rts_mkPtr...\n");
+ int x = 0;
+ rts_getPtr (rts_mkPtr ( cap, &x));
+ printf("rts_getFunPtr, rts_mkFunPtr...\n");
+ rts_getFunPtr (rts_mkFunPtr ( cap, &addOne ));
+ printf("rts_getFloat, rts_mkFloat...\n");
+ rts_getFloat (rts_mkFloat ( cap, 0.0 ));
+ printf("rts_getDouble, rts_mkDouble...\n");
+ rts_getDouble (rts_mkDouble ( cap, 0.0 ));
+ printf("rts_getStablePtr, rts_mkStablePtr...\n");
+ rts_getStablePtr (rts_mkStablePtr ( cap, &x ));
+ printf("rts_getBool, rts_mkBool...\n");
+ rts_getBool (rts_mkBool ( cap, 0 ));
+ printf("rts_mkString...\n");
+ rts_mkString ( cap, "Hello ghc-debug!" );
+ printf("rts_apply...\n");
+ rts_apply ( cap, deRefStablePtr(haskellFn), haskellFnArgument );
+
+ printf("rts_eval...\n");
+ HaskellObj ret;
+ rts_eval(&cap, obj1, &ret);
+ assert(cap == cap0);
+
+ printf("rts_eval_...\n");
+ rts_eval_ (&cap, obj2, 50, &ret);
+ assert(cap == cap0);
+
+ printf("rts_evalIO...\n");
+ HaskellObj io = deRefStablePtr(stablePtrIO);
+ rts_evalIO (&cap, io, &ret);
+ assert(cap == cap0);
+
+ printf("rts_evalStableIOMain...\n");
+ HsStablePtr retStablePtr;
+ rts_evalStableIOMain (&cap, stablePtrIO, &retStablePtr);
+ assert(cap == cap0);
+
+ printf("rts_evalStableIO...\n");
+ rts_evalStableIO (&cap, stablePtrIO, &retStablePtr);
+ assert(cap == cap0);
+
+ printf("rts_evalLazyIO...\n");
+ rts_evalLazyIO (&cap, io, &ret);
+ assert(cap == cap0);
+
+ printf("rts_evalLazyIO_...\n");
+ rts_evalLazyIO_ (&cap, io, 50, &ret);
+ assert(cap == cap0);
+
+ printf("rts_setInCallCapability...\n");
+ rts_setInCallCapability (0, 1);
+ printf("rts_pinThreadToNumaNode...\n");
+ rts_pinThreadToNumaNode (0);
+
+ // Resume the RTS.
+ printf("Resume the RTS...");
+ rts_resume(cap);
+ assert(cap == cap0);
+ printf("Resumed\n");
+}
+
void* pauseAndResumeViaThread_helper(volatile unsigned int * count)
{
pauseAndResume(false, count);
=====================================
testsuite/tests/rts/ghc-debug/ghc_debug.h
=====================================
@@ -1,3 +1,10 @@
void pauseAndResume(bool assertNotPaused, volatile unsigned int * count);
unsigned long pauseAndResumeViaThread(volatile unsigned int * count);
+void pauseAndUseRtsAPIAndResume
+ ( HaskellObj haskellFn
+ , HaskellObj haskellFnArgument
+ , HaskellObj obj1
+ , HaskellObj obj2
+ , HsStablePtr stablePtrIO
+ );
=====================================
testsuite/tests/rts/ghc-debug/ghc_debug_03.stdout
=====================================
@@ -0,0 +1 @@
+All threads finished
=====================================
testsuite/tests/rts/ghc-debug/ghc_debug_04.hs
=====================================
@@ -0,0 +1,28 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+import Foreign
+import System.Exit
+import System.Timeout
+
+foreign import ccall safe "ghc_debug.h pauseAndUseRtsAPIAndResume"
+ pauseAndUseRtsAPIAndResume
+ :: (StablePtr (Int -> Int))
+ -> Int
+ -> Int
+ -> Int
+ -> (StablePtr (IO Int))
+ -> IO ()
+
+main :: IO ()
+main = do
+ addOne <- newStablePtr ((+1) :: Int -> Int)
+ ioOne <- newStablePtr (return 1 :: IO Int)
+ successMay <- timeout 5000000 $ pauseAndUseRtsAPIAndResume
+ addOne
+ 1
+ 2
+ 3
+ ioOne
+ case successMay of
+ Nothing -> exitFailure
+ Just () -> exitSuccess
=====================================
testsuite/tests/rts/ghc-debug/ghc_debug_04.stdout
=====================================
@@ -0,0 +1,34 @@
+Pause the RTS...Paused
+getRTSStats...
+getRTSStatsEnabled...
+getAllocations...
+rts_getSchedStatus...
+rts_getChar, rts_mkChar...
+rts_getInt, rts_mkInt...
+rts_getInt8, rts_mkInt8...
+rts_getInt16, rts_mkInt16...
+rts_getInt32, rts_mkInt32...
+rts_getInt64, rts_mkInt64...
+rts_getWord, rts_mkWord...
+rts_getWord8, rts_mkWord8...
+rts_getWord16, rts_mkWord16...
+rts_getWord32, rts_mkWord32...
+rts_getWord64, rts_mkWord64...
+rts_getPtr, rts_mkPtr...
+rts_getFunPtr, rts_mkFunPtr...
+rts_getFloat, rts_mkFloat...
+rts_getDouble, rts_mkDouble...
+rts_getStablePtr, rts_mkStablePtr...
+rts_getBool, rts_mkBool...
+rts_mkString...
+rts_apply...
+rts_eval...
+rts_eval_...
+rts_evalIO...
+rts_evalStableIOMain...
+rts_evalStableIO...
+rts_evalLazyIO...
+rts_evalLazyIO_...
+rts_setInCallCapability...
+rts_pinThreadToNumaNode...
+Resume the RTS...Resumed
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/daddf2b184bc79fd51823aae83a790acf76020d5
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/daddf2b184bc79fd51823aae83a790acf76020d5
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/20200922/9e35438f/attachment-0001.html>
More information about the ghc-commits
mailing list