[Git][ghc/ghc][wip/ghc-debug] Add a test for rts_pause and rts_unpause

[Sven Tennie]

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


Commits:
3e3f488f by Sven Tennie at 2020-06-21T18:27:44+02:00
Add a test for rts_pause and rts_unpause

- - - - -


6 changed files:

- includes/RtsAPI.h
- 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,24 @@ 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.
+// 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);
 


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


=====================================
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','-optc=-g3 -optc=-O0 -opta=-g')], '-threaded -debug -O0 -g'])


=====================================
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,40 @@
+#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();
+
+    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() {
+    return timestamps.begin;
+}
+
+time_t getPauseEnd() {
+    return timestamps.end;
+}
+
+time_t getUnixTime(){
+    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();
+time_t getPauseEnd();
+time_t getUnixTime();



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3e3f488ff095b11d534097d4e3a9483f3b5ddbaa
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/20200621/9d8aac11/attachment-0001.html>