[Git][ghc/ghc][wip/ghc-debug] 8 commits: Add test for StgTSO decoding (#18405)
Sven Tennie
gitlab at gitlab.haskell.org
Sun Jun 28 15:28:12 UTC 2020
Sven Tennie pushed to branch wip/ghc-debug at Glasgow Haskell Compiler / GHC
Commits:
595d363c by Sven Tennie at 2020-06-28T17:24:47+02:00
Add test for StgTSO decoding (#18405)
This makes sure ghc-heap decodes StgTSO and StgStack correctly.
To assert - otherwise dynamic - properties, a new, non-running TSO is
created in create_tso() (create_tso.c).
size is renamed to stack_size to use a dedicated type.
size was already defined as a HalfWord in GenClosure, which is
only equivalent to Word32 on 64bit architectures.
- - - - -
b09b0816 by Sven Tennie at 2020-06-28T17:27:15+02:00
Revert changes to TSO.h
The memory layout of StgTSO isn't significant anymore as we decode it
with hsc2hs.
(Of course the basic structure of a closure with an info table must be
still in place, but that's not touched by this commit.)
- - - - -
5d3904e2 by Sven Tennie at 2020-06-28T17:27:15+02:00
Add some documentation
- - - - -
dc93991c by Sven Tennie at 2020-06-28T17:27:15+02:00
Add/update documentation for FindPtrCb
- - - - -
109bdf57 by Sven Tennie at 2020-06-28T17:27:15+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
| ^^^^^^^^^^^
)
- - - - -
5f47e2ed by Sven Tennie at 2020-06-28T17:27:15+02:00
Add test for rts_pause and rts_unpause (#18405)
- - - - -
8d8410e9 by Sven Tennie at 2020-06-28T17:27:15+02:00
Add test list_threads_and_misc_roots (#18405)
It uses rts_listThreads() and rts_listMiscRoots().
- - - - -
32a06874 by Sven Tennie at 2020-06-28T17:27:15+02:00
Introduce rts_isPaused() (#18405)
Some operations are only save when the RTS is paused. This predicate
helps to make such checks.
- - - - -
19 changed files:
- includes/RtsAPI.h
- includes/rts/storage/TSO.h
- libraries/ghc-heap/GHC/Exts/Heap.hs
- libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- libraries/ghc-heap/tests/all.T
- + libraries/ghc-heap/tests/create_tso.c
- + libraries/ghc-heap/tests/create_tso.h
- + 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
- + libraries/ghc-heap/tests/tso_and_stack_closures.hs
- rts/Heap.c
- rts/Printer.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);
=====================================
includes/rts/storage/TSO.h
=====================================
@@ -107,22 +107,6 @@ typedef struct StgTSO_ {
*/
struct StgStack_ *stackobj;
- struct InCall_ *bound;
- struct Capability_ *cap;
-
- struct StgTRecHeader_ *trec; /* STM transaction record */
-
- /*
- * A list of threads blocked on this TSO waiting to throw exceptions.
- */
- struct MessageThrowTo_ *blocked_exceptions;
-
- /*
- * A list of StgBlockingQueue objects, representing threads
- * blocked on thunks that are under evaluation by this thread.
- */
- struct StgBlockingQueue_ *bq;
-
/*
* The tso->dirty flag indicates that this TSO's stack should be
* scanned during garbage collection. It also indicates that this
@@ -144,6 +128,21 @@ typedef struct StgTSO_ {
StgThreadID id;
StgWord32 saved_errno;
StgWord32 dirty; /* non-zero => dirty */
+ struct InCall_* bound;
+ struct Capability_* cap;
+
+ struct StgTRecHeader_ * trec; /* STM transaction record */
+
+ /*
+ * A list of threads blocked on this TSO waiting to throw exceptions.
+ */
+ struct MessageThrowTo_ * blocked_exceptions;
+
+ /*
+ * A list of StgBlockingQueue objects, representing threads
+ * blocked on thunks that are under evaluation by this thread.
+ */
+ struct StgBlockingQueue_ *bq;
/*
* The allocation limit for this thread, which is updated as the
=====================================
libraries/ghc-heap/GHC/Exts/Heap.hs
=====================================
@@ -79,9 +79,11 @@ class HasHeapRep (a :: TYPE rep) where
-- 'Word' for "raw" usage of pointers.
getClosureDataX ::
(forall c . c -> IO (Ptr StgInfoTable, [Word], [b]))
- -- ^ Helper function to get info table, memory and pointers of the closure
+ -- ^ Helper function to get info table, memory and pointers of the
+ -- closure. The order of @[b]@ is significant and determined by
+ -- @collect_pointers()@ in @rts/Heap.c at .
-> a -- ^ Closure to decode
- -> IO (GenClosure b) -- Heap representation of the closure
+ -> IO (GenClosure b) -- ^ Heap representation of the closure
instance HasHeapRep (a :: TYPE 'LiftedRep) where
getClosureDataX = getClosureX
@@ -150,14 +152,28 @@ getClosureData :: forall rep (a :: TYPE rep) . HasHeapRep a => a -> IO Closure
getClosureData = getClosureDataX getClosureRaw
--- | This function returns a parsed heap representation of the argument _at
--- this moment_, even if it is unevaluated or an indirection or other exotic
--- stuff. Beware when passing something to this function, the same caveats as
--- for 'asBox' apply.
-getClosureX :: forall a b . (a -> IO (Ptr StgInfoTable, [Word], [b]))
- -> a -> IO (GenClosure b)
+-- | This function returns a parsed heap representation ('GenClosure') of the
+-- closure _at this moment_, even if it is unevaluated or an indirection or
+-- other exotic stuff. Beware when passing something to this function, the same
+-- caveats as for 'asBox' apply.
+--
+-- Inside a GHC context 'b' is usually a 'GHC.Exts.Heap.Closures.Box'
+-- containing a thunk or an evaluated heap object. Outside it can be a
+-- 'Word' for "raw" usage of pointers.
+--
+-- 'get_closure_raw' should provide low level details of the closure's heap
+-- respresentation. The order of @[b]@ is significant and determined by
+-- @collect_pointers()@ in @rts/Heap.c at .
+--
+-- For most use cases 'getClosureData' is an easier to use alternative.
+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
@@ -341,7 +357,7 @@ getClosureX get_closure_raw x = do
pure $ StackClosure
{ info = itbl
- , size = FFIClosures.stack_size fields
+ , stack_size = FFIClosures.stack_size fields
, stack_dirty = FFIClosures.stack_dirty fields
, stackPointer = (pts !! 0)
, stack = FFIClosures.stack fields
=====================================
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/GHC/Exts/Heap/Closures.hs
=====================================
@@ -285,7 +285,7 @@ data GenClosure b
-- Representation of StgStack: The 'tsoStack' of a 'TSOClosure'.
| StackClosure
{ info :: !StgInfoTable
- , size :: !Word32 -- ^ stack size in *words*
+ , stack_size :: !Word32 -- ^ stack size in *words*
, stack_dirty :: !Word8 -- ^ non-zero => dirty
#if __GLASGOW_HASKELL__ >= 811
, stack_marking :: Word8
=====================================
libraries/ghc-heap/tests/all.T
=====================================
@@ -36,3 +36,16 @@ test('closure_size_noopt',
],
compile_and_run, [''])
+test('tso_and_stack_closures',
+ [extra_files(['create_tso.c','create_tso.h']),
+ ignore_stdout,
+ 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/create_tso.c
=====================================
@@ -0,0 +1,10 @@
+#include "Rts.h"
+#include "RtsAPI.h"
+
+StgTSO* create_tso(){
+ HaskellObj trueClosure = rts_mkBool(&MainCapability, 1);
+
+ StgTSO * tso = createGenThread(&MainCapability, 500U, trueClosure);
+
+ return tso;
+}
=====================================
libraries/ghc-heap/tests/create_tso.h
=====================================
@@ -0,0 +1,3 @@
+#include "RtsAPI.h"
+
+StgTSO* create_tso();
=====================================
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);
=====================================
libraries/ghc-heap/tests/tso_and_stack_closures.hs
=====================================
@@ -0,0 +1,77 @@
+{-# LANGUAGE ForeignFunctionInterface, MagicHash, CPP, BangPatterns #-}
+
+import Foreign
+import Foreign.C.Types
+import GHC.Exts.Heap
+import GHC.Exts
+
+import GHC.Word
+
+#include "ghcconfig.h"
+#include "rts/Constants.h"
+
+foreign import ccall unsafe "create_tso.h create_tso"
+ c_create_tso:: IO Word
+
+-- 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
+
+-- We can make some assumptions about the - otherwise dynamic - properties of
+-- StgTSO and StgStack, because a new, non-running TSO is created with
+-- create_tso() (create_tso.c).create_tso
+main :: IO ()
+main = do
+ tso <- createTSOClosure
+ assertEqual (what_next tso) ThreadRunGHC
+ assertEqual (why_blocked tso) NotBlocked
+ assertEqual (saved_errno tso) 0
+
+ print $ "tso : "++ show tso
+
+ -- The newly created TSO should be on the end of the run queue.
+ let !_linkBox = _link tso
+ _linkClosure <- getBoxedClosureData _linkBox
+ assertEqual (name _linkClosure) "END_TSO_QUEUE"
+
+ let !global_linkBox = global_link tso
+ globalLinkClosure <- getBoxedClosureData global_linkBox
+ assertEqual (getClosureType globalLinkClosure) TSO
+
+ let !stackBox = tsoStack tso
+ stackClosure <- getBoxedClosureData stackBox
+ assertEqual (getClosureType stackClosure) STACK
+
+ let !stackPointerBox = stackPointer stackClosure
+ stackPointerClosure <- getBoxedClosureData stackPointerBox
+ assertEqual (getClosureType stackPointerClosure) RET_SMALL
+
+ let !trecBox = trec tso
+ trecClosure <- getBoxedClosureData trecBox
+ assertEqual (name trecClosure) "NO_TREC"
+
+ let !blockedExceptionsBox = blocked_exceptions tso
+ blockedExceptionsClosure <- getBoxedClosureData blockedExceptionsBox
+ assertEqual (name blockedExceptionsClosure) "END_TSO_QUEUE"
+
+ let !bqBox = bq tso
+ bqClosure <- getBoxedClosureData bqBox
+ assertEqual (name bqClosure) "END_TSO_QUEUE"
+
+createTSOClosure :: IO (GenClosure Box)
+createTSOClosure = do
+ ptr <- c_create_tso
+ let wPtr = unpackWord# ptr
+ getClosureData ((unsafeCoerce# wPtr) :: FoolStgTSO)
+
+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 ()
+
+getClosureType :: GenClosure b -> ClosureType
+getClosureType = tipe . info
=====================================
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/Printer.c
=====================================
@@ -852,10 +852,12 @@ extern void DEBUG_LoadSymbols( const char *name STG_UNUSED )
#endif /* USING_LIBBFD */
-// findPtr takes a callback so external tools such as ghc-debug can invoke it
-// and intercept the intermediate results. When findPtr successfully finds
-// a closure containing an address then the callback is called on the address
-// of that closure. The `StgClosure` argument is an untagged closure pointer.
+// findPtrCb takes a callback of type FindPtrCb, so external tools (such as
+// ghc-debug) can invoke it and intercept the intermediate results.
+// When findPtrCb successfully finds a closure containing an address then the
+// callback is called on the address of that closure.
+// The `StgClosure` argument is an untagged closure pointer.
+// `user` points to any data provided by the caller. It's not used internally.
typedef void (*FindPtrCb)(void *user, StgClosure *);
void findPtr(P_ p, int); /* keep gcc -Wall happy */
@@ -949,11 +951,14 @@ findPtr_gen(FindPtrCb cb, void *user, P_ p, int follow)
}
}
-void
-findPtr(P_ p, int follow){
+// Special case of findPtrCb: Uses a default callback, that prints the closure
+// pointed to by p.
+void findPtr(P_ p, int follow){
findPtr_gen(&findPtr_default_callback, NULL, p, follow);
}
+// Call cb on the closure pointed to by p.
+// FindPtrCb is documented where it's defined.
void findPtrCb(FindPtrCb cb, void* user, P_ p){
findPtr_gen(cb, user, p, 0);
}
=====================================
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/f1b38f6ba2124210127b2629fdc08a27ddc313ad...32a068747a3b45564259a9151d7c6f3398b548cc
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f1b38f6ba2124210127b2629fdc08a27ddc313ad...32a068747a3b45564259a9151d7c6f3398b548cc
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/0f936588/attachment-0001.html>
More information about the ghc-commits
mailing list