diff --git a/testsuite/tests/concurrent/should_run/T5611a.hs b/testsuite/tests/concurrent/should_run/T5611a.hs new file mode 100644 index 0000000000000000000000000000000000000000..81e6cc957e1c532342dbe079e5eb2077bc6b2e5e --- /dev/null +++ b/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 diff --git a/testsuite/tests/concurrent/should_run/T5611a.stderr b/testsuite/tests/concurrent/should_run/T5611a.stderr new file mode 100644 index 0000000000000000000000000000000000000000..644a878735f38f8342032a89de5c2d0db338569d --- /dev/null +++ b/testsuite/tests/concurrent/should_run/T5611a.stderr @@ -0,0 +1 @@ +T5611a: user error (Exception delivered successfully) diff --git a/testsuite/tests/concurrent/should_run/T5611a.stderr.mingw32 b/testsuite/tests/concurrent/should_run/T5611a.stderr.mingw32 new file mode 100644 index 0000000000000000000000000000000000000000..42c9f24f7679dd64261aad62ff4d72b0b3f258a0 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/T5611a.stderr.mingw32 @@ -0,0 +1 @@ +T5611a: <stdout>: commitBuffer: user error (Exception delivered successfully) diff --git a/testsuite/tests/concurrent/should_run/T5611a.stdout b/testsuite/tests/concurrent/should_run/T5611a.stdout new file mode 100644 index 0000000000000000000000000000000000000000..cf4f0d28274a2053b309087eba7cadf966494549 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/T5611a.stdout @@ -0,0 +1,2 @@ +child: Sleeping +parent: Done throwing exception diff --git a/testsuite/tests/concurrent/should_run/all.T b/testsuite/tests/concurrent/should_run/all.T index 706cd68ed482f6ddcc60e2a20b083fe1cae1f828..b8aeb32803a59c3b48a4ae27f51d189f3737af56 100644 --- a/testsuite/tests/concurrent/should_run/all.T +++ b/testsuite/tests/concurrent/should_run/all.T @@ -74,10 +74,8 @@ test('T5558', compile_and_run, ['']) test('T5421', normal, compile_and_run, ['']) -test('T5611', - [expect_broken_for(16845, ['ghci']), - when(opsys('darwin'), fragile(12751))], - 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, [''])