[Git][ghc/ghc][wip/ghc-debug_gc_roots] Add rts_listThreads and rts_listMiscRoots to RtsAPI.h

[David Eichmann]

David Eichmann pushed to branch wip/ghc-debug_gc_roots at Glasgow Haskell Compiler / GHC


Commits:
601bf072 by David Eichmann at 2020-11-03T16:22:55+00:00
Add rts_listThreads and rts_listMiscRoots to RtsAPI.h

These are used to find the current roots of the garbage collector.

Co-authored-by: Sven Tennie's avatarSven Tennie <sven.tennie at gmail.com>
Co-authored-by: Matthew Pickering's avatarMatthew Pickering <matthewtpickering at gmail.com>
Co-authored-by: default avatarBen Gamari <bgamari.foss at gmail.com>

- - - - -


6 changed files:

- includes/RtsAPI.h
- rts/RtsAPI.c
- testsuite/tests/rts/pause-resume/all.T
- + testsuite/tests/rts/pause-resume/list_threads_and_misc_roots.hs
- + testsuite/tests/rts/pause-resume/list_threads_and_misc_roots_c.c
- + testsuite/tests/rts/pause-resume/list_threads_and_misc_roots_c.h


Changes:

=====================================
includes/RtsAPI.h
=====================================
@@ -17,6 +17,7 @@ extern "C" {
 
 #include "HsFFI.h"
 #include "rts/Time.h"
+#include "rts/Types.h"
 #include "rts/EventLogWriter.h"
 
 /*
@@ -566,6 +567,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


=====================================
rts/RtsAPI.c
=====================================
@@ -809,6 +809,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 +873,18 @@ bool rts_isPaused()
                "multithreaded RTS.");
     return false;
 }
+
+// See RtsAPI.h
+void rts_listThreads(ListThreadsCb cb, void *user)
+{
+    errorBelch("Warning: rts_listThreads is only possible for multithreaded RTS.");
+}
+
+// See RtsAPI.h
+void rts_listMiscRoots (ListRootsCb cb, void *user)
+{
+    errorBelch("Warning: rts_listMiscRoots is only possible for multithreaded RTS.");
+}
 #endif
 
 void rts_done (void)


=====================================
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


=====================================
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


=====================================
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);
+}


=====================================
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);



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/601bf072e52a92d3e4f21126abe83a93e6d089e4

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/601bf072e52a92d3e4f21126abe83a93e6d089e4
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/20201103/4bf3c4e6/attachment-0001.html>