[Git][ghc/ghc][wip/T5611-fix] 2 commits: testsuite: Use safe FFI call in T5611

[Ben Gamari]

Ben Gamari pushed to branch wip/T5611-fix at Glasgow Haskell Compiler / GHC


Commits:
aeb511a5 by Ben Gamari at 2019-06-19T16:21:26Z
testsuite: Use safe FFI call in T5611

The original issue, #5611, was concerned with safe calls. However, the
test inexplicably used an unsafe call. Fix this.

- - - - -
62797991 by Ben Gamari at 2019-06-19T16:21:26Z
testsuite: Add T5611a

This is the same as T5611 but with an unsafe call to sleep.

- - - - -


6 changed files:

- testsuite/tests/concurrent/should_run/T5611.hs
- + testsuite/tests/concurrent/should_run/T5611a.hs
- + testsuite/tests/concurrent/should_run/T5611a.stderr
- + testsuite/tests/concurrent/should_run/T5611a.stderr.mingw32
- + testsuite/tests/concurrent/should_run/T5611a.stdout
- testsuite/tests/concurrent/should_run/all.T


Changes:

=====================================
testsuite/tests/concurrent/should_run/T5611.hs
=====================================
@@ -4,12 +4,12 @@ import Control.Concurrent
 import Foreign.C
 import System.IO
 
-#ifdef mingw32_HOST_OS
+#if defined(mingw32_HOST_OS)
 sleep n = sleepBlock (n*1000)
-foreign import stdcall unsafe "Sleep" sleepBlock :: Int -> IO ()
+foreign import stdcall safe "Sleep" sleepBlock :: Int -> IO ()
 #else
 sleep n = sleepBlock n
-foreign import ccall unsafe "sleep" sleepBlock :: Int -> IO ()
+foreign import ccall safe "sleep" sleepBlock :: Int -> IO ()
 #endif
 
 main :: IO ()


=====================================
testsuite/tests/concurrent/should_run/T5611a.hs
=====================================
@@ -0,0 +1,36 @@
+-- The same as T5611 but with unsafe calls.
+
+{-# LANGUAGE CPP,ForeignFunctionInterface #-}
+
+import Control.Concurrent
+import Foreign.C
+import System.IO
+
+#if defined(mingw32_HOST_OS)
+sleep n = sleepBlock (n*1000)
+foreign import stdcall unsafe "Sleep" sleepBlock :: Int -> IO ()
+#else
+sleep n = sleepBlock n
+foreign import ccall unsafe "sleep" sleepBlock :: Int -> IO ()
+#endif
+
+main :: IO ()
+main = do
+     hSetBuffering stdout LineBuffering
+
+     tid <- forkIO $ do
+         putStrLn "child: Sleeping"
+         _ <- sleep 1
+
+         -- The following lines should not happen after the killThread from the
+         -- parent thread completes.  However, they do...
+         -- putStrLn "child: Done sleeping"
+         threadDelay 100000
+         putStrLn "child: Done waiting"
+
+     threadDelay 100000
+     -- putStrLn $ "parent: Throwing exception to thread " ++ show tid
+     throwTo tid $ userError "Exception delivered successfully"
+     putStrLn "parent: Done throwing exception"
+
+     threadDelay 200000


=====================================
testsuite/tests/concurrent/should_run/T5611a.stderr
=====================================
@@ -0,0 +1 @@
+T5611a: user error (Exception delivered successfully)


=====================================
testsuite/tests/concurrent/should_run/T5611a.stderr.mingw32
=====================================
@@ -0,0 +1 @@
+T5611a: <stdout>: commitBuffer: user error (Exception delivered successfully)


=====================================
testsuite/tests/concurrent/should_run/T5611a.stdout
=====================================
@@ -0,0 +1,2 @@
+child: Sleeping
+parent: Done throwing exception


=====================================
testsuite/tests/concurrent/should_run/all.T
=====================================
@@ -75,6 +75,7 @@ test('T5558',
 
 test('T5421', normal, compile_and_run, [''])
 test('T5611', when(opsys('darwin'), fragile(12751)) , compile_and_run, [''])
+test('T5611a', when(opsys('darwin'), fragile(12751)) , compile_and_run, [''])
 test('T5238', normal, compile_and_run, [''])
 test('T5866', exit_code(1), compile_and_run, [''])
 



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/3b8d260eea2050df62edf51330848e92f96254ec...627979918ff0575f4f27d6cfeff6770fdee683bb

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/3b8d260eea2050df62edf51330848e92f96254ec...627979918ff0575f4f27d6cfeff6770fdee683bb
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/20190619/52661b79/attachment-0001.html>