[Git][ghc/ghc][wip/ghc-debug] Add tests for calling ghc-debug API via safe/unsafe FFI call and via a new thread

[David Eichmann]

David Eichmann pushed to branch wip/ghc-debug at Glasgow Haskell Compiler / GHC


Commits:
47b915a1 by David Eichmann at 2020-09-17T15:02:11+01:00
Add tests for calling ghc-debug API via safe/unsafe FFI call and via a new thread

- - - - -


6 changed files:

- testsuite/tests/rts/ghc-debug/all.T
- testsuite/tests/rts/ghc-debug/pause_and_unpause.hs → testsuite/tests/rts/ghc-debug/rts_pause_and_unpause.hs
- testsuite/tests/rts/ghc-debug/pause_and_unpause_thread.c → testsuite/tests/rts/ghc-debug/rts_pause_and_unpause_c.c
- testsuite/tests/rts/ghc-debug/pause_and_unpause_thread.h → testsuite/tests/rts/ghc-debug/rts_pause_and_unpause_c.h
- + testsuite/tests/rts/ghc-debug/shouldfail/all.T
- + testsuite/tests/rts/ghc-debug/shouldfail/unsafe_rts_pause.hs


Changes:

=====================================
testsuite/tests/rts/ghc-debug/all.T
=====================================
@@ -1,6 +1,6 @@
-test('pause_and_unpause',
-     [ extra_files(['pause_and_unpause_thread.c','pause_and_unpause_thread.h']),
+test('rts_pause_and_unpause',
+     [ extra_files(['rts_pause_and_unpause_c.c','rts_pause_and_unpause_c.h']),
       ignore_stdout,
       ignore_stderr
      ],
-     multi_compile_and_run, ['pause_and_unpause', [('pause_and_unpause_thread.c','')], '-threaded'])
+     multi_compile_and_run, ['rts_pause_and_unpause', [('rts_pause_and_unpause_c.c','')], '-threaded '])
\ No newline at end of file


=====================================
testsuite/tests/rts/ghc-debug/pause_and_unpause.hs → testsuite/tests/rts/ghc-debug/rts_pause_and_unpause.hs
=====================================
@@ -8,23 +8,30 @@ 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 "rts_pause_and_unpause_c.h pauseAndUnpause"
+    safe_pauseAndUnpause_c :: IO ()
 
-foreign import ccall safe "pause_and_unpause_thread.h getUnixTime"
+foreign import ccall unsafe "rts_pause_and_unpause_c.h pauseAndUnpause"
+    unsafe_pauseAndUnpause_c :: IO ()
+
+foreign import ccall unsafe "rts_pause_and_unpause_c.h pauseAndUnpauseViaNewThread"
+    unsafe_pauseAndUnpauseViaNewThread_c :: IO ()
+
+-- Note that these should be unsafe FFI calls. rts_pause() does not pause or
+-- wait for safe FFI calls, as they do not own a capability.
+foreign import ccall unsafe "rts_pause_and_unpause_c.h getUnixTime"
     getUnixTime_c :: IO CTime
 
-foreign import ccall safe "pause_and_unpause_thread.h getPauseBegin"
+foreign import ccall unsafe "rts_pause_and_unpause_c.h getPauseBegin"
     getPauseBegin_c :: IO CTime
 
-foreign import ccall safe "pause_and_unpause_thread.h getPauseEnd"
+foreign import ccall unsafe "rts_pause_and_unpause_c.h getPauseEnd"
     getPauseEnd_c :: IO CTime
 
 clockEachSecond :: IORef [CTime] -> IO ()
 clockEachSecond ref = forever $ do
   time <- getUnixTime_c
-  timesList <- readIORef ref
-  writeIORef ref $ time : timesList
+  modifyIORef ref $ (time:)
 
   sleepSeconds 1
 
@@ -35,12 +42,30 @@ 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
+  -- Start thread that forever writes the current time to an IORef
+  ref <- newIORef []
+  forkIO $ clockEachSecond ref
 
-    sleepSeconds 3
+  -- Attempt pause and unpause in various forms
+  withPauseAndUnpause ref
+    "Pause and unpause via safe FFI call"
+    safe_pauseAndUnpause_c
+
+  withPauseAndUnpause ref
+    "Pause and unpause via unsafe FFI call"
+    unsafe_pauseAndUnpause_c
 
-    pauseAndUnpause_c
+  withPauseAndUnpause ref
+    "Pause and unpause via unsafe FFI call that creates a new OS thread"
+    unsafe_pauseAndUnpauseViaNewThread_c
+
+withPauseAndUnpause :: IORef [CTime] -> String -> IO () -> IO ()
+withPauseAndUnpause ref startMsg pauseAndUnpause = do
+    putStrLn startMsg
+
+    writeIORef ref []
+    sleepSeconds 3
+    pauseAndUnpause
 
     -- This seems to sleep for 8 - 5 Seconds. That's strange, but should be
     -- good enough for this test.
@@ -56,7 +81,7 @@ main = do
     filter (\t -> t <= pauseBegin) times `shouldNotBe` []
     filter (\t -> t >= pauseEnd) times `shouldNotBe` []
 
-    return ()
+    putStrLn "DONE"
 
 sleepSeconds :: Int -> IO ()
 sleepSeconds t = threadDelay $ oneSecondInMicroSeconds * t


=====================================
testsuite/tests/rts/ghc-debug/pause_and_unpause_thread.c → testsuite/tests/rts/ghc-debug/rts_pause_and_unpause_c.c
=====================================
@@ -1,7 +1,7 @@
 #include <pthread.h>
 #include <time.h>
 #include <unistd.h>
-#include "pause_and_unpause_thread.h"
+#include "rts_pause_and_unpause_c.h"
 #include "Rts.h"
 #include "RtsAPI.h"
 
@@ -9,8 +9,8 @@
 
 struct PauseTimestamps timestamps = {0, 0};
 
-void pauseAndUnpause(void){
-    RtsPaused r_paused = rts_pause();
+void* pauseAndUnpause_thread(void* unused){
+    RtsPaused rtsPaused = rts_pause();
 
     if(!rts_isPaused()) {
         errorBelch("Expected the RTS to be paused.");
@@ -21,7 +21,7 @@ void pauseAndUnpause(void){
     sleep(5);
     timestamps.end = time(NULL);
 
-    rts_unpause(r_paused);
+    rts_unpause(rtsPaused);
 
     if(rts_isPaused()) {
         errorBelch("Expected the RTS to be unpaused.");
@@ -31,6 +31,16 @@ void pauseAndUnpause(void){
     return NULL;
 }
 
+void pauseAndUnpause(void){
+    pauseAndUnpause_thread(NULL);
+}
+
+void pauseAndUnpauseViaNewThread(void){
+    pthread_t threadId;
+    pthread_create(&threadId, NULL, &pauseAndUnpause_thread, NULL);
+    pthread_detach(threadId);
+}
+
 time_t getPauseBegin(void) {
     return timestamps.begin;
 }


=====================================
testsuite/tests/rts/ghc-debug/pause_and_unpause_thread.h → testsuite/tests/rts/ghc-debug/rts_pause_and_unpause_c.h
=====================================


=====================================
testsuite/tests/rts/ghc-debug/shouldfail/all.T
=====================================
@@ -0,0 +1 @@
+test('unsafe_rts_pause', [ignore_stderr, exit_code(134)], compile_and_run, ['-threaded '])
\ No newline at end of file


=====================================
testsuite/tests/rts/ghc-debug/shouldfail/unsafe_rts_pause.hs
=====================================
@@ -0,0 +1,21 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+import Data.Word
+import Data.IORef
+import GHC.Clock
+import Control.Concurrent
+import Foreign.Ptr
+import System.Mem
+import Control.Monad
+
+data RtsPause
+
+foreign import ccall unsafe "RtsAPI.h rts_pause"
+    unsafe_rts_pause_c :: IO (Ptr RtsPause)
+
+main :: IO ()
+main = do
+  putStrLn "Making a unsafe call to rts_pause() should fail on return. We \
+           \cannot allow this haskell thread to continue if the RTS is paused."
+  _ <- unsafe_rts_pause_c
+  putStrLn "Oops! Haskell thread has continued even though RTS was paused."



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/47b915a196db03d57ca3358a7c03e6ab97e7aac4
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/20200917/e6459462/attachment-0001.html>