[Git][ghc/ghc][wip/ghc-debug] Add test list_threads_and_misc_roots

[Sven Tennie]

Sven Tennie pushed to branch wip/ghc-debug at Glasgow Haskell Compiler / GHC


Commits:
ff9ddba9 by Sven Tennie at 2020-06-25T20:24:34+02:00
Add test list_threads_and_misc_roots

This uses rts_listThreads() and rts_listMiscRoots().

- - - - -


4 changed files:

- libraries/ghc-heap/tests/all.T
- + libraries/ghc-heap/tests/list_threads_and_misc_roots.hs
- + libraries/ghc-heap/tests/list_threads_and_misc_roots_c.c
- + libraries/ghc-heap/tests/list_threads_and_misc_roots_c.h


Changes:

=====================================
libraries/ghc-heap/tests/all.T
=====================================
@@ -42,3 +42,10 @@ test('tso_and_stack_closures',
       ignore_stderr
      ],
      multi_compile_and_run, ['tso_and_stack_closures', [('create_tso.c','')], ''])
+
+test('list_threads_and_misc_roots',
+     [extra_files(['list_threads_and_misc_roots_c.c','list_threads_and_misc_roots_c.h']),
+      ignore_stdout,
+      ignore_stderr
+     ],
+     multi_compile_and_run, ['list_threads_and_misc_roots', [('list_threads_and_misc_roots_c.c','')], '-threaded'])


=====================================
libraries/ghc-heap/tests/list_threads_and_misc_roots.hs
=====================================
@@ -0,0 +1,58 @@
+{-# LANGUAGE MagicHash #-}
+
+import Foreign.Ptr
+import Foreign.Marshal.Array
+import GHC.IORef
+import Control.Concurrent
+import GHC.Exts.Heap
+import GHC.Exts
+
+
+-- Invent a type to bypass the type constraints of getClosureData.
+-- Infact this will be a Word#, that is directly given to unpackClosure#
+-- (which is a primop that expects a pointer to a closure).
+data FoolStgTSO
+
+foreign import ccall safe "list_threads_and_misc_roots_c.h listThreadsAndMiscRoots"
+    listThreadsAndMiscRoots_c :: IO ()
+
+foreign import ccall safe "list_threads_and_misc_roots_c.h getTSOCount"
+    getTSOCount_c :: IO Int
+
+foreign import ccall safe "list_threads_and_misc_roots_c.h getTSOs"
+    getTSOs_c :: IO (Ptr Word)
+
+foreign import ccall safe "list_threads_and_misc_roots_c.h getMiscRootsCount"
+    getMiscRootsCount_c :: IO Int
+
+foreign import ccall safe "list_threads_and_misc_roots_c.h getMiscRoots"
+    getMiscRoots_c :: IO (Ptr Word)
+
+main :: IO ()
+main = do
+    listThreadsAndMiscRoots_c
+    tsoCount <- getTSOCount_c
+    print tsoCount
+    tsos <- getTSOs_c
+    tsoList <- peekArray tsoCount tsos
+    tsoClosures <- sequence $ map createClosure tsoList
+    print tsoClosures
+    -- TODO: assert...
+
+    miscRootsCount <- getMiscRootsCount_c
+    print miscRootsCount
+    miscRoots <- getMiscRoots_c
+    miscRootsList <- peekArray miscRootsCount miscRoots
+    heapClosures <- sequence $ map createClosure miscRootsList
+    print heapClosures
+    -- TODO: assert...
+
+    return ()
+
+createClosure :: Word -> IO (GenClosure Box)
+createClosure tsoPtr = do
+    let wPtr = unpackWord# tsoPtr
+    getClosureData ((unsafeCoerce# wPtr) :: FoolStgTSO)
+
+unpackWord# :: Word -> Word#
+unpackWord# (W# w#) = w#


=====================================
libraries/ghc-heap/tests/list_threads_and_misc_roots_c.c
=====================================
@@ -0,0 +1,54 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include "Rts.h"
+#include "RtsAPI.h"
+#include "list_threads_and_misc_roots_c.h"
+
+int tsoCount = 0;
+StgTSO** tsos;
+
+int miscRootsCount = 0;
+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(tsos, sizeof(StgTSO*) * miscRootsCount);
+    miscRoots[miscRootsCount-1] = closure;
+}
+
+void* listThreads_thread(void* unused){
+    RtsPaused paused = rts_pause();
+    rts_listThreads(&collectTSOsCallback, NULL);
+    rts_listMiscRoots(&collectMiscRootsCallback, NULL);
+    rts_unpause(paused);
+
+    return NULL;
+}
+
+void listThreadsAndMiscRoots(void){
+    pthread_t threadId;
+    pthread_create(&threadId, NULL, &listThreads_thread, NULL);
+    pthread_join(threadId, NULL);
+}
+
+int getTSOCount(void){
+    return tsoCount;
+}
+
+StgTSO** getTSOs(void){
+    return tsos;
+}
+
+int getMiscRootsCount(void){
+    return miscRootsCount;
+}
+
+StgClosure** getMiscRoots(void){
+    return miscRoots;
+}


=====================================
libraries/ghc-heap/tests/list_threads_and_misc_roots_c.h
=====================================
@@ -0,0 +1,11 @@
+#include "Rts.h"
+
+void listThreadsAndMiscRoots(void);
+
+int getTSOCount(void);
+
+StgTSO** getTSOs(void);
+
+int getMiscRootsCount(void);
+
+StgClosure** getMiscRoots(void);



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ff9ddba9f4afca9b099c13724f9ef7fec4b4aa2a
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/20200625/ead2cc70/attachment-0001.html>