[Git][ghc/ghc][wip/ghc-debug] 2 commits: Add test list_threads_and_misc_roots (#18405)
Sven Tennie
gitlab at gitlab.haskell.org
Sun Jun 28 14:46:27 UTC 2020
Sven Tennie pushed to branch wip/ghc-debug at Glasgow Haskell Compiler / GHC
Commits:
e23ce495 by Sven Tennie at 2020-06-28T16:44:42+02:00
Add test list_threads_and_misc_roots (#18405)
It uses rts_listThreads() and rts_listMiscRoots().
- - - - -
3ffd67f4 by Sven Tennie at 2020-06-28T16:44:53+02:00
Introduce rts_isPaused() (#18405)
Some operations are only save when the RTS is paused. This predicate
helps to make such checks.
- - - - -
9 changed files:
- includes/RtsAPI.h
- libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs
- 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
- rts/Heap.c
- rts/RtsAPI.c
- testsuite/tests/rts/ghc-debug/pause_and_unpause_thread.c
Changes:
=====================================
includes/RtsAPI.h
=====================================
@@ -504,6 +504,9 @@ RtsPaused rts_pause (void);
// (i.e. myTask() must stay the same).
void rts_unpause (RtsPaused paused);
+// Tells the current state of the RTS regarding rts_pause() and rts_unpause().
+bool rts_isPaused(void);
+
// List all live threads. Must be done while RTS is paused (see rts_pause()).
typedef void (*ListThreadsCb)(void *user, StgTSO *);
void rts_listThreads(ListThreadsCb cb, void *user);
=====================================
libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs
=====================================
@@ -81,7 +81,7 @@ data ClosureType
| SMALL_MUT_ARR_PTRS_FROZEN_CLEAN
| COMPACT_NFDATA
| N_CLOSURE_TYPES
- deriving (Enum, Eq, Ord, Show, Generic)
+ deriving (Enum, Eq, Ord, Show, Generic, Bounded)
-- | Return the size of the closures header in words
closureTypeHeaderSize :: ClosureType -> Int
=====================================
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,72 @@
+{-# 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 FoolClosure
+
+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
+ tsos <- getTSOs_c
+ tsoList <- peekArray tsoCount tsos
+ tsoClosures <- mapM createClosure tsoList
+ assertEqual tsoCount $ length tsoClosures
+ mapM (assertEqual TSO) $ map (tipe . info) tsoClosures
+
+ miscRootsCount <- getMiscRootsCount_c
+ miscRoots <- getMiscRoots_c
+ miscRootsList <- peekArray miscRootsCount miscRoots
+ heapClosures <- mapM createClosure miscRootsList
+ assertEqual miscRootsCount $ length heapClosures
+ -- Regarding the type system, this always has to be True, but we want to
+ -- force evaluation / de-serialization with a simple check.
+ mapM assertIsClosureType $ map (tipe . info) heapClosures
+
+ return ()
+
+createClosure :: Word -> IO (GenClosure Box)
+createClosure tsoPtr = do
+ let wPtr = unpackWord# tsoPtr
+ getClosureData ((unsafeCoerce# wPtr) :: FoolClosure)
+
+unpackWord# :: Word -> Word#
+unpackWord# (W# w#) = w#
+
+assertEqual :: (Show a, Eq a) => a -> a -> IO ()
+assertEqual a b
+ | a /= b = error (show a ++ " /= " ++ show b)
+ | otherwise = return ()
+
+assertIsClosureType :: ClosureType -> IO ()
+assertIsClosureType t
+ | t `elem` enumerate = return ()
+ | otherwise = error (show t ++ " not in " ++ show enumerate)
+ where
+ enumerate :: [ClosureType]
+ enumerate = [minBound..maxBound]
=====================================
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(miscRoots, sizeof(StgClosure*) * 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);
=====================================
rts/Heap.c
=====================================
@@ -247,6 +247,13 @@ static StgWord collect_pointers(StgClosure *closure, StgWord size, StgClosure *p
}
StgArrBytes *heap_view_closurePtrsAsWords(Capability *cap, StgClosure *closure) {
+ if(!rts_isPaused()){
+ errorBelch("Warning: "
+ "The RTS must be paused (see rts_pause()) to inspect it's heap!");
+
+ return NULL;
+ }
+
ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
StgWord size = heap_view_closureSize(closure);
=====================================
rts/RtsAPI.c
=====================================
@@ -672,6 +672,12 @@ void rts_unpause (RtsPaused paused)
freeTask(paused.pausing_task);
}
+// Tells the current state of the RTS regarding rts_pause() and rts_unpause().
+bool rts_isPaused(void)
+{
+ return rts_paused;
+}
+
// Call cb for all StgTSOs. *user is a user defined payload to cb. It's not
// used by the RTS.
// rts_listThreads should only be called when the RTS is paused, i.e. rts_pause
@@ -732,6 +738,13 @@ void rts_unpause (RtsPaused paused STG_UNUSED)
"multithreaded RTS.");
}
+bool rts_isPaused(void)
+{
+ errorBelch("Warning: (Un-) Pausing the RTS is only possible for "
+ "multithreaded RTS.");
+ return false;
+}
+
void rts_listThreads(ListThreadsCb cb STG_UNUSED, void *user STG_UNUSED)
{
=====================================
testsuite/tests/rts/ghc-debug/pause_and_unpause_thread.c
=====================================
@@ -12,6 +12,11 @@ struct PauseTimestamps timestamps = {0, 0};
void* pauseAndUnpause_thread(void* unused){
RtsPaused r_paused = rts_pause();
+ if(!rts_isPaused()) {
+ errorBelch("Expected the RTS to be paused.");
+ exit(1);
+ }
+
timestamps.begin = time(NULL);
sleep(5);
timestamps.end = time(NULL);
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bf6cd82c46e18e7ce0642ff20ab0df928a433759...3ffd67f4d8d977453d7534b2d0dcf21ed2e5deba
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bf6cd82c46e18e7ce0642ff20ab0df928a433759...3ffd67f4d8d977453d7534b2d0dcf21ed2e5deba
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/20200628/9e82647a/attachment-0001.html>
More information about the ghc-commits
mailing list