summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--includes/RtsAPI.h12
-rw-r--r--rts/RtsAPI.c53
-rw-r--r--testsuite/tests/rts/pause-resume/all.T5
-rw-r--r--testsuite/tests/rts/pause-resume/list_threads_and_misc_roots.hs6
-rw-r--r--testsuite/tests/rts/pause-resume/list_threads_and_misc_roots_c.c54
-rw-r--r--testsuite/tests/rts/pause-resume/list_threads_and_misc_roots_c.h5
6 files changed, 135 insertions, 0 deletions
diff --git a/includes/RtsAPI.h b/includes/RtsAPI.h
index 6c782e504a..36ab4d4b04 100644
--- a/includes/RtsAPI.h
+++ b/includes/RtsAPI.h
@@ -17,8 +17,10 @@ extern "C" {
#include "HsFFI.h"
#include "rts/Time.h"
+#include "rts/Types.h"
#include "rts/EventLogWriter.h"
+
/*
* Running the scheduler
*/
@@ -566,6 +568,16 @@ void rts_resume (PauseToken *pauseToken);
// Returns true if the rts is paused. See rts_pause() and rts_resume().
bool rts_isPaused(void);
+// List all live threads. The RTS must be paused and this must be called on the
+// same thread that called rts_pause().
+typedef void (*ListThreadsCb)(void *user, StgTSO *);
+void rts_listThreads(ListThreadsCb cb, void *user);
+
+// List all non-thread GC roots. The RTS must be paused and this must be called
+// on the same thread that called rts_pause().
+typedef void (*ListRootsCb)(void *user, StgClosure *);
+void rts_listMiscRoots(ListRootsCb cb, void *user);
+
/*
* The RTS allocates some thread-local data when you make a call into
* Haskell using one of the rts_eval() functions. This data is not
diff --git a/rts/RtsAPI.c b/rts/RtsAPI.c
index bf58f53735..aaea838f72 100644
--- a/rts/RtsAPI.c
+++ b/rts/RtsAPI.c
@@ -15,6 +15,7 @@
#include "Prelude.h"
#include "Schedule.h"
#include "Capability.h"
+#include "StableName.h"
#include "StablePtr.h"
#include "Threads.h"
#include "Weak.h"
@@ -809,6 +810,46 @@ static void assert_isPausedOnMyTask(const char *functionName)
}
}
+// See RtsAPI.h
+void rts_listThreads(ListThreadsCb cb, void *user)
+{
+ assert_isPausedOnMyTask("rts_listThreads");
+
+ // The rts is paused and can only be resumed by the current thread. Hence it
+ // is safe to read global thread data.
+
+ for (uint32_t g=0; g < RtsFlags.GcFlags.generations; g++) {
+ StgTSO *tso = generations[g].threads;
+ while (tso != END_TSO_QUEUE) {
+ cb(user, tso);
+ tso = tso->global_link;
+ }
+ }
+}
+
+struct list_roots_ctx {
+ ListRootsCb cb;
+ void *user;
+};
+
+// This is an evac_fn.
+static void list_roots_helper(void *user, StgClosure **p) {
+ struct list_roots_ctx *ctx = (struct list_roots_ctx *) user;
+ ctx->cb(ctx->user, *p);
+}
+
+// See RtsAPI.h
+void rts_listMiscRoots (ListRootsCb cb, void *user)
+{
+ assert_isPausedOnMyTask("rts_listMiscRoots");
+
+ struct list_roots_ctx ctx;
+ ctx.cb = cb;
+ ctx.user = user;
+
+ threadStableNameTable(&list_roots_helper, (void *)&ctx);
+ threadStablePtrTable(&list_roots_helper, (void *)&ctx);
+}
#else
PauseToken GNU_ATTRIBUTE(__noreturn__)
@@ -833,6 +874,18 @@ bool rts_isPaused()
"multithreaded RTS.");
return false;
}
+
+// See RtsAPI.h
+void rts_listThreads(ListThreadsCb cb STG_UNUSED, void *user STG_UNUSED)
+{
+ errorBelch("Warning: rts_listThreads is only possible for multithreaded RTS.");
+}
+
+// See RtsAPI.h
+void rts_listMiscRoots (ListRootsCb cb STG_UNUSED, void *user STG_UNUSED)
+{
+ errorBelch("Warning: rts_listMiscRoots is only possible for multithreaded RTS.");
+}
#endif
void rts_done (void)
diff --git a/testsuite/tests/rts/pause-resume/all.T b/testsuite/tests/rts/pause-resume/all.T
index 3099a8f12c..88c6f6e483 100644
--- a/testsuite/tests/rts/pause-resume/all.T
+++ b/testsuite/tests/rts/pause-resume/all.T
@@ -18,3 +18,8 @@ test('pause_and_use_rts_api',
, extra_files(['pause_resume.c','pause_resume.h'])
],
multi_compile_and_run, ['pause_and_use_rts_api', [('pause_resume.c','')], ''])
+test('list_threads_and_misc_roots',
+ [ only_ways(['threaded1', 'threaded2'])
+ , extra_files(['list_threads_and_misc_roots_c.c','list_threads_and_misc_roots_c.h'])
+ ],
+ multi_compile_and_run, ['list_threads_and_misc_roots', [('list_threads_and_misc_roots_c.c','')], '']) \ No newline at end of file
diff --git a/testsuite/tests/rts/pause-resume/list_threads_and_misc_roots.hs b/testsuite/tests/rts/pause-resume/list_threads_and_misc_roots.hs
new file mode 100644
index 0000000000..1de3fa926b
--- /dev/null
+++ b/testsuite/tests/rts/pause-resume/list_threads_and_misc_roots.hs
@@ -0,0 +1,6 @@
+
+foreign import ccall safe "list_threads_and_misc_roots_c.h checkGcRoots"
+ checkGcRoots :: IO ()
+
+main :: IO ()
+main = checkGcRoots
diff --git a/testsuite/tests/rts/pause-resume/list_threads_and_misc_roots_c.c b/testsuite/tests/rts/pause-resume/list_threads_and_misc_roots_c.c
new file mode 100644
index 0000000000..634bab75e2
--- /dev/null
+++ b/testsuite/tests/rts/pause-resume/list_threads_and_misc_roots_c.c
@@ -0,0 +1,54 @@
+
+#include "list_threads_and_misc_roots_c.h"
+
+static int tsoCount = 0;
+static StgTSO** tsos;
+
+static int miscRootsCount = 0;
+static StgClosure** miscRoots;
+
+void collectTSOsCallback(void *user, StgTSO* tso){
+ tsoCount++;
+ tsos = realloc(tsos, sizeof(StgTSO*) * tsoCount);
+ tsos[tsoCount - 1] = tso;
+}
+
+void collectMiscRootsCallback(void *user, StgClosure* closure){
+ miscRootsCount++;
+ miscRoots = realloc(miscRoots, sizeof(StgClosure*) * miscRootsCount);
+ miscRoots[miscRootsCount - 1] = closure;
+}
+
+void checkGcRoots(void)
+{
+ PauseToken * token = rts_pause();
+
+ // Check TSO collection.
+ rts_listThreads(&collectTSOsCallback, NULL);
+ for (int i = 0; i < tsoCount; i++)
+ {
+ StgTSO *tso = UNTAG_CLOSURE(tsos[i]);
+ if (get_itbl(tso)->type != TSO)
+ {
+ fprintf(stderr, "tso returned a non-TSO type %zu at index %i\n",
+ tso->header.info->type,
+ i);
+ exit(1);
+ }
+ }
+
+ // Check misc GC roots collection.
+ rts_listMiscRoots(&collectMiscRootsCallback, NULL);
+ for (int i = 0; i < miscRootsCount; i++)
+ {
+ StgClosure *root = UNTAG_CLOSURE(miscRoots[i]);
+ if (get_itbl(root)->type == TSO)
+ {
+ fprintf(stderr, "rts_listThreads unexpectedly returned an TSO type at index %i (TSO=%zu)\n", i, TSO);
+ exit(1);
+ }
+ }
+
+
+ rts_resume(token);
+}
diff --git a/testsuite/tests/rts/pause-resume/list_threads_and_misc_roots_c.h b/testsuite/tests/rts/pause-resume/list_threads_and_misc_roots_c.h
new file mode 100644
index 0000000000..408c3a79ca
--- /dev/null
+++ b/testsuite/tests/rts/pause-resume/list_threads_and_misc_roots_c.h
@@ -0,0 +1,5 @@
+
+#include "Rts.h"
+#include "RtsAPI.h"
+
+void checkGcRoots(void);