[Git][ghc/ghc][wip/ghc-debug] 4 commits: Adjust type of getClosureX to type of getClosureDataX (#18405)
Sven Tennie
gitlab at gitlab.haskell.org
Sun Jun 28 15:19:47 UTC 2020
Sven Tennie pushed to branch wip/ghc-debug at Glasgow Haskell Compiler / GHC
Commits:
08ceea79 by Sven Tennie at 2020-06-28T17:17:37+02:00
Adjust type of getClosureX to type of getClosureDataX (#18405)
After a rebase the compiler complained:
libraries/ghc-heap/GHC/Exts/Heap.hs:89:23: error:
• Couldn't match type: a -> IO (Ptr StgInfoTable, [Word], [b])
with: forall c. c -> IO (Ptr StgInfoTable, [Word], [b])
Expected: (forall c. c -> IO (Ptr StgInfoTable, [Word], [b]))
-> a -> IO (GenClosure b)
Actual: (a -> IO (Ptr StgInfoTable, [Word], [b]))
-> a -> IO (GenClosure b)
• In the expression: getClosureX
In an equation for ‘getClosureDataX’: getClosureDataX = getClosureX
In the instance declaration for ‘HasHeapRep a’
• Relevant bindings include
getClosureDataX :: (forall c.
c -> IO (Ptr StgInfoTable, [Word], [b]))
-> a -> IO (GenClosure b)
(bound at libraries/ghc-heap/GHC/Exts/Heap.hs:89:5)
|
89 | getClosureDataX = getClosureX
| ^^^^^^^^^^^
)
- - - - -
f3ea85d8 by Sven Tennie at 2020-06-28T17:18:37+02:00
Add test for rts_pause and rts_unpause (#18405)
- - - - -
6788b9b6 by Sven Tennie at 2020-06-28T17:18:46+02:00
Add test list_threads_and_misc_roots (#18405)
It uses rts_listThreads() and rts_listMiscRoots().
- - - - -
f1b38f6b by Sven Tennie at 2020-06-28T17:18:46+02:00
Introduce rts_isPaused() (#18405)
Some operations are only save when the RTS is paused. This predicate
helps to make such checks.
- - - - -
13 changed files:
- includes/RtsAPI.h
- libraries/ghc-heap/GHC/Exts/Heap.hs
- 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/all.T
- + testsuite/tests/rts/ghc-debug/pause_and_unpause.hs
- + testsuite/tests/rts/ghc-debug/pause_and_unpause_thread.c
- + testsuite/tests/rts/ghc-debug/pause_and_unpause_thread.h
Changes:
=====================================
includes/RtsAPI.h
=====================================
@@ -492,14 +492,27 @@ typedef struct RtsPaused_ {
Capability *capabilities;
} RtsPaused;
+// Halt execution of all Haskell threads.
+// It is different to rts_lock because it pauses all capabilities. rts_lock
+// only pauses a single capability.
+// rts_pause() and rts_unpause() have to be executed from the same OS thread
+// (i.e. myTask() must stay the same).
RtsPaused rts_pause (void);
+
+// Counterpart of rts_pause: Continue from a pause.
+// rts_pause() and rts_unpause() have to be executed from the same OS thread
+// (i.e. myTask() must stay the same).
void rts_unpause (RtsPaused paused);
-// List all live threads. Must be done while RTS is 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);
-// List all non-thread GC roots. Must be done while RTS is paused.
+// List all non-thread GC roots. Must be done while RTS is paused (see
+// rts_pause()).
typedef void (*ListRootsCb)(void *user, StgClosure *);
void rts_listMiscRoots(ListRootsCb cb, void *user);
=====================================
libraries/ghc-heap/GHC/Exts/Heap.hs
=====================================
@@ -166,14 +166,14 @@ getClosureData = getClosureDataX getClosureRaw
-- @collect_pointers()@ in @rts/Heap.c at .
--
-- For most use cases 'getClosureData' is an easier to use alternative.
-getClosureX :: forall a b .
- (a -> IO (Ptr StgInfoTable, [Word], [b]))
+getClosureX :: forall a b.
+ (forall c . c -> IO (Ptr StgInfoTable, [Word], [b]))
-- ^ Helper function to get info table, memory and pointers of the
-- closure
-> a -- ^ Closure to decode
-> IO (GenClosure b) -- ^ Heap representation of the closure
getClosureX get_closure_raw x = do
- (iptr, wds, pts) <- get_closure_raw x
+ (iptr, wds, pts) <- get_closure_raw (unsafeCoerce# x)
itbl <- peekItbl iptr
-- The remaining words after the header
let rawWds = drop (closureTypeHeaderSize (tipe itbl)) wds
=====================================
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
=====================================
@@ -651,6 +651,8 @@ static bool rts_paused = false;
// Halt execution of all Haskell threads.
// It is different to rts_lock because it pauses all capabilities. rts_lock
// only pauses a single capability.
+// rts_pause() and rts_unpause() have to be executed from the same OS thread
+// (i.e. myTask() must stay the same).
RtsPaused rts_pause (void)
{
struct RtsPaused_ paused;
@@ -661,6 +663,8 @@ RtsPaused rts_pause (void)
}
// Counterpart of rts_pause: Continue from a pause.
+// rts_pause() and rts_unpause() have to be executed from the same OS thread
+// (i.e. myTask() must stay the same).
void rts_unpause (RtsPaused paused)
{
rts_paused = false;
@@ -668,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
@@ -728,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/all.T
=====================================
@@ -0,0 +1,6 @@
+test('pause_and_unpause',
+ [ extra_files(['pause_and_unpause_thread.c','pause_and_unpause_thread.h']),
+ ignore_stdout,
+ ignore_stderr
+ ],
+ multi_compile_and_run, ['pause_and_unpause', [('pause_and_unpause_thread.c','')], '-threaded'])
=====================================
testsuite/tests/rts/ghc-debug/pause_and_unpause.hs
=====================================
@@ -0,0 +1,73 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+import Data.Word
+import Data.IORef
+import GHC.Clock
+import Control.Concurrent
+import Foreign.C.Types
+import System.Mem
+import Control.Monad
+
+foreign import ccall safe "pause_and_unpause_thread.h pauseAndUnpause"
+ pauseAndUnpause_c :: IO ()
+
+foreign import ccall safe "pause_and_unpause_thread.h getUnixTime"
+ getUnixTime_c :: IO CTime
+
+foreign import ccall safe "pause_and_unpause_thread.h getPauseBegin"
+ getPauseBegin_c :: IO CTime
+
+foreign import ccall safe "pause_and_unpause_thread.h getPauseEnd"
+ getPauseEnd_c :: IO CTime
+
+clockEachSecond :: IORef [CTime] -> IO ()
+clockEachSecond ref = forever $ do
+ time <- getUnixTime_c
+ timesList <- readIORef ref
+ writeIORef ref $ time : timesList
+
+ sleepSeconds 1
+
+{- To show that rts_pause() and rts_unpause() work, clockEachSecond adds the
+current unix time to a list (once per Second). pauseAndUnpause_c stops the RTS
+for 5 Seconds. Thus there's an invariant that there should be no timestamp in
+the list that is in this 5 Seconds wide timeframe, which is defined by
+getPauseBegin_c and getPauseEnd_c. -}
+main :: IO ()
+main = do
+ ref <- newIORef []
+ forkIO $ clockEachSecond ref
+
+ sleepSeconds 3
+
+ pauseAndUnpause_c
+
+ -- This seems to sleep for 8 - 5 Seconds. That's strange, but should be
+ -- good enough for this test.
+ -- 5 Seconds is the time the whole RTS is paused. But I (Sven) don't
+ -- understand how this relates.
+ sleepSeconds 8
+
+ times <- readIORef ref
+
+ pauseBegin <- getPauseBegin_c
+ pauseEnd <- getPauseEnd_c
+ filter (\t -> pauseBegin < t && t < pauseEnd) times `shouldBe` []
+ filter (\t -> t <= pauseBegin) times `shouldNotBe` []
+ filter (\t -> t >= pauseEnd) times `shouldNotBe` []
+
+ return ()
+
+sleepSeconds :: Int -> IO ()
+sleepSeconds t = threadDelay $ oneSecondInMicroSeconds * t
+
+oneSecondInMicroSeconds :: Int
+oneSecondInMicroSeconds = 1000000
+
+shouldBe :: (Eq a, Show a) => a -> a -> IO ()
+shouldBe x y =
+ unless (x == y) $ fail $ show x ++ " is not equal to " ++ show y
+
+shouldNotBe :: (Eq a, Show a) => a -> a -> IO ()
+shouldNotBe x y =
+ unless (x /= y) $ fail $ show x ++ " is equal to " ++ show y
=====================================
testsuite/tests/rts/ghc-debug/pause_and_unpause_thread.c
=====================================
@@ -0,0 +1,45 @@
+#include <pthread.h>
+#include <time.h>
+#include <unistd.h>
+#include "pause_and_unpause_thread.h"
+#include "Rts.h"
+#include "RtsAPI.h"
+
+#include <stdio.h>
+
+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);
+
+ rts_unpause(r_paused);
+
+ return NULL;
+}
+
+void pauseAndUnpause(void){
+ pthread_t threadId;
+ pthread_create(&threadId, NULL, &pauseAndUnpause_thread, NULL);
+ pthread_detach(threadId);
+}
+
+time_t getPauseBegin(void) {
+ return timestamps.begin;
+}
+
+time_t getPauseEnd(void) {
+ return timestamps.end;
+}
+
+time_t getUnixTime(void){
+ return time(NULL);
+}
=====================================
testsuite/tests/rts/ghc-debug/pause_and_unpause_thread.h
=====================================
@@ -0,0 +1,11 @@
+#include <time.h>
+
+struct PauseTimestamps{
+ time_t begin;
+ time_t end;
+};
+
+void pauseAndUnpause(void);
+time_t getPauseBegin(void);
+time_t getPauseEnd(void);
+time_t getUnixTime(void);
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fe5414693d1875e83b1c3cf70f9a2236ce1c599e...f1b38f6ba2124210127b2629fdc08a27ddc313ad
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fe5414693d1875e83b1c3cf70f9a2236ce1c599e...f1b38f6ba2124210127b2629fdc08a27ddc313ad
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/cd6fe60a/attachment-0001.html>
More information about the ghc-commits
mailing list