diff options
| author | David Terei <davidterei@gmail.com> | 2011-07-20 11:09:03 -0700 |
|---|---|---|
| committer | David Terei <davidterei@gmail.com> | 2011-07-20 11:26:35 -0700 |
| commit | 16514f272fb42af6e9c7674a9bd6c9dce369231f (patch) | |
| tree | e4f332b45fe65e2a7a2451be5674f887b42bf199 /testsuite/tests/concurrent/should_run | |
| parent | ebd422aed41048476aa61dd4c520d43becd78682 (diff) | |
| download | haskell-16514f272fb42af6e9c7674a9bd6c9dce369231f.tar.gz | |
Move tests from tests/ghc-regress/* to just tests/*
Diffstat (limited to 'testsuite/tests/concurrent/should_run')
144 files changed, 2075 insertions, 0 deletions
diff --git a/testsuite/tests/concurrent/should_run/1980.hs b/testsuite/tests/concurrent/should_run/1980.hs new file mode 100644 index 0000000000..61fcd9d15b --- /dev/null +++ b/testsuite/tests/concurrent/should_run/1980.hs @@ -0,0 +1,13 @@ +import Control.Exception +import Control.Concurrent + +main = do + thr <- myThreadId + evaluate $ increase_stack 1000 + throwTo thr ThreadKilled + `Control.Exception.catch` (\e -> case e of + ThreadKilled -> return () + _ -> throw e) + where + increase_stack 0 = 1 + increase_stack n = increase_stack (n-1) + n diff --git a/testsuite/tests/concurrent/should_run/2910.hs b/testsuite/tests/concurrent/should_run/2910.hs new file mode 100644 index 0000000000..2867008159 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/2910.hs @@ -0,0 +1,9 @@ +import Control.Exception +import GHC.Conc + +main = do + t1 <- block $ forkIO yield + t2 <- forkIO $ killThread t1 + threadDelay 100000 + threadStatus t1 >>= print + threadStatus t2 >>= print diff --git a/testsuite/tests/concurrent/should_run/2910.stdout b/testsuite/tests/concurrent/should_run/2910.stdout new file mode 100644 index 0000000000..145fced527 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/2910.stdout @@ -0,0 +1,2 @@ +ThreadFinished +ThreadFinished diff --git a/testsuite/tests/concurrent/should_run/2910a.hs b/testsuite/tests/concurrent/should_run/2910a.hs new file mode 100644 index 0000000000..380c15467d --- /dev/null +++ b/testsuite/tests/concurrent/should_run/2910a.hs @@ -0,0 +1,9 @@ +import Control.Exception +import GHC.Conc + +main = do + t1 <- mask_ $ forkIO yield + t2 <- forkIO $ killThread t1 + threadDelay 100000 + threadStatus t1 >>= print + threadStatus t2 >>= print diff --git a/testsuite/tests/concurrent/should_run/2910a.stdout b/testsuite/tests/concurrent/should_run/2910a.stdout new file mode 100644 index 0000000000..145fced527 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/2910a.stdout @@ -0,0 +1,2 @@ +ThreadFinished +ThreadFinished diff --git a/testsuite/tests/concurrent/should_run/3279.hs b/testsuite/tests/concurrent/should_run/3279.hs new file mode 100644 index 0000000000..279895f444 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/3279.hs @@ -0,0 +1,25 @@ +-- test for #3279 + +import System.IO.Unsafe +import GHC.Conc +import Control.Exception +import Prelude hiding (catch) + +f :: Int +f = (1 +) . unsafePerformIO $ do + error "foo" `catch` \(SomeException e) -> do + myThreadId >>= flip throwTo e + -- point X + unblock $ return 1 + +main :: IO () +main = do + evaluate f `catch` \(SomeException e) -> return 0 + -- the evaluation of 'x' is now suspended at point X + tid <- block $ forkIO (evaluate f >> return ()) + killThread tid + -- now execute the 'unblock' above with a pending exception + yield + -- should print 1 + 1 = 2 + print f + diff --git a/testsuite/tests/concurrent/should_run/3279.stdout b/testsuite/tests/concurrent/should_run/3279.stdout new file mode 100644 index 0000000000..0cfbf08886 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/3279.stdout @@ -0,0 +1 @@ +2 diff --git a/testsuite/tests/concurrent/should_run/3429.hs b/testsuite/tests/concurrent/should_run/3429.hs new file mode 100644 index 0000000000..8b12a8b1ff --- /dev/null +++ b/testsuite/tests/concurrent/should_run/3429.hs @@ -0,0 +1,22 @@ +import Control.Monad +import Control.Concurrent +import Control.Concurrent.MVar +import Control.Exception +import System.IO + +main :: IO () +main = do hSetBuffering stdout NoBuffering + replicateM_ 1000 doit + +doit :: IO () +doit = do v <- newMVar () + t <- forkIO (foo v) + threadDelay 1000 + killThread t + takeMVar v + putChar '.' + +foo :: MVar () -> IO () +foo v = do let loop = do withMVar v $ \x -> evaluate x + loop + loop diff --git a/testsuite/tests/concurrent/should_run/3429.stdout b/testsuite/tests/concurrent/should_run/3429.stdout new file mode 100644 index 0000000000..ad88db8c31 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/3429.stdout @@ -0,0 +1 @@ +........................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................
\ No newline at end of file diff --git a/testsuite/tests/concurrent/should_run/4030.hs b/testsuite/tests/concurrent/should_run/4030.hs new file mode 100644 index 0000000000..1993bad86b --- /dev/null +++ b/testsuite/tests/concurrent/should_run/4030.hs @@ -0,0 +1,8 @@ +module Main where + +import Control.Concurrent ( forkIO, killThread ) +import Control.Exception ( block ) + +main :: IO () +main = do tid <- block $ forkIO $ let x = x in x + killThread tid diff --git a/testsuite/tests/concurrent/should_run/4030.stderr b/testsuite/tests/concurrent/should_run/4030.stderr new file mode 100644 index 0000000000..0e2a7bfc12 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/4030.stderr @@ -0,0 +1 @@ +4030: <<loop>> diff --git a/testsuite/tests/concurrent/should_run/4262.hs b/testsuite/tests/concurrent/should_run/4262.hs new file mode 100644 index 0000000000..e114b558a6 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/4262.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Main where + +-- Tests that superfluous worker threads are discarded rather than +-- being kept around by the RTS. + +import Control.Concurrent +import Control.Monad +import Foreign.C.Types +import System.Mem +import System.Posix.Process +import System.Directory +import Control.Concurrent.QSem + +foreign import ccall safe sleep :: CUInt -> IO () + +main = do + let amount = 200 + qsem <- newQSem 0 + replicateM_ amount . forkIO $ (sleep 2 >> signalQSem qsem) + replicateM_ amount $ waitQSem qsem + -- POSIX only: check thread usage manually + pid <- getProcessID + let dir = "/proc/" ++ show pid ++ "/task" + contents <- getDirectoryContents dir + let status = length contents - 2 -- . and .. + print status diff --git a/testsuite/tests/concurrent/should_run/4262.stdout b/testsuite/tests/concurrent/should_run/4262.stdout new file mode 100644 index 0000000000..45a4fb75db --- /dev/null +++ b/testsuite/tests/concurrent/should_run/4262.stdout @@ -0,0 +1 @@ +8 diff --git a/testsuite/tests/concurrent/should_run/4811.hs b/testsuite/tests/concurrent/should_run/4811.hs new file mode 100644 index 0000000000..5aad0a51df --- /dev/null +++ b/testsuite/tests/concurrent/should_run/4811.hs @@ -0,0 +1,14 @@ +import Control.Concurrent +import Control.Monad + +-- tests for a bug where throwTo targets a thread just created by +-- forkOn, which is still in the process of migrating to another CPU (#4811) + +main = do + m <- newEmptyMVar + forkOn 0 $ do + replicateM_ 1000 $ do + t <- forkOn 1 $ return () + killThread t + putMVar m () + takeMVar m diff --git a/testsuite/tests/concurrent/should_run/4813.hs b/testsuite/tests/concurrent/should_run/4813.hs new file mode 100644 index 0000000000..db3a9778c6 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/4813.hs @@ -0,0 +1,12 @@ +import Control.Concurrent +import Control.Monad +import Control.Exception +import System.Mem + +-- caused an assertion failure with -debug in 7.0.1 (#4813) + +main = do + m <- newEmptyMVar + ts <- replicateM 100 $ mask_ $ forkIO $ threadDelay 100000; putMVar m () + mapM_ killThread (reverse (init ts)) + takeMVar m diff --git a/testsuite/tests/concurrent/should_run/Makefile b/testsuite/tests/concurrent/should_run/Makefile new file mode 100644 index 0000000000..c6bef49619 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/Makefile @@ -0,0 +1,6 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +conc059_setup : + '$(TEST_HC)' $(TEST_HC_OPTS) -c conc059.hs diff --git a/testsuite/tests/concurrent/should_run/all.T b/testsuite/tests/concurrent/should_run/all.T new file mode 100644 index 0000000000..cdcbd6da68 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/all.T @@ -0,0 +1,200 @@ +# ----------------------------------------------------------------------------- +# These tests we do even for 'make fast' + +test('conc003', normal, compile_and_run, ['']) +test('conc006', normal, compile_and_run, ['']) +test('conc027', normal, compile_and_run, ['']) +test('conc051', normal, compile_and_run, ['']) + +if ('threaded1' in config.run_ways): + only_threaded_ways = only_ways(['ghci','threaded1','threaded2']) +else: + only_threaded_ways = skip + +test('conc069', only_threaded_ways, compile_and_run, ['']) +test('conc069a', only_threaded_ways, compile_and_run, ['']) +# this test gives slightly different results for non-threaded ways, so omit +# those for now. +test('conc070', only_threaded_ways, compile_and_run, ['']) + +test('conc071', omit_ways(['threaded2']), compile_and_run, ['']) +test('conc072', only_ways(['threaded2']), compile_and_run, ['']) + +test('1980', normal, compile_and_run, ['']) +test('2910', normal, compile_and_run, ['']) +test('2910a', normal, compile_and_run, ['']) +test('3279', normal, compile_and_run, ['']) + +# This test takes a long time with the default context switch interval +test('3429', extra_run_opts('+RTS -i0.001 -RTS'), compile_and_run, ['']) + +# without -O, goes into an infinite loop +# GHCi cannot deterct the infinite loop, because the thread is always reachable +# (see also conc033 and others). We should really fix this. +test('4030', omit_ways('ghci'), compile_and_run, ['-O']) + +# each of these runs for about a second +test('throwto001', [reqlib('random'), extra_run_opts('1000 2000')], + compile_and_run, ['']) +test('throwto002', [reqlib('random'), ignore_output], compile_and_run, ['']) +test('throwto003', normal, compile_and_run, ['']) + +test('mask001', normal, compile_and_run, ['']) +# ghci does not generate the BlockedIndefinitely exceptions, so omit: +test('mask002', omit_ways(['ghci']), compile_and_run, ['']) + +test('async001', normal, compile_and_run, ['']) + +test('numsparks001', only_ways(['threaded1']), compile_and_run, ['']) + +test('4262', [ skip, # skip for now, it doesn't give reliable results + only_ways(['threaded1']), + unless_os('linux',skip), + if_compiler_lt('ghc', '7.1', expect_fail) ], + compile_and_run, ['']) + +test('4813', normal, compile_and_run, ['']) +test('4811', normal, compile_and_run, ['']) + +test('allowinterrupt001', normal, compile_and_run, ['']) + +# ----------------------------------------------------------------------------- +# These tests we only do for a full run + +def f( opts ): + if config.fast: + opts.skip = 1 + +setTestOpts(f) + +test('conc001', normal, compile_and_run, ['']) +test('conc002', normal, compile_and_run, ['']) + +# Omit GHCi way - it blows up to 0.5G. Something to do with the threaded RTS? +test('conc004', omit_ways(['ghci']), compile_and_run, ['']) + +test('conc007', compose(only_compiler_types(['ghc']), + extra_run_opts('+RTS -H128M -RTS')), + compile_and_run, ['']) +test('conc008', only_compiler_types(['ghc']), compile_and_run, ['']) +test('conc009', compose(only_compiler_types(['ghc']), exit_code(1)), + compile_and_run, ['']) +test('conc010', only_compiler_types(['ghc']), compile_and_run, ['']) + +# conc012(ghci) needs a smaller stack, or it takes forever +test('conc012', normal, compile_and_run, ['+RTS -K8m -RTS']) + +test('conc013', only_compiler_types(['ghc']), compile_and_run, ['']) + +test('conc014', only_compiler_types(['ghc']), compile_and_run, ['']) +test('conc015', only_compiler_types(['ghc']), compile_and_run, ['']) +test('conc015a', only_compiler_types(['ghc']), compile_and_run, ['']) +test('conc016', [ omit_ways(['threaded2']), # see comment in conc016.hs + only_compiler_types(['ghc']) ], compile_and_run, ['']) +test('conc017', only_compiler_types(['ghc']), compile_and_run, ['']) +test('conc017a', only_compiler_types(['ghc']), compile_and_run, ['']) +test('conc018', only_compiler_types(['ghc']), compile_and_run, ['']) +test('conc019', compose(only_compiler_types(['ghc']), + extra_run_opts('+RTS -K16m -RTS')), + compile_and_run, ['']) +test('conc020', only_compiler_types(['ghc']), compile_and_run, ['']) +test('conc021', compose(omit_ways(['ghci']), exit_code(1)), + compile_and_run, ['']) +test('conc022', only_compiler_types(['ghc']), compile_and_run, ['']) + +# On Windows, the non-threaded RTS creates a real OS thread for each +# threadDelay. conc023 creates 5000 concurrent threadDelays, and the +# resulting creation of OS threads seems to cause the system to run +# out of memory sometimes (I'm not sure exactly how/why this happens, +# but the threaded RTS fixes it). See #1197. +if config.platform == 'i386-unknown-mingw32': + conc023_ways = only_ways(['threaded1','threaded2']) +else: + conc023_ways = normal + +test('conc023', composes([skip_if_fast, + only_compiler_types(['ghc']), + conc023_ways]), compile_and_run, ['']) + +test('conc024', only_compiler_types(['ghc']), compile_and_run, ['']) +test('conc025', normal, compile_and_run, ['']) +test('conc026', only_compiler_types(['ghc']), compile_and_run, ['']) +test('conc028', normal, compile_and_run, ['']) +test('conc029', normal, compile_and_run, ['']) +test('conc030', compose(only_compiler_types(['ghc']), + extra_run_opts('+RTS -K4M -RTS')), + compile_and_run, ['']) + +test('conc031', normal, compile_and_run, ['']) + +test('conc032', only_compiler_types(['ghc']), compile_and_run, ['']) + +# Omit for GHCi, because it just sits there waiting for you to press ^C +test('conc033', omit_ways(['ghci']), compile_and_run, ['']) + +# Omit for GHCi, because it just sits there waiting for you to press ^C +test('conc034', compose(only_compiler_types(['ghc']), + compose(omit_ways(['ghci']), + extra_run_opts('+RTS -C0 -RTS'))), + compile_and_run, ['']) + +test('conc035', only_compiler_types(['ghc']), compile_and_run, ['']) + +# Omit for GHCi: firstly GHCi doesn't have unsafe FFI calls, and secondly +# the main thread cannot receive the deadlock exception because it can be +# woken up by ^C. +# Omit for threaded2: this test is really bogus and fails to do anything +# sensible for more than one CPU. +test('conc036', compose(skip_if_fast, + compose(omit_ways(['ghci','threaded2']), + only_compiler_types(['ghc']))), compile_and_run, ['']) +# Interrupting foreign calls only makes sense if we are threaded +test('foreignInterruptible', composes([skip_if_fast, + only_threaded_ways, + only_compiler_types(['ghc'])]), compile_and_run, ['']) + +test('conc037', only_ways(['threaded1','threaded2']), compile_and_run, ['']) +test('conc038', only_ways(['threaded1','threaded2']), compile_and_run, ['']) + +# Omit for GHCi, uses foreign export +# Omit for the threaded ways, because in this case the main thread is allowed to +# complete, which causes the child thread to be interrupted. +test('conc039', omit_ways(['ghci','threaded1','threaded2','profthreaded']), compile_and_run, ['']) + +# Omit for GHCi, uses foreign export +test('conc040', compose(only_compiler_types(['ghc']), + compose(exit_code(1), + omit_ways(['ghci']))), + compile_and_run, ['']) + +# STM-related tests. +test('conc041', only_compiler_types(['ghc']), compile_and_run, ['']) +test('conc042', only_compiler_types(['ghc']), compile_and_run, ['']) +test('conc043', only_compiler_types(['ghc']), compile_and_run, ['']) +test('conc044', only_compiler_types(['ghc']), compile_and_run, ['']) +test('conc045', only_compiler_types(['ghc']), compile_and_run, ['']) + +test('conc058', only_compiler_types(['ghc']), compile_and_run, ['']) + +test('conc059', + [only_compiler_types(['ghc']), + only_ways(['threaded1','threaded2']), + compile_cmd_prefix('$MAKE conc059_setup && '), + extra_clean(['conc059_c.o'])], + compile_and_run, + ['conc059_c.c -no-hs-main']) + +# This test sometimes just exits successfully +# when run the threaded2 way. The problem hasn't been diagnosed yet +test('conc064', + exit_code(1), + compile_and_run, ['']) + +test('conc065', ignore_output, compile_and_run, ['']) +test('conc066', ignore_output, compile_and_run, ['']) +test('conc067', ignore_output, compile_and_run, ['']) + +# omit threaded2, the behaviour of this test is non-deterministic with more +# than one CPU. +test('conc068', [ omit_ways('threaded2'), exit_code(1) ], compile_and_run, ['']) + diff --git a/testsuite/tests/concurrent/should_run/allowinterrupt001.hs b/testsuite/tests/concurrent/should_run/allowinterrupt001.hs new file mode 100644 index 0000000000..938aa65383 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/allowinterrupt001.hs @@ -0,0 +1,13 @@ +import Control.Exception +import Control.Concurrent +import GHC.Conc +import Control.Monad + +nfib n = if n < 2 then 1 else nfib (n-2) + nfib (n-1) + +main = do + t <- mask_ $ forkIO $ forM_ [1..] $ \n -> nfib n `seq` allowInterrupt + killThread t + let loop = do r <- threadStatus t + when (r /= ThreadFinished) $ do yield; loop + loop diff --git a/testsuite/tests/concurrent/should_run/async001.hs b/testsuite/tests/concurrent/should_run/async001.hs new file mode 100644 index 0000000000..7d765e26f9 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/async001.hs @@ -0,0 +1,19 @@ +import Control.Exception as E +import Control.Concurrent +import System.IO.Unsafe + +-- x is killed during evaluation with an asynchronous exception, but +-- nevertheless gets overwritten with 'throw ThreadKilled' because the +-- async exception is re-thrown as a synchrnonous exception by +-- 'onException'. + +main = do + let x = unsafePerformIO $ + (do threadDelay 1000000; return 42) + `onException` return () + + t <- forkIO $ do evaluate x; return () + threadDelay 1000 + killThread t + + print x `E.catch` \e -> putStrLn ("main caught: " ++ show (e::SomeException)) diff --git a/testsuite/tests/concurrent/should_run/async001.stdout b/testsuite/tests/concurrent/should_run/async001.stdout new file mode 100644 index 0000000000..241be4a895 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/async001.stdout @@ -0,0 +1 @@ +main caught: thread killed diff --git a/testsuite/tests/concurrent/should_run/conc001.hs b/testsuite/tests/concurrent/should_run/conc001.hs new file mode 100644 index 0000000000..99488fb07b --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc001.hs @@ -0,0 +1,15 @@ +module Main where + +import Control.Concurrent + +-- two processes, one MVar communication. + +main = do + s <- newEmptyMVar + let + write = do + putMVar s "hello world\n" + + forkIO write + str <- takeMVar s + putStr str diff --git a/testsuite/tests/concurrent/should_run/conc001.stdout b/testsuite/tests/concurrent/should_run/conc001.stdout new file mode 100644 index 0000000000..3b18e512db --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc001.stdout @@ -0,0 +1 @@ +hello world diff --git a/testsuite/tests/concurrent/should_run/conc002.hs b/testsuite/tests/concurrent/should_run/conc002.hs new file mode 100644 index 0000000000..93efd6fe4c --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc002.hs @@ -0,0 +1,14 @@ +module Main where + +import Control.Concurrent + +main = do + c <- newChan + let writer = writeList2Chan c "Hello World\n" + forkIO writer + let reader = do char <- readChan c + if (char == '\n') + then return () + else do putChar char; reader + reader + diff --git a/testsuite/tests/concurrent/should_run/conc002.stdout b/testsuite/tests/concurrent/should_run/conc002.stdout new file mode 100644 index 0000000000..5e1c309dae --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc002.stdout @@ -0,0 +1 @@ +Hello World
\ No newline at end of file diff --git a/testsuite/tests/concurrent/should_run/conc003.hs b/testsuite/tests/concurrent/should_run/conc003.hs new file mode 100644 index 0000000000..c7b1f9a56c --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc003.hs @@ -0,0 +1,28 @@ +module Main where + +import Control.Concurrent + +-- simple handshaking using two MVars, +-- must context switch twice for each character. + +main = do + ready <- newEmptyMVar + datum <- newEmptyMVar + let + reader = do + putMVar ready () + char <- takeMVar datum + if (char == '\n') + then return () + else do putChar char; reader + + writer "" = do + takeMVar ready + putMVar datum '\n' + writer (c:cs) = do + takeMVar ready + putMVar datum c + writer cs + + forkIO reader + writer "Hello World" diff --git a/testsuite/tests/concurrent/should_run/conc003.stdout b/testsuite/tests/concurrent/should_run/conc003.stdout new file mode 100644 index 0000000000..5e1c309dae --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc003.stdout @@ -0,0 +1 @@ +Hello World
\ No newline at end of file diff --git a/testsuite/tests/concurrent/should_run/conc004.hs b/testsuite/tests/concurrent/should_run/conc004.hs new file mode 100644 index 0000000000..ec46c4ba73 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc004.hs @@ -0,0 +1,19 @@ +module Main where + +-- Test thread creation. +-- (from: Einar Wolfgang Karlsen <ewk@Informatik.Uni-Bremen.DE>) + +import Control.Concurrent + +main :: IO () +main = do + mvar <- newEmptyMVar + + let + spawner :: (IO () -> IO ThreadId) -> Int -> IO () + spawner c 0 = putMVar mvar () + spawner c n = do { c (spawner c (n-1)); return ()} + + spawner forkIO 100000 + takeMVar mvar + putStr "done" diff --git a/testsuite/tests/concurrent/should_run/conc004.stdout b/testsuite/tests/concurrent/should_run/conc004.stdout new file mode 100644 index 0000000000..348ebd9491 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc004.stdout @@ -0,0 +1 @@ +done
\ No newline at end of file diff --git a/testsuite/tests/concurrent/should_run/conc006.hs b/testsuite/tests/concurrent/should_run/conc006.hs new file mode 100644 index 0000000000..4a77b5fc95 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc006.hs @@ -0,0 +1,23 @@ +module Main where + +import Control.Concurrent + +-- This test hopefully exercises the black hole code. The main thread +-- forks off another thread and starts on a large computation. +-- The child thread attempts to get the result of the same large +-- computation (and should get blocked doing so, because the parent +-- won't have evaluated it yet). When the result is available, the +-- child passes it back to the parent who prints it out. + +test = sum [1..10000] + +main = do + x <- newEmptyMVar + forkIO (if test > 0 + then putMVar x test + else error "proc" + ) + if test > 0 -- evaluate test + then do result <- takeMVar x + print result + else error "main" diff --git a/testsuite/tests/concurrent/should_run/conc006.stdout b/testsuite/tests/concurrent/should_run/conc006.stdout new file mode 100644 index 0000000000..b9d569380c --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc006.stdout @@ -0,0 +1 @@ +50005000 diff --git a/testsuite/tests/concurrent/should_run/conc007.hs b/testsuite/tests/concurrent/should_run/conc007.hs new file mode 100644 index 0000000000..74535ebe6d --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc007.hs @@ -0,0 +1,23 @@ + +module Main where + +import Control.Concurrent +import Control.Exception as E + +choose :: a -> a -> IO a +choose a b = do + ready <- newMVar () + answer <- newEmptyMVar + a_id <- forkIO (a `seq` takeMVar ready >> putMVar answer a) + b_id <- forkIO (b `seq` takeMVar ready >> putMVar answer b) + it <- takeMVar answer + killThread a_id + killThread b_id + return it + +main = do + let big = sum [1..] + small = sum [1..42] + test1 <- choose big small + test2 <- choose small big + print (test1,test2) diff --git a/testsuite/tests/concurrent/should_run/conc007.stdout b/testsuite/tests/concurrent/should_run/conc007.stdout new file mode 100644 index 0000000000..ee81b5ecd3 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc007.stdout @@ -0,0 +1 @@ +(903,903) diff --git a/testsuite/tests/concurrent/should_run/conc008.hs b/testsuite/tests/concurrent/should_run/conc008.hs new file mode 100644 index 0000000000..66a4b5f973 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc008.hs @@ -0,0 +1,12 @@ + +module Main where + +import Control.Concurrent +import Control.Exception + +-- Send ourselves a KillThread signal, catch it and recover. + +main = do + id <- myThreadId + Control.Exception.catch (killThread id) $ + \e -> putStr (show (e::SomeException)) diff --git a/testsuite/tests/concurrent/should_run/conc008.stdout b/testsuite/tests/concurrent/should_run/conc008.stdout new file mode 100644 index 0000000000..faed5b894d --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc008.stdout @@ -0,0 +1 @@ +thread killed
\ No newline at end of file diff --git a/testsuite/tests/concurrent/should_run/conc009.hs b/testsuite/tests/concurrent/should_run/conc009.hs new file mode 100644 index 0000000000..94c7809332 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc009.hs @@ -0,0 +1,9 @@ + +module Main where + +import Control.Concurrent +import Control.Exception + +main = do + id <- myThreadId + throwTo id (ErrorCall "hello") diff --git a/testsuite/tests/concurrent/should_run/conc009.stderr b/testsuite/tests/concurrent/should_run/conc009.stderr new file mode 100644 index 0000000000..e42034eba1 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc009.stderr @@ -0,0 +1 @@ +conc009: hello diff --git a/testsuite/tests/concurrent/should_run/conc010.hs b/testsuite/tests/concurrent/should_run/conc010.hs new file mode 100644 index 0000000000..52acb97a35 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc010.hs @@ -0,0 +1,28 @@ + +module Main where + +import Control.Concurrent +import Control.Exception + +-- Raise an exception in another thread. We need a lot of synchronisation here: + +-- - an MVar for the second thread to block on which it waits for the +-- signal (block) + +-- - an MVar to signal the main thread that the second thread is ready to +-- accept the signal (ready) + +-- - an MVar to signal the main thread that the second thread has received +-- the signal (ready2). If we don't have this MVar, then the main +-- thread could exit before the second thread has time to print +-- the result. + +main = do + block <- newEmptyMVar + ready <- newEmptyMVar + ready2 <- newEmptyMVar + id <- forkIO (Control.Exception.catch (putMVar ready () >> takeMVar block) + (\e -> putStr (show (e::SomeException)) >> putMVar ready2 ())) + takeMVar ready + throwTo id (ErrorCall "hello") + takeMVar ready2 diff --git a/testsuite/tests/concurrent/should_run/conc010.stdout b/testsuite/tests/concurrent/should_run/conc010.stdout new file mode 100644 index 0000000000..b6fc4c620b --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc010.stdout @@ -0,0 +1 @@ +hello
\ No newline at end of file diff --git a/testsuite/tests/concurrent/should_run/conc012.hs b/testsuite/tests/concurrent/should_run/conc012.hs new file mode 100644 index 0000000000..a2f139e401 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc012.hs @@ -0,0 +1,23 @@ +module Main where + +import Control.Concurrent +import Control.Exception +--import GlaExts + +data Result = Died SomeException | Finished + +-- Test stack overflow catching. Should print "Died: stack overflow". + +stackoverflow :: Int -> Int +stackoverflow 0 = 1 +stackoverflow n = n + stackoverflow n + +main = do + let x = stackoverflow 1 + result <- newEmptyMVar + forkIO $ Control.Exception.catch (x `seq` putMVar result Finished) $ + \e -> putMVar result (Died e) + res <- takeMVar result + case res of + Died e -> putStr ("Died: " ++ show e ++ "\n") + Finished -> putStr "Ok.\n" diff --git a/testsuite/tests/concurrent/should_run/conc012.stdout b/testsuite/tests/concurrent/should_run/conc012.stdout new file mode 100644 index 0000000000..12e0c906fc --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc012.stdout @@ -0,0 +1 @@ +Died: stack overflow diff --git a/testsuite/tests/concurrent/should_run/conc013.hs b/testsuite/tests/concurrent/should_run/conc013.hs new file mode 100644 index 0000000000..ea2130ee47 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc013.hs @@ -0,0 +1,10 @@ +module Main where + +-- !!! test Eq and Ord instances over thread Ids. + +import Control.Concurrent + +main = do + tso1 <- forkIO (return ()) + tso2 <- forkIO (return ()) + print [compare tso1 tso2, compare tso1 tso1, compare tso2 tso1] diff --git a/testsuite/tests/concurrent/should_run/conc013.stdout b/testsuite/tests/concurrent/should_run/conc013.stdout new file mode 100644 index 0000000000..98ab9c11f2 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc013.stdout @@ -0,0 +1 @@ +[LT,EQ,GT] diff --git a/testsuite/tests/concurrent/should_run/conc014.hs b/testsuite/tests/concurrent/should_run/conc014.hs new file mode 100644 index 0000000000..76cb3c24b0 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc014.hs @@ -0,0 +1,27 @@ +import Control.Concurrent +import Control.Exception + +-- Test blocking of async exceptions in an exception handler. +-- The exception raised in the main thread should not be delivered +-- until the first exception handler finishes. +main = do + main_thread <- myThreadId + m <- newEmptyMVar + forkIO (do { takeMVar m; throwTo main_thread (ErrorCall "foo") }) + (do + error "wibble" + `Control.Exception.catch` + (\e -> let _ = e::ErrorCall in + do putMVar m (); sum [1..10000] `seq` putStrLn "done.") + myDelay 500000 + ) + `Control.Exception.catch` + \e -> putStrLn ("caught: " ++ show (e::SomeException)) + +-- compensate for the fact that threadDelay is non-interruptible +-- on Windows with the threaded RTS in 6.6. +myDelay usec = do + m <- newEmptyMVar + forkIO $ do threadDelay usec; putMVar m () + takeMVar m + diff --git a/testsuite/tests/concurrent/should_run/conc014.stdout b/testsuite/tests/concurrent/should_run/conc014.stdout new file mode 100644 index 0000000000..807edef7c9 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc014.stdout @@ -0,0 +1,2 @@ +done. +caught: foo diff --git a/testsuite/tests/concurrent/should_run/conc015.hs b/testsuite/tests/concurrent/should_run/conc015.hs new file mode 100644 index 0000000000..7574e15e5e --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc015.hs @@ -0,0 +1,44 @@ +import Control.Concurrent +import Control.Exception + +-- test blocking & unblocking of async exceptions. + +-- the first exception "foo" should be caught by the "caught1" handler, +-- since async exceptions are blocked outside this handler. + +-- the second exception "bar" should be caught by the outer "caught2" handler, +-- (i.e. this tests that async exceptions are properly unblocked after +-- being blocked). + +main = do + main_thread <- myThreadId + print =<< blocked -- False + m <- newEmptyMVar + m2 <- newEmptyMVar + forkIO (do takeMVar m + throwTo main_thread (ErrorCall "foo") + throwTo main_thread (ErrorCall "bar") + putMVar m2 () + ) + ( do + block (do + putMVar m () + print =<< blocked -- True + sum [1..1] `seq` -- give 'foo' a chance to be raised + (unblock $ myDelay 500000) + `Control.Exception.catch` + \e -> putStrLn ("caught1: " ++ show (e::SomeException)) + ) + threadDelay 10000 + takeMVar m2 + ) + `Control.Exception.catch` + \e -> do print =<< blocked + putStrLn ("caught2: " ++ show (e::SomeException)) + +-- compensate for the fact that threadDelay is non-interruptible +-- on Windows with the threaded RTS in 6.6. +myDelay usec = do + m <- newEmptyMVar + forkIO $ do threadDelay usec; putMVar m () + takeMVar m diff --git a/testsuite/tests/concurrent/should_run/conc015.stdout b/testsuite/tests/concurrent/should_run/conc015.stdout new file mode 100644 index 0000000000..be6aa71d11 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc015.stdout @@ -0,0 +1,5 @@ +False +True +caught1: foo +True +caught2: bar diff --git a/testsuite/tests/concurrent/should_run/conc015a.hs b/testsuite/tests/concurrent/should_run/conc015a.hs new file mode 100644 index 0000000000..cd8d9dd6c7 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc015a.hs @@ -0,0 +1,47 @@ +import Control.Concurrent +import Control.Exception + +-- version of conc015 using mask in place of the old deprecated +-- block/unblock. + +-- test blocking & unblocking of async exceptions. + +-- the first exception "foo" should be caught by the "caught1" handler, +-- since async exceptions are blocked outside this handler. + +-- the second exception "bar" should be caught by the outer "caught2" handler, +-- (i.e. this tests that async exceptions are properly unblocked after +-- being blocked). + +main = do + main_thread <- myThreadId + print =<< getMaskingState + m <- newEmptyMVar + m2 <- newEmptyMVar + forkIO (do takeMVar m + throwTo main_thread (ErrorCall "foo") + throwTo main_thread (ErrorCall "bar") + putMVar m2 () + ) + ( do + mask $ \restore -> do + putMVar m () + print =<< getMaskingState + sum [1..100000] `seq` -- give 'foo' a chance to be raised + (restore (myDelay 500000) + `Control.Exception.catch` + \e -> putStrLn ("caught1: " ++ show (e::SomeException))) + + threadDelay 10000 + takeMVar m2 + ) + `Control.Exception.catch` + \e -> do print =<< getMaskingState + putStrLn ("caught2: " ++ show (e::SomeException)) + +-- compensate for the fact that threadDelay is non-interruptible +-- on Windows with the threaded RTS in 6.6. +myDelay usec = do + m <- newEmptyMVar + forkIO $ do threadDelay usec; putMVar m () + takeMVar m diff --git a/testsuite/tests/concurrent/should_run/conc015a.stdout b/testsuite/tests/concurrent/should_run/conc015a.stdout new file mode 100644 index 0000000000..19b98e9b60 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc015a.stdout @@ -0,0 +1,5 @@ +Unmasked +MaskedInterruptible +caught1: foo +MaskedUninterruptible +caught2: bar diff --git a/testsuite/tests/concurrent/should_run/conc016.hs b/testsuite/tests/concurrent/should_run/conc016.hs new file mode 100644 index 0000000000..639b4306b3 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc016.hs @@ -0,0 +1,27 @@ +import Control.Concurrent +import Control.Exception + +-- check that we can still kill a thread that is blocked on +-- delivering an exception to us. + +-- NB. this test is non-deterministic in the threaded2 way since 6.14, +-- because throwTo is now always interruptible, so the main thread's +-- killThread can be legitimately interrupted by the child thread's +-- killThread, rather than the other way around. This happens because +-- the child thread is running on another processor, so the main +-- thread's throwTo is blocked waiting for a response, and while +-- waiting it is interruptible. + +main = do + main_thread <- myThreadId + m <- newEmptyMVar + sub_thread <- forkIO (do + takeMVar m + throwTo main_thread (ErrorCall "foo") + ) + mask_ $ do + putMVar m () + sum [1..10000] `seq` -- to be sure the other thread is now blocked + killThread sub_thread + + putStrLn "ok" diff --git a/testsuite/tests/concurrent/should_run/conc016.stdout b/testsuite/tests/concurrent/should_run/conc016.stdout new file mode 100644 index 0000000000..9766475a41 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc016.stdout @@ -0,0 +1 @@ +ok diff --git a/testsuite/tests/concurrent/should_run/conc017.hs b/testsuite/tests/concurrent/should_run/conc017.hs new file mode 100644 index 0000000000..30d8a1c56d --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc017.hs @@ -0,0 +1,45 @@ +import Control.Concurrent +import Control.Exception + +-- check that async exceptions are restored to their previous +-- state after an exception is raised and handled. + +main = do + main_thread <- myThreadId + m1 <- newEmptyMVar + m2 <- newEmptyMVar + m3 <- newEmptyMVar + forkIO (do + takeMVar m1 + throwTo main_thread (ErrorCall "foo") + takeMVar m2 + throwTo main_thread (ErrorCall "bar") + putMVar m3 () + ) + (do + block (do + (do putMVar m1 () + unblock ( + -- unblocked, "foo" delivered to "caught1" + myDelay 100000 + ) + ) `Control.Exception.catch` + \e -> putStrLn ("caught1: " ++ show (e::SomeException)) + putMVar m2 () + -- blocked here, "bar" can't be delivered + (sum [1..10000] `seq` return ()) + `Control.Exception.catch` + \e -> putStrLn ("caught2: " ++ show (e::SomeException)) + ) + -- unblocked here, "bar" delivered to "caught3" + takeMVar m3 + ) + `Control.Exception.catch` + \e -> putStrLn ("caught3: " ++ show (e::SomeException)) + +-- compensate for the fact that threadDelay is non-interruptible +-- on Windows with the threaded RTS in 6.6. +myDelay usec = do + m <- newEmptyMVar + forkIO $ do threadDelay usec; putMVar m () + takeMVar m diff --git a/testsuite/tests/concurrent/should_run/conc017.stdout b/testsuite/tests/concurrent/should_run/conc017.stdout new file mode 100644 index 0000000000..7fca279f26 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc017.stdout @@ -0,0 +1,2 @@ +caught1: foo +caught3: bar diff --git a/testsuite/tests/concurrent/should_run/conc017a.hs b/testsuite/tests/concurrent/should_run/conc017a.hs new file mode 100644 index 0000000000..ad015f7413 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc017a.hs @@ -0,0 +1,44 @@ +import Control.Concurrent +import Control.Exception + +-- check that async exceptions are restored to their previous +-- state after an exception is raised and handled. + +main = do + main_thread <- myThreadId + m1 <- newEmptyMVar + m2 <- newEmptyMVar + m3 <- newEmptyMVar + forkIO (do + takeMVar m1 + throwTo main_thread (ErrorCall "foo") + takeMVar m2 + throwTo main_thread (ErrorCall "bar") + putMVar m3 () + ) + (do + mask $ \restore -> do + (do putMVar m1 () + restore ( + -- unblocked, "foo" delivered to "caught1" + myDelay 100000 + ) + ) `Control.Exception.catch` + \e -> putStrLn ("caught1: " ++ show (e::SomeException)) + putMVar m2 () + -- blocked here, "bar" can't be delivered + (sum [1..10000] `seq` return ()) + `Control.Exception.catch` + \e -> putStrLn ("caught2: " ++ show (e::SomeException)) + -- unblocked here, "bar" delivered to "caught3" + takeMVar m3 + ) + `Control.Exception.catch` + \e -> putStrLn ("caught3: " ++ show (e::SomeException)) + +-- compensate for the fact that threadDelay is non-interruptible +-- on Windows with the threaded RTS in 6.6. +myDelay usec = do + m <- newEmptyMVar + forkIO $ do threadDelay usec; putMVar m () + takeMVar m diff --git a/testsuite/tests/concurrent/should_run/conc017a.stdout b/testsuite/tests/concurrent/should_run/conc017a.stdout new file mode 100644 index 0000000000..7fca279f26 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc017a.stdout @@ -0,0 +1,2 @@ +caught1: foo +caught3: bar diff --git a/testsuite/tests/concurrent/should_run/conc018.hs b/testsuite/tests/concurrent/should_run/conc018.hs new file mode 100644 index 0000000000..aa83e31738 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc018.hs @@ -0,0 +1,26 @@ +import Control.Concurrent +import Control.Exception +import GHC.Conc +import Foreign + +-- test that putMVar blocks on a full MVar rather than raising an +-- exception. + +main = do + -- In this test we want a thread to get BlockedIndefinitely; that + -- can't be the main thread because in GHCi the main thread + -- doesn't get BlockedIndefinitely. So we have to use a + -- subthread, and "prevent* the main thread from getting + -- BlockedIndefinitely when we're not in GHCi, which is what the + -- following hack does: + myThreadId >>= newStablePtr + + m <- newEmptyMVar + t <- forkIO $ do + Control.Exception.catch (do + m <- newMVar () + putMVar m () + ) + (\e -> putMVar m (e::SomeException)) + takeMVar m >>= print + -- should print "thread blocked indefinitely" diff --git a/testsuite/tests/concurrent/should_run/conc018.stdout b/testsuite/tests/concurrent/should_run/conc018.stdout new file mode 100644 index 0000000000..dd56b71f23 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc018.stdout @@ -0,0 +1 @@ +thread blocked indefinitely in an MVar operation diff --git a/testsuite/tests/concurrent/should_run/conc019.hs b/testsuite/tests/concurrent/should_run/conc019.hs new file mode 100644 index 0000000000..51b3d7563a --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc019.hs @@ -0,0 +1,14 @@ +import Control.Concurrent +import Control.Exception +import Data.List +import System.Mem + +-- !!! test that a child thread waiting on its own MVar will get killed by +-- a signal. + +main = do + forkIO (Control.Exception.catch (do { m <- newEmptyMVar; takeMVar m }) + $ \e -> putStrLn ("caught: " ++ show (e::SomeException))) + threadDelay 10000 + System.Mem.performGC + threadDelay 10000 diff --git a/testsuite/tests/concurrent/should_run/conc019.stdout b/testsuite/tests/concurrent/should_run/conc019.stdout new file mode 100644 index 0000000000..aba647b928 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc019.stdout @@ -0,0 +1 @@ +caught: thread blocked indefinitely in an MVar operation diff --git a/testsuite/tests/concurrent/should_run/conc020.hs b/testsuite/tests/concurrent/should_run/conc020.hs new file mode 100644 index 0000000000..956b761245 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc020.hs @@ -0,0 +1,10 @@ +import Control.Concurrent +import Control.Exception + +main = do + m <- newEmptyMVar + t <- forkIO (block $ takeMVar m) + threadDelay 100000 + throwTo t (ErrorCall "I'm Interruptible") + threadDelay 100000 + putMVar m () -- to avoid t being garbage collected diff --git a/testsuite/tests/concurrent/should_run/conc020.stderr b/testsuite/tests/concurrent/should_run/conc020.stderr new file mode 100644 index 0000000000..b0bcbfb17f --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc020.stderr @@ -0,0 +1 @@ +conc020: I'm Interruptible diff --git a/testsuite/tests/concurrent/should_run/conc021.hs b/testsuite/tests/concurrent/should_run/conc021.hs new file mode 100644 index 0000000000..c07c48af35 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc021.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Main where + +-- !!! test for uncaught exception + +foreign export ccall foo :: Int -> IO Int +foreign import ccall safe "foo" foo_imported :: Int -> IO Int + +foo n = error "wurble" + +main = foo_imported 3 diff --git a/testsuite/tests/concurrent/should_run/conc021.stderr b/testsuite/tests/concurrent/should_run/conc021.stderr new file mode 100644 index 0000000000..78e92140e6 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc021.stderr @@ -0,0 +1 @@ +conc021: wurble diff --git a/testsuite/tests/concurrent/should_run/conc022.hs b/testsuite/tests/concurrent/should_run/conc022.hs new file mode 100644 index 0000000000..5d420d8af7 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc022.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE MagicHash #-} +-- !!! test tryTakeMVar + +import Control.Concurrent +import Control.Exception + +import GHC.Exts ( fork# ) +import GHC.IO ( IO(..) ) +import GHC.Conc ( ThreadId(..) ) + +main = do + m <- newEmptyMVar + r <- timeout 5 (tryTakeMVar m) (putStrLn "timed out!" >> return Nothing) + print (r :: Maybe Int) + + m <- newMVar True + r <- timeout 5 (tryTakeMVar m) (putStrLn "timed out!" >> return Nothing) + print r + +timeout + :: Int -- secs + -> IO a -- action to run + -> IO a -- action to run on timeout + -> IO a + +timeout secs action on_timeout + = do + threadid <- myThreadId + timeout <- forkIO $ do threadDelay (secs * 1000000) + throwTo threadid (ErrorCall "__timeout") + ( do result <- action + killThread timeout + return result + ) + `Control.Exception.catch` + \exception -> case fromException exception of + Just (ErrorCall "__timeout") -> on_timeout + _other -> do killThread timeout + throw exception + diff --git a/testsuite/tests/concurrent/should_run/conc022.stdout b/testsuite/tests/concurrent/should_run/conc022.stdout new file mode 100644 index 0000000000..07de2e62f6 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc022.stdout @@ -0,0 +1,2 @@ +Nothing +Just True diff --git a/testsuite/tests/concurrent/should_run/conc023.hs b/testsuite/tests/concurrent/should_run/conc023.hs new file mode 100644 index 0000000000..b128c224a3 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc023.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- !!! test threadDelay, Random, and QSemN. + +-- start a large number (n) of threads each of which will wait for a +-- random delay between 0 and m seconds. We use a semaphore to wait +-- for all the threads to finish. + +import System.Random +import Control.Concurrent +import Control.Exception + +n = 5000 -- no. of threads +m = 3000 -- maximum delay + +main = do + s <- newQSemN n + (is :: [Int]) <- sequence (take n (repeat (getStdRandom (randomR (1,m))))) + mapM (fork_sleep s) is + waitQSemN s n + where + fork_sleep s i = forkIO (do waitQSemN s 1 + threadDelay (i*1000) + signalQSemN s 1) diff --git a/testsuite/tests/concurrent/should_run/conc024.hs b/testsuite/tests/concurrent/should_run/conc024.hs new file mode 100644 index 0000000000..e37d64a6e2 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc024.hs @@ -0,0 +1,15 @@ +module Main where + +import Control.Exception +import Control.Concurrent +import Prelude hiding (catch) +import System.Mem + +-- illustrates the BlockOnDeadMVar exception + +main = do + id <- myThreadId + forkIO (catch (do m <- newEmptyMVar; takeMVar m) + (\e -> throwTo id (e::SomeException))) + catch (do yield; performGC; threadDelay 1000000) + (\e -> print (e::SomeException)) diff --git a/testsuite/tests/concurrent/should_run/conc024.stdout b/testsuite/tests/concurrent/should_run/conc024.stdout new file mode 100644 index 0000000000..dd56b71f23 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc024.stdout @@ -0,0 +1 @@ +thread blocked indefinitely in an MVar operation diff --git a/testsuite/tests/concurrent/should_run/conc025.hs b/testsuite/tests/concurrent/should_run/conc025.hs new file mode 100644 index 0000000000..a9591d4223 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc025.hs @@ -0,0 +1,16 @@ +-- !!! Simple test of dupChan +-- Embarassingly, the published version fails! + +module Main where + +import Control.Exception +import Control.Concurrent.Chan + +main = do + chan <- newChan + ch <- dupChan chan + writeChan chan "done" + x <- readChan chan + y <- readChan ch + print ("Got "++x ++" "++y) + diff --git a/testsuite/tests/concurrent/should_run/conc025.stdout b/testsuite/tests/concurrent/should_run/conc025.stdout new file mode 100644 index 0000000000..fb1569261c --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc025.stdout @@ -0,0 +1 @@ +"Got done done" diff --git a/testsuite/tests/concurrent/should_run/conc026.hs b/testsuite/tests/concurrent/should_run/conc026.hs new file mode 100644 index 0000000000..0aa170afb5 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc026.hs @@ -0,0 +1,8 @@ +-- test for blocking putMVar + +import Control.Concurrent + +main = do + m <- newMVar () + forkIO (threadDelay 100000 >> takeMVar m) + putMVar m () diff --git a/testsuite/tests/concurrent/should_run/conc027.hs b/testsuite/tests/concurrent/should_run/conc027.hs new file mode 100644 index 0000000000..4a04211824 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc027.hs @@ -0,0 +1,9 @@ + +import Control.Concurrent + +main = do + m <- newEmptyMVar + end <- newEmptyMVar + forkIO (sequence_ [ putMVar m () | _ <- [1 .. 10000] ]) + forkIO (sequence_ [ takeMVar m | _ <- [1 .. 10000] ] >> putMVar end ()) + takeMVar end diff --git a/testsuite/tests/concurrent/should_run/conc028.hs b/testsuite/tests/concurrent/should_run/conc028.hs new file mode 100644 index 0000000000..4d3d16866a --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc028.hs @@ -0,0 +1,11 @@ +-- test tryPutMVar + +import Control.Concurrent + +main = do + m <- newMVar () + r <- tryPutMVar m () + print r + takeMVar m + r <- tryPutMVar m () + print r diff --git a/testsuite/tests/concurrent/should_run/conc028.stdout b/testsuite/tests/concurrent/should_run/conc028.stdout new file mode 100644 index 0000000000..91d6f80f27 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc028.stdout @@ -0,0 +1,2 @@ +False +True diff --git a/testsuite/tests/concurrent/should_run/conc029.hs b/testsuite/tests/concurrent/should_run/conc029.hs new file mode 100644 index 0000000000..dc1150073d --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc029.hs @@ -0,0 +1,11 @@ +module Main where + +import Control.Exception +import Control.Concurrent +import Prelude hiding (catch) + +-- the BlockOnDeadMVar exception doesn't cause any output by default + +main = do + forkIO (do m <- newEmptyMVar; takeMVar m) + print (sum [1..10000]) diff --git a/testsuite/tests/concurrent/should_run/conc029.stdout b/testsuite/tests/concurrent/should_run/conc029.stdout new file mode 100644 index 0000000000..b9d569380c --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc029.stdout @@ -0,0 +1 @@ +50005000 diff --git a/testsuite/tests/concurrent/should_run/conc030.hs b/testsuite/tests/concurrent/should_run/conc030.hs new file mode 100644 index 0000000000..4f01668456 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc030.hs @@ -0,0 +1,15 @@ +module Main where + +import Control.Exception +import Control.Concurrent +import Prelude hiding (catch) + +-- the ThreadKilled exception doesn't cause any output by default + +main = do + m <- newEmptyMVar + id <- forkIO (takeMVar m) + yield + killThread id + putMVar m () + print (sum [1..50000]) diff --git a/testsuite/tests/concurrent/should_run/conc030.stdout b/testsuite/tests/concurrent/should_run/conc030.stdout new file mode 100644 index 0000000000..ba6ee958ee --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc030.stdout @@ -0,0 +1 @@ +1250025000 diff --git a/testsuite/tests/concurrent/should_run/conc031.hs b/testsuite/tests/concurrent/should_run/conc031.hs new file mode 100644 index 0000000000..c3347550a9 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc031.hs @@ -0,0 +1,30 @@ +import Control.Concurrent +import Control.Exception +import System.Mem ( performGC ) +import System.Mem.Weak ( addFinalizer ) + +data P = P (MVar Bool) + +-- Bug reported by Manuel Chakravarty, namely that we weren't checking +-- for runnable finalizers before declaring that the program is +-- deadlocked. + +main = do +-- gcThread -- with this thread enabled, no error + mv <- newEmptyMVar + let p = P mv + addFinalizer p (set p) + takeMVar mv >>= print + putStrLn "End." + where + set (P mv) = putMVar mv True + -- + -- this is just to demonstrate that it is only about the GC timing + -- + gcThread = forkIO $ let gc = do + putStrLn "delay" + threadDelay 100000 + putStrLn "gc" + performGC + gc + in gc diff --git a/testsuite/tests/concurrent/should_run/conc031.stdout b/testsuite/tests/concurrent/should_run/conc031.stdout new file mode 100644 index 0000000000..8d45abf2c7 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc031.stdout @@ -0,0 +1,2 @@ +True +End. diff --git a/testsuite/tests/concurrent/should_run/conc032.hs b/testsuite/tests/concurrent/should_run/conc032.hs new file mode 100644 index 0000000000..42149ff477 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc032.hs @@ -0,0 +1,74 @@ +-- !!! this test exposed a bug in the take/putMVar implementation in +-- !!! GHC 5.00. It involves multiple blocking takes & puts on the +-- !!! same MVar. + +import Control.Concurrent +import System.IO.Unsafe + +awk True True z = 1 +awk False y True = 2 +awk x False False = 3 + +awk'1 True True z = 1 +awk'2 False y True = 2 +awk'3 x False False = 3 + +awk' x y z | ppm [a1'1,a1'2,a1'3] (x,y,z) = awk'1 x y z + | ppm [a2'1,a2'2,a2'3] (x,y,z) = awk'2 x y z + | ppm [a3'1,a3'2,a3'3] (x,y,z) = awk'3 x y z + | otherwise = 0 + +a1'1 (True,y,z) s = s True +a1'1 (x,y,z) s = s False + +a1'2 (x,True,z) s = s True +a1'2 (x,y,z) s = s False + +a1'3 (x,y,z) s = s True + +a2'1 (False,y,z) s = s True +a2'1 (x,y,z) s = s False + +a2'2 (x,y,z) s = s True + +a2'3 (x,y,True) s = s True +a2'3 (x,y,z) s = s False + +a3'1 (x,y,z) s = s True + +a3'2 (x,False,z) s = s True +a3'2 (x,y,z) s = s False + +a3'3 (x,y,False) s = s True +a3'3 (x,y,z) s = s False + +ppm fs as = unsafePerformIO (ppm' fs as) + +ppm' fs as = do m <- newEmptyMVar + let s = putMVar m + hs <- sequence [forkIO (f as s)|f <- fs] + result <- assess (length fs) m + sequence (map killThread hs) + return result + where assess 0 m = return True + assess n m = do h <- takeMVar m + if h then (assess (n-1) m) + else return False + +main = do sequence [putStrLn (show (awk' x y z))|(x,y,z) <- args] + where args = [ + (t,t,t), + (t,t,f), + (t,f,t), + (t,f,f), + (f,t,t), + (f,t,f), + (f,f,t), + (f,f,f), + (t,t,n) + --(f,n,t), + --(n,f,f), + ] + t = True + f = False + n = odd (last [1..]) diff --git a/testsuite/tests/concurrent/should_run/conc032.stdout b/testsuite/tests/concurrent/should_run/conc032.stdout new file mode 100644 index 0000000000..a357bc8aac --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc032.stdout @@ -0,0 +1,9 @@ +1 +1 +0 +3 +2 +0 +2 +3 +1 diff --git a/testsuite/tests/concurrent/should_run/conc033.hs b/testsuite/tests/concurrent/should_run/conc033.hs new file mode 100644 index 0000000000..6933822e56 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc033.hs @@ -0,0 +1,10 @@ +import Control.Concurrent +import Control.Exception + +-- !!! test that deadlock is raised as an exception properly +main = do + r <- Control.Exception.try $ do + m <- newEmptyMVar + takeMVar m + return () + print (r::Either SomeException ()) diff --git a/testsuite/tests/concurrent/should_run/conc033.stdout b/testsuite/tests/concurrent/should_run/conc033.stdout new file mode 100644 index 0000000000..1c0eba9dec --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc033.stdout @@ -0,0 +1 @@ +Left thread blocked indefinitely in an MVar operation diff --git a/testsuite/tests/concurrent/should_run/conc034.hs b/testsuite/tests/concurrent/should_run/conc034.hs new file mode 100644 index 0000000000..4101212ad1 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc034.hs @@ -0,0 +1,31 @@ +import Control.Concurrent +import Control.Exception +import Foreign + +import System.IO (hFlush,stdout) + +import Prelude hiding (catch) + +-- !!! Try to get two threads into a knot depending on each other. + +-- This should result in the main thread being sent a NonTermination +-- exception (in GHC 5.02, the program is terminated with "no threads +-- to run" instead). + +main = do + Foreign.newStablePtr stdout + -- HACK, because when these two threads get blocked on each other, + -- there's nothing keeping stdout alive so it will get finalized. + -- SDM 12/3/2004 + let a = last ([1..10000] ++ [b]) + b = last ([2..10000] ++ [a]) + -- we have to be careful to ensure that the strictness analyser + -- can't see that a and b are both bottom, otherwise the + -- simplifier will go to town here, resulting in something like + -- a = a and b = a. + forkIO (print a `catch` \NonTermination -> return ()) + -- we need to catch in the child thread too, because it might + -- get sent the NonTermination exception first. + r <- Control.Exception.try (print b) + print (r :: Either NonTermination ()) + diff --git a/testsuite/tests/concurrent/should_run/conc034.stdout b/testsuite/tests/concurrent/should_run/conc034.stdout new file mode 100644 index 0000000000..1f83158694 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc034.stdout @@ -0,0 +1 @@ +Left <<loop>> diff --git a/testsuite/tests/concurrent/should_run/conc035.hs b/testsuite/tests/concurrent/should_run/conc035.hs new file mode 100644 index 0000000000..fcb2d5c2e4 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc035.hs @@ -0,0 +1,49 @@ +module Main where + +import Control.Concurrent +import qualified Control.Exception as E + +trapHandler :: MVar Int -> MVar () -> IO () +trapHandler inVar caughtVar = + (do E.block $ do + trapMsg <- takeMVar inVar + putStrLn ("Handler got: " ++ show trapMsg) + trapHandler inVar caughtVar + ) + `E.catch` + (trapExc inVar caughtVar) + +trapExc :: MVar Int -> MVar () -> E.SomeException -> IO () +-- If we have been killed then we are done +trapExc inVar caughtVar e + | Just E.ThreadKilled <- E.fromException e = return () +-- Otherwise... +trapExc inVar caughtVar e = + do putStrLn ("Exception: " ++ show e) + putMVar caughtVar () + trapHandler inVar caughtVar + +main :: IO () +main = do + inVar <- newEmptyMVar + caughtVar <- newEmptyMVar + tid <- forkIO (trapHandler inVar caughtVar) + yield + putMVar inVar 1 + threadDelay 1000 + throwTo tid (E.ErrorCall "1st") + takeMVar caughtVar + putMVar inVar 2 + threadDelay 1000 + throwTo tid (E.ErrorCall "2nd") + -- the second time around, exceptions will be blocked, because + -- the trapHandler is effectively "still in the handler" from the + -- first exception. I'm not sure if this is by design or by + -- accident. Anyway, the trapHandler will at some point block + -- in takeMVar, and thereby become interruptible, at which point + -- it will receive the second exception. + takeMVar caughtVar + -- Running the GHCi way complains that tid is blocked indefinitely if + -- it still exists, so kill it. + killThread tid + putStrLn "All done" diff --git a/testsuite/tests/concurrent/should_run/conc035.stdout b/testsuite/tests/concurrent/should_run/conc035.stdout new file mode 100644 index 0000000000..f667439731 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc035.stdout @@ -0,0 +1,5 @@ +Handler got: 1 +Exception: 1st +Handler got: 2 +Exception: 2nd +All done diff --git a/testsuite/tests/concurrent/should_run/conc036.hs b/testsuite/tests/concurrent/should_run/conc036.hs new file mode 100644 index 0000000000..ead85a530d --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc036.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# OPTIONS -cpp #-} +module Main where + +import Control.Concurrent +import Control.Exception +import Prelude hiding (catch) +import Foreign +import System.IO + +#ifdef 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 + newStablePtr stdout -- prevent stdout being finalized, sigh + th <- newEmptyMVar + forkIO $ do + putStrLn "newThread started" + sleep 1 + putMVar th "child" + threadDelay 500000 + yield -- another hack, just in case child yields right after "sleep 1" + putMVar th "main" `catch` (\BlockedIndefinitelyOnMVar -> return ()) + -- tests that the other thread doing an unsafe call to + -- sleep(3) has blocked this thread. Not sure if this + -- is a useful test. + x <- takeMVar th + putStrLn x + putStrLn "\nshutting down" diff --git a/testsuite/tests/concurrent/should_run/conc036.stdout b/testsuite/tests/concurrent/should_run/conc036.stdout new file mode 100644 index 0000000000..d5fb94ff25 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc036.stdout @@ -0,0 +1,4 @@ +newThread started +child + +shutting down diff --git a/testsuite/tests/concurrent/should_run/conc037.hs b/testsuite/tests/concurrent/should_run/conc037.hs new file mode 100644 index 0000000000..7da76f5025 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc037.hs @@ -0,0 +1,27 @@ +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE ForeignFunctionInterface #-} +module Main where + +import Control.Concurrent + +#ifdef mingw32_HOST_OS +foreign import stdcall safe "Sleep" _sleepBlock :: Int -> IO () +sleepBlock n = _sleepBlock (n*1000) +#else +foreign import ccall safe "sleep" sleepBlock :: Int -> IO () +#endif + +main :: IO () +main = do + th <- newEmptyMVar + forkIO $ do + putStrLn "newThread started" + sleepBlock 1 + putStrLn "newThread back again" + putMVar th "1 sec later" + threadDelay 200000 -- make sure the newly created thread is run. + putStrLn "mainThread" + x <- takeMVar th + putStrLn x + putStrLn "\nshutting down" + diff --git a/testsuite/tests/concurrent/should_run/conc037.stdout b/testsuite/tests/concurrent/should_run/conc037.stdout new file mode 100644 index 0000000000..18c9f447f6 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc037.stdout @@ -0,0 +1,6 @@ +newThread started +mainThread +newThread back again +1 sec later + +shutting down diff --git a/testsuite/tests/concurrent/should_run/conc038.hs b/testsuite/tests/concurrent/should_run/conc038.hs new file mode 100644 index 0000000000..0cf82f3b24 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc038.hs @@ -0,0 +1,37 @@ +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE ForeignFunctionInterface #-} +module Main where + +import Control.Concurrent + +haskellFun :: Int -> IO () +haskellFun c = putStrLn ("Haskell: " ++ show c) + +foreign export ccall "hFun" haskellFun :: Int -> IO () +foreign import ccall safe "hFun" hFun :: Int -> IO () + +#ifdef mingw32_HOST_OS +foreign import stdcall safe "Sleep" _sleepBlock :: Int -> IO () +sleepBlock n = _sleepBlock (n*1000) +#else +foreign import ccall safe "sleep" sleepBlock :: Int -> IO () +#endif + + + +main :: IO () +main = do + th <- newEmptyMVar + forkIO $ do + putStrLn "newThread started" + sleepBlock 1 + putStrLn "newThread back again" + putMVar th "1 sec later" + threadDelay 500000 >> putStrLn "mainThread" + -- this will not be blocked in the threaded RTS + forkIO $ (hFun 2) + -- neither will this + x <- takeMVar th + putStrLn x + putStrLn "\nshutting down" + diff --git a/testsuite/tests/concurrent/should_run/conc038.stdout b/testsuite/tests/concurrent/should_run/conc038.stdout new file mode 100644 index 0000000000..21fc15c4e2 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc038.stdout @@ -0,0 +1,7 @@ +newThread started +mainThread +Haskell: 2 +newThread back again +1 sec later + +shutting down diff --git a/testsuite/tests/concurrent/should_run/conc039.hs b/testsuite/tests/concurrent/should_run/conc039.hs new file mode 100644 index 0000000000..dc5d181a31 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc039.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +import Foreign +import System.Mem +import Control.Concurrent + +foreign export ccall "performGC_" performGC' :: IO () +performGC' = do putMVar m (); yield; performGC + +foreign import ccall "performGC_" f :: IO () + +{-# NOINLINE m #-} +m = unsafePerformIO newEmptyMVar + +main = do + forkIO f + takeMVar m + +-- This tests for a bug in the garbage collector, whereby a main +-- thread that has completed may be GC'd before its return value is +-- propagated back to the caller of rts_evalIO(). +-- +-- The sequence we hope to create is: +-- - main thread (1) forks off thread (2) +-- - thread (2) invokes new main thread (3) via a 'safe' ccall +-- - thread (3) yields to thread (1) +-- - thread (1) completes, but cannot return yet because (3) +-- is the current main thread (unless we +-- are in SMP or RTS_SUPPORTS_THREADS mode) +-- - thread (3) invokes a GC +-- - thread (1) is GC'd, unless we're careful! diff --git a/testsuite/tests/concurrent/should_run/conc040.hs b/testsuite/tests/concurrent/should_run/conc040.hs new file mode 100644 index 0000000000..be3bfdb915 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc040.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +import Foreign +import Data.IORef +import Control.Concurrent +import Control.Exception + +foreign import ccall "wrapper" + wrap :: IO () -> IO (FunPtr (IO ())) + +foreign import ccall "dynamic" + invoke :: FunPtr (IO ()) -> IO () + +{-# NOINLINE m #-} +m :: IORef ThreadId +m = unsafePerformIO (newIORef (error "m")) + +main = do + id <- myThreadId + writeIORef m id + raise' <- wrap raise + invoke raise' + +raise = do + id <- readIORef m + me <- myThreadId + forkIO $ do threadDelay 10000; throwTo me (ErrorCall "timeout") + throwTo id (ErrorCall "kapow!") diff --git a/testsuite/tests/concurrent/should_run/conc040.stderr b/testsuite/tests/concurrent/should_run/conc040.stderr new file mode 100644 index 0000000000..d113a02a99 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc040.stderr @@ -0,0 +1 @@ +conc040: timeout diff --git a/testsuite/tests/concurrent/should_run/conc041.hs b/testsuite/tests/concurrent/should_run/conc041.hs new file mode 100644 index 0000000000..8aec345b1c --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc041.hs @@ -0,0 +1,9 @@ +module Main where + +import GHC.Conc + +-- Create a new TVar and never use it +main = do + putStr "Before\n" + t <- atomically ( newTVar 42 ) + putStr "After\n" diff --git a/testsuite/tests/concurrent/should_run/conc041.stderr b/testsuite/tests/concurrent/should_run/conc041.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc041.stderr diff --git a/testsuite/tests/concurrent/should_run/conc041.stdout b/testsuite/tests/concurrent/should_run/conc041.stdout new file mode 100644 index 0000000000..a84f0c9779 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc041.stdout @@ -0,0 +1,2 @@ +Before
+After
diff --git a/testsuite/tests/concurrent/should_run/conc042.hs b/testsuite/tests/concurrent/should_run/conc042.hs new file mode 100644 index 0000000000..9ebbf3e4ea --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc042.hs @@ -0,0 +1,11 @@ +module Main where + +import GHC.Conc + +-- Create a new TVar and check that it contains the expected value +main = do + putStr "Before\n" + t <- atomically ( newTVar 42 ) + r <- atomically ( readTVar t ) + putStr ("After " ++ (show r) ++ "\n") + diff --git a/testsuite/tests/concurrent/should_run/conc042.stderr b/testsuite/tests/concurrent/should_run/conc042.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc042.stderr diff --git a/testsuite/tests/concurrent/should_run/conc042.stdout b/testsuite/tests/concurrent/should_run/conc042.stdout new file mode 100644 index 0000000000..6fea5e3fe9 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc042.stdout @@ -0,0 +1,2 @@ +Before
+After 42
diff --git a/testsuite/tests/concurrent/should_run/conc043.hs b/testsuite/tests/concurrent/should_run/conc043.hs new file mode 100644 index 0000000000..18cf1196f7 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc043.hs @@ -0,0 +1,13 @@ +module Main where + +import GHC.Conc + +-- Create a new TVar, update it and check that it contains the expected value after the +-- transaction +main = do + putStr "Before\n" + t <- atomically ( newTVar 42 ) + atomically ( writeTVar t 17 ) + r <- atomically ( readTVar t ) + putStr ("After " ++ (show r) ++ "\n") + diff --git a/testsuite/tests/concurrent/should_run/conc043.stderr b/testsuite/tests/concurrent/should_run/conc043.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc043.stderr diff --git a/testsuite/tests/concurrent/should_run/conc043.stdout b/testsuite/tests/concurrent/should_run/conc043.stdout new file mode 100644 index 0000000000..8b2ff8961d --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc043.stdout @@ -0,0 +1,2 @@ +Before
+After 17
diff --git a/testsuite/tests/concurrent/should_run/conc044.hs b/testsuite/tests/concurrent/should_run/conc044.hs new file mode 100644 index 0000000000..0ad4701f8b --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc044.hs @@ -0,0 +1,13 @@ +module Main where + +import GHC.Conc + +-- Create a new TVar, update it and check that it contains the expected value within +-- the transaction +main = do + putStr "Before\n" + t <- atomically ( newTVar 42 ) + r <- atomically ( do writeTVar t 17 + readTVar t) + putStr ("After " ++ (show r) ++ "\n") + diff --git a/testsuite/tests/concurrent/should_run/conc044.stderr b/testsuite/tests/concurrent/should_run/conc044.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc044.stderr diff --git a/testsuite/tests/concurrent/should_run/conc044.stdout b/testsuite/tests/concurrent/should_run/conc044.stdout new file mode 100644 index 0000000000..8b2ff8961d --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc044.stdout @@ -0,0 +1,2 @@ +Before
+After 17
diff --git a/testsuite/tests/concurrent/should_run/conc045.hs b/testsuite/tests/concurrent/should_run/conc045.hs new file mode 100644 index 0000000000..4ab585eef3 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc045.hs @@ -0,0 +1,39 @@ +module Main where + +import GHC.Conc +import Control.Concurrent + +snapshot t1 t2 = atomically ( do v1 <- readTVar t1 + v2 <- readTVar t2 + return (v1, v2) ) + +twiddle mv _ _ 0 = putMVar mv () +twiddle mv t1 t2 n = do atomically ( do v1 <- readTVar t1 + v2 <- readTVar t2 + writeTVar t2 (v1+1) + writeTVar t1 (v2+1) ) + twiddle mv t1 t2 (n-1) + + +-- Contended updates to a pair of TVars +main = do + putStr "Before\n" + (t1,t2) <- atomically ( do t1 <- newTVar 0 + t2 <- newTVar 1 + return (t1, t2)) + + -- MVars used to signal completion + t1c <- newEmptyMVar + t2c <- newEmptyMVar + + forkIO (twiddle t1c t1 t2 1000) + forkIO (twiddle t2c t1 t2 1000) + + -- Wait for threads to exit + takeMVar t1c + takeMVar t2c + + -- Display final state + (r1,r2) <- snapshot t1 t2 + putStr ("After " ++ (show r1) ++ " , " ++ (show r2) ++ "\n") + diff --git a/testsuite/tests/concurrent/should_run/conc045.stderr b/testsuite/tests/concurrent/should_run/conc045.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc045.stderr diff --git a/testsuite/tests/concurrent/should_run/conc045.stdout b/testsuite/tests/concurrent/should_run/conc045.stdout new file mode 100644 index 0000000000..31640611f4 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc045.stdout @@ -0,0 +1,2 @@ +Before
+After 2000 , 2001
diff --git a/testsuite/tests/concurrent/should_run/conc051.hs b/testsuite/tests/concurrent/should_run/conc051.hs new file mode 100644 index 0000000000..db8a796a9c --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc051.hs @@ -0,0 +1,32 @@ +module Main (main) where + +import System.Environment +import Control.Concurrent +import Control.Monad + +----------------------------------------------------------------------------- +-- test MVar throughput between the main thread and a child thread + +-- This test runs quite slowly on the threaded/SMP RTS vs. the normal RTS, +-- because the main thread and child thread are run by different OS threads, +-- so each MVar communication requires real OS thread switching. +-- +-- Figures I get are about a factor of 10 difference in speed, at GHC 6.5. + +main = chanTest 300000 + +chanTest :: Int -> IO () +chanTest n = do + chan <- newEmptyMVar + forkIO (writer chan n) + reader chan n + +reader chan 0 = return () +reader chan n = do + takeMVar chan + reader chan (n-1) + +writer chan 0 = return () +writer chan n = do + putMVar chan () + writer chan (n-1) diff --git a/testsuite/tests/concurrent/should_run/conc058.hs b/testsuite/tests/concurrent/should_run/conc058.hs new file mode 100644 index 0000000000..5fbe4e5af8 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc058.hs @@ -0,0 +1,13 @@ +import Control.Concurrent +import Control.Exception + +-- variation on conc020 that tests for threadDelay being interruptible. +-- On Windows, with the threaded RTS, in 6.6 and earlier, threadDelay is +-- not interruptible. +main = do + m <- newEmptyMVar + t <- forkIO (block $ threadDelay 1000000) + threadDelay 100000 + throwTo t (ErrorCall "I'm Interruptible") + threadDelay 100000 + putMVar m () -- to avoid t being garbage collected diff --git a/testsuite/tests/concurrent/should_run/conc058.stderr b/testsuite/tests/concurrent/should_run/conc058.stderr new file mode 100644 index 0000000000..2b5ddd02dc --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc058.stderr @@ -0,0 +1 @@ +conc058: I'm Interruptible diff --git a/testsuite/tests/concurrent/should_run/conc059.hs b/testsuite/tests/concurrent/should_run/conc059.hs new file mode 100644 index 0000000000..bed28d27cb --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc059.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +module Test where + +import Control.Concurrent +import Control.Monad +import Foreign.C + +-- See also conc059_c.c +-- +-- This test fires off some threads that will return after the RTS has +-- shut down. This should not crash or confuse the RTS. + +f :: Int -> IO () +f x = do + print x + replicateM_ 10 $ forkIO $ do usleep (fromIntegral x); putStrLn "hello" + return () + +foreign export ccall "f" f :: Int -> IO () + +#ifdef mingw32_HOST_OS +foreign import stdcall safe "Sleep" _sleep :: Int -> IO () +usleep n = _sleep (n `quot` 1000) +#else +foreign import ccall safe "usleep" usleep :: Int -> IO () +#endif diff --git a/testsuite/tests/concurrent/should_run/conc059.stdout b/testsuite/tests/concurrent/should_run/conc059.stdout new file mode 100644 index 0000000000..92911bfda2 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc059.stdout @@ -0,0 +1,2 @@ +exiting... +exited. diff --git a/testsuite/tests/concurrent/should_run/conc059_c.c b/testsuite/tests/concurrent/should_run/conc059_c.c new file mode 100644 index 0000000000..f15fbdd735 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc059_c.c @@ -0,0 +1,30 @@ +#include "HsFFI.h" +#include "conc059_stub.h" +#include <unistd.h> +#include <stdio.h> +#if mingw32_HOST_OS +#include <windows.h> +#endif + +void __stginit_Test(void); + +int main(int argc, char *argv[]) +{ + hs_init(&argc,&argv); + hs_add_root(__stginit_Test); + f(500000); +#if mingw32_HOST_OS + Sleep(100); +#else + usleep(100000); +#endif + printf("exiting...\n"); + hs_exit(); + printf("exited.\n"); +#if mingw32_HOST_OS + Sleep(1000); +#else + usleep(1000000); +#endif + exit(0); +} diff --git a/testsuite/tests/concurrent/should_run/conc064.hs b/testsuite/tests/concurrent/should_run/conc064.hs new file mode 100644 index 0000000000..d37387c601 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc064.hs @@ -0,0 +1,30 @@ +-- test for bug #1067 + +import Control.Concurrent +import Control.Exception + +main = do + master <- myThreadId + test master 10 + -- make sure we catch a final NonTermination exception to get + -- a consistent result. + threadDelay (10 * one_second) + +test tid 0 = return () +test tid n = do + e <- try threads + case e of + Left NonTermination -> test tid (n-1) + Right _ -> return () + where + threads = do sequence $ replicate 3 $ + forkIO $ do t <- myThreadId + --putStrLn ("Start " ++ show t) + threadDelay one_second + --putStrLn ("End " ++ show t) + throwTo tid NonTermination + --putStrLn ("Thrown " ++ show t) + threadDelay (10 * one_second) + +one_second :: Int +one_second = 100000 diff --git a/testsuite/tests/concurrent/should_run/conc064.stderr b/testsuite/tests/concurrent/should_run/conc064.stderr new file mode 100644 index 0000000000..9a49972f77 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc064.stderr @@ -0,0 +1 @@ +conc064: <<loop>> diff --git a/testsuite/tests/concurrent/should_run/conc065.hs b/testsuite/tests/concurrent/should_run/conc065.hs new file mode 100644 index 0000000000..db6d7cf3ba --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc065.hs @@ -0,0 +1,13 @@ +-- Test for bug #1047 + +import Control.Concurrent +import Control.Exception + +-- This loop spends most of its time printing stuff, and very occasionally +-- pops outside 'block'. This test ensures that an thread trying to +-- throwTo this thread will eventually succeed. +loop = block (print "alive") >> loop + +main = do tid <- forkIO loop + threadDelay 1 + killThread tid diff --git a/testsuite/tests/concurrent/should_run/conc066.hs b/testsuite/tests/concurrent/should_run/conc066.hs new file mode 100644 index 0000000000..81638dfd10 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc066.hs @@ -0,0 +1,13 @@ +-- Test for bug #1047 + +import Control.Concurrent +import Control.Exception + +-- This loop spends most of its time printing stuff, and very occasionally +-- executes 'unblock (return ())'. This test ensures that a thread waiting +-- to throwTo this thread is not blocked indefinitely. +loop = do unblock (return ()); print "alive"; loop + +main = do tid <- forkIO (block loop) + yield + killThread tid diff --git a/testsuite/tests/concurrent/should_run/conc067.hs b/testsuite/tests/concurrent/should_run/conc067.hs new file mode 100644 index 0000000000..ef6dde3ff7 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc067.hs @@ -0,0 +1,16 @@ +-- Test for bug #418 + +module Main where + +import Control.Concurrent +import System.IO.Unsafe (unsafeInterleaveIO) + +main = do + v <- newEmptyMVar + a <- unsafeInterleaveIO (readMVar v) + t <- forkIO (print a) + threadDelay (100*1000) + killThread t + forkIO $ print a + putMVar v () + diff --git a/testsuite/tests/concurrent/should_run/conc068.hs b/testsuite/tests/concurrent/should_run/conc068.hs new file mode 100644 index 0000000000..eb90d06591 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc068.hs @@ -0,0 +1,14 @@ +import Control.Concurrent +import Control.Exception +import GHC.Conc + +-- test forkBlockIO +main = do + main_thread <- myThreadId + m <- newEmptyMVar + sub_thread <- block $ forkIO $ + sum [1..100000] `seq` + throwTo main_thread (ErrorCall "foo") + killThread sub_thread + putStrLn "oops" + diff --git a/testsuite/tests/concurrent/should_run/conc068.stderr b/testsuite/tests/concurrent/should_run/conc068.stderr new file mode 100644 index 0000000000..bf40dfdd92 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc068.stderr @@ -0,0 +1 @@ +conc068: foo diff --git a/testsuite/tests/concurrent/should_run/conc069.hs b/testsuite/tests/concurrent/should_run/conc069.hs new file mode 100644 index 0000000000..fd757133a5 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc069.hs @@ -0,0 +1,19 @@ +import Control.Concurrent +import Control.Exception + +main = do + -- stat -- main thread is not bound in GHCi + m <- newEmptyMVar + forkIO (do stat; putMVar m ()) + takeMVar m + block $ forkIO (do stat; putMVar m ()) + takeMVar m + forkOS (do stat; putMVar m ()) + takeMVar m + block $ forkOS (do stat; putMVar m ()) + takeMVar m + +stat = do + x <- isCurrentThreadBound + y <- blocked + print (x,y) diff --git a/testsuite/tests/concurrent/should_run/conc069.stdout b/testsuite/tests/concurrent/should_run/conc069.stdout new file mode 100644 index 0000000000..240e16e63f --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc069.stdout @@ -0,0 +1,4 @@ +(False,False) +(False,True) +(True,False) +(True,True) diff --git a/testsuite/tests/concurrent/should_run/conc069a.hs b/testsuite/tests/concurrent/should_run/conc069a.hs new file mode 100644 index 0000000000..5bf619bec1 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc069a.hs @@ -0,0 +1,19 @@ +import Control.Concurrent +import Control.Exception + +main = do + -- stat -- main thread is not bound in GHCi + m <- newEmptyMVar + forkIO (do stat; putMVar m ()) + takeMVar m + mask_ $ forkIO (do stat; putMVar m ()) + takeMVar m + forkOS (do stat; putMVar m ()) + takeMVar m + mask_ $ forkOS (do stat; putMVar m ()) + takeMVar m + +stat = do + x <- isCurrentThreadBound + y <- getMaskingState + print (x,y) diff --git a/testsuite/tests/concurrent/should_run/conc069a.stdout b/testsuite/tests/concurrent/should_run/conc069a.stdout new file mode 100644 index 0000000000..0883f133dc --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc069a.stdout @@ -0,0 +1,4 @@ +(False,Unmasked) +(False,MaskedInterruptible) +(True,Unmasked) +(True,MaskedInterruptible) diff --git a/testsuite/tests/concurrent/should_run/conc070.hs b/testsuite/tests/concurrent/should_run/conc070.hs new file mode 100644 index 0000000000..71eb415427 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc070.hs @@ -0,0 +1,18 @@ +import Control.Concurrent +import GHC.Conc +import Data.List +import Data.Maybe + +main = do + t1 <- forkIO (threadDelay 100000000) + m <- newEmptyMVar + t2 <- forkIO (takeMVar m) + t3 <- forkIO (let loop = do r <- tryTakeMVar m; + _ <- newEmptyMVar -- do some allocation :( + if isNothing r then loop else return () + in loop) + t4 <- forkIO (return ()) + yield + threadDelay 10000 + print =<< mapM threadStatus [t1,t2,t3,t4] + putMVar m () diff --git a/testsuite/tests/concurrent/should_run/conc070.stdout b/testsuite/tests/concurrent/should_run/conc070.stdout new file mode 100644 index 0000000000..30f0076668 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc070.stdout @@ -0,0 +1 @@ +[ThreadBlocked BlockedOnMVar,ThreadBlocked BlockedOnMVar,ThreadRunning,ThreadFinished] diff --git a/testsuite/tests/concurrent/should_run/conc071.hs b/testsuite/tests/concurrent/should_run/conc071.hs new file mode 100644 index 0000000000..7c58efbc9f --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc071.hs @@ -0,0 +1,11 @@ +module Main where + +import Control.Concurrent + +main = do + t <- forkIO (return ()) + threadCapability t >>= print + t <- forkOn 0 (return ()) + threadCapability t >>= print + t <- forkOn 1 (return ()) + threadCapability t >>= print diff --git a/testsuite/tests/concurrent/should_run/conc071.stdout b/testsuite/tests/concurrent/should_run/conc071.stdout new file mode 100644 index 0000000000..9933b254fe --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc071.stdout @@ -0,0 +1,3 @@ +(0,False) +(0,True) +(0,True) diff --git a/testsuite/tests/concurrent/should_run/conc072.hs b/testsuite/tests/concurrent/should_run/conc072.hs new file mode 100644 index 0000000000..8f1218084c --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc072.hs @@ -0,0 +1,9 @@ +module Main where + +import Control.Concurrent + +main = do + t <- forkOn 0 (return ()) + threadCapability t >>= print + t <- forkOn 1 (return ()) + threadCapability t >>= print diff --git a/testsuite/tests/concurrent/should_run/conc072.stdout b/testsuite/tests/concurrent/should_run/conc072.stdout new file mode 100644 index 0000000000..739ac3797e --- /dev/null +++ b/testsuite/tests/concurrent/should_run/conc072.stdout @@ -0,0 +1,2 @@ +(0,True) +(1,True) diff --git a/testsuite/tests/concurrent/should_run/foreignInterruptible.hs b/testsuite/tests/concurrent/should_run/foreignInterruptible.hs new file mode 100644 index 0000000000..32252fb8db --- /dev/null +++ b/testsuite/tests/concurrent/should_run/foreignInterruptible.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# OPTIONS -cpp #-} +module Main where + +import Control.Concurrent +import Control.Exception +import Prelude hiding (catch) +import Foreign +import System.IO + +#ifdef mingw32_HOST_OS +sleep n = sleepBlock (n*1000) +foreign import stdcall interruptible "Sleep" sleepBlock :: Int -> IO () +#else +sleep n = sleepBlock n +foreign import ccall interruptible "sleep" sleepBlock :: Int -> IO () +#endif + +main :: IO () +main = do + newStablePtr stdout -- prevent stdout being finalized + th <- newEmptyMVar + tid <- forkIO $ do + putStrLn "newThread started" + (sleep 2 >> putStrLn "fail") `catch` (\ThreadKilled -> putStrLn "pass") + putMVar th "child" + yield + threadDelay 500000 + killThread tid + x <- takeMVar th + putStrLn x + putStrLn "\nshutting down" diff --git a/testsuite/tests/concurrent/should_run/foreignInterruptible.stdout b/testsuite/tests/concurrent/should_run/foreignInterruptible.stdout new file mode 100644 index 0000000000..4048ae362e --- /dev/null +++ b/testsuite/tests/concurrent/should_run/foreignInterruptible.stdout @@ -0,0 +1,5 @@ +newThread started +pass +child + +shutting down diff --git a/testsuite/tests/concurrent/should_run/mask001.hs b/testsuite/tests/concurrent/should_run/mask001.hs new file mode 100644 index 0000000000..96bbf53c73 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/mask001.hs @@ -0,0 +1,70 @@ +import Control.Exception +import Text.Printf + +-- Test all the various combinations of nesting mask/uninterruptibleMask + +main = do + stat 1 Unmasked + mask_ $ stat 2 MaskedInterruptible + mask $ \restore -> do + stat 3 MaskedInterruptible + restore $ stat 4 Unmasked + restore $ restore $ stat 5 Unmasked + stat 6 MaskedInterruptible + uninterruptibleMask $ \restore -> do + stat 7 MaskedUninterruptible + restore $ stat 8 MaskedInterruptible + restore $ restore $ stat 9 MaskedInterruptible + stat 10 MaskedUninterruptible + mask $ \restore -> do + stat 11 MaskedUninterruptible + restore $ stat 12 MaskedUninterruptible + restore $ restore $ stat 13 MaskedUninterruptible + stat 14 MaskedUninterruptible + stat 15 MaskedUninterruptible + stat 16 MaskedInterruptible + stat 17 Unmasked + + uninterruptibleMask $ \restore -> do + stat 20 MaskedUninterruptible + restore $ stat 21 Unmasked + restore $ restore $ stat 22 Unmasked + stat 23 MaskedUninterruptible + mask $ \restore -> do + stat 24 MaskedUninterruptible + restore $ stat 25 MaskedUninterruptible + restore $ restore $ stat 26 MaskedUninterruptible + stat 27 MaskedUninterruptible + uninterruptibleMask $ \restore -> do + stat 28 MaskedUninterruptible + restore $ stat 29 MaskedUninterruptible + restore $ restore $ stat 30 MaskedUninterruptible + stat 31 MaskedUninterruptible + stat 32 MaskedUninterruptible + stat 33 MaskedUninterruptible + stat 34 Unmasked + + -- it is possible to call a restore from a mask that is not the + -- innermost enclosing one, although this is not a recommended use + -- of the API. + mask $ \restore0 -> do + stat 41 MaskedInterruptible + -- it is possible to call a restore from a mask that is not the + uninterruptibleMask $ \restore1 -> do + stat 42 MaskedUninterruptible + restore0 $ stat 43 Unmasked + restore0 $ restore0 $ stat 44 Unmasked + restore1 $ stat 45 MaskedInterruptible + restore1 $ restore1 $ stat 46 MaskedInterruptible + restore0 $ restore1 $ stat 47 MaskedInterruptible + restore1 $ restore0 $ stat 48 Unmasked + stat 49 MaskedUninterruptible + stat 50 MaskedInterruptible + stat 51 Unmasked + +stat :: Int -> MaskingState -> IO () +stat n m = do + s <- getMaskingState + if (s /= m) + then error (printf "%2d: %s\n" n (show s)) + else return () diff --git a/testsuite/tests/concurrent/should_run/mask002.hs b/testsuite/tests/concurrent/should_run/mask002.hs new file mode 100644 index 0000000000..15b2e64a00 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/mask002.hs @@ -0,0 +1,32 @@ +import Control.Exception +import Control.Concurrent +import Text.Printf +import Prelude hiding(catch) + +-- Test combinations of nesting mask/uninterruptibleMask with +-- forkIO/forkIOUnmask + +main = do + m <- newEmptyMVar + t1 <- mask_ $ forkIO $ do + takeMVar m `catch` \e -> do stat 1 MaskedInterruptible + print (e::SomeException) + throwIO e + killThread t1 + t2 <- uninterruptibleMask_ $ forkIO $ do + takeMVar m `catch` \e -> do stat 2 MaskedUninterruptible + print (e::SomeException) + throwIO e + killThread t2 + t3 <- mask_ $ forkIOUnmasked $ do stat 3 Unmasked; putMVar m () + takeMVar m + t4 <- uninterruptibleMask_ $ forkIOUnmasked $ do stat 4 Unmasked; putMVar m () + takeMVar m + +stat :: Int -> MaskingState -> IO () +stat n m = do + s <- getMaskingState + if (s /= m) + then error (printf "%2d: %s\n" n (show s)) + else return () + diff --git a/testsuite/tests/concurrent/should_run/mask002.stdout b/testsuite/tests/concurrent/should_run/mask002.stdout new file mode 100644 index 0000000000..baa1975a5a --- /dev/null +++ b/testsuite/tests/concurrent/should_run/mask002.stdout @@ -0,0 +1,2 @@ +thread killed +thread blocked indefinitely in an MVar operation diff --git a/testsuite/tests/concurrent/should_run/numsparks001.hs b/testsuite/tests/concurrent/should_run/numsparks001.hs new file mode 100644 index 0000000000..f28bf87d55 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/numsparks001.hs @@ -0,0 +1,11 @@ + +import GHC.Conc + +main = do + let x = length [1..100] + numSparks >>= print + x `par` numSparks >>= print + x `par` numSparks >>= print + x `par` numSparks >>= print + x `par` numSparks >>= print + diff --git a/testsuite/tests/concurrent/should_run/numsparks001.stdout b/testsuite/tests/concurrent/should_run/numsparks001.stdout new file mode 100644 index 0000000000..9dfcf39f5a --- /dev/null +++ b/testsuite/tests/concurrent/should_run/numsparks001.stdout @@ -0,0 +1,5 @@ +0 +1 +2 +3 +4 diff --git a/testsuite/tests/concurrent/should_run/throwto001.hs b/testsuite/tests/concurrent/should_run/throwto001.hs new file mode 100644 index 0000000000..999d3335d8 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/throwto001.hs @@ -0,0 +1,38 @@ +import Control.Concurrent +import Control.Exception +import Data.Array +import System.Random +import System.Environment +import Control.Monad +import GHC.Conc + +-- A fiendish throwTo test. A bunch of threads take random MVars from +-- a shared array; if the MVar has Nothing in it, replace it with Just +-- of the current thread's ThreadId. If the MVar has another ThreadId +-- in it, then killThread that thread, and replace it with the current +-- thread's ThreadId. We keep going until only one thread is left +-- standing. +-- +-- On multiple CPUs this should give throwTo a good workout. +-- +main = do + [m, t] <- fmap (fmap read) getArgs + ms <- replicateM m $ newMVar Nothing + let arr = listArray (1,m) ms + dead <- newTVarIO 0 + ts <- replicateM t $ forkIO (thread m arr `onException` + (atomically $ do d <- readTVar dead + writeTVar dead $! d+1)) + atomically $ do + d <- readTVar dead + when (d < t-1) $ retry + +thread m arr = do + x <- randomIO + id <- myThreadId + modifyMVar_ (arr ! ((x `mod` m) + 1)) $ \b -> + case b of + Nothing -> return (Just id) + Just other -> do when (other /= id) $ killThread other + return (Just id) + thread m arr diff --git a/testsuite/tests/concurrent/should_run/throwto002.hs b/testsuite/tests/concurrent/should_run/throwto002.hs new file mode 100644 index 0000000000..c9857f1f1e --- /dev/null +++ b/testsuite/tests/concurrent/should_run/throwto002.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DoRec, ScopedTypeVariables #-} +import Control.Concurrent +import Control.Exception +import Data.Array +import System.Random +import System.Environment +import Control.Monad +import GHC.Conc +import Data.IORef +import Prelude hiding (catch) + +main = do + r <- newIORef 0 + rec + t1 <- block $ forkIO (thread r t2) + t2 <- block $ forkIO (thread r t1) + threadDelay 1000000 + readIORef r >>= print + +thread r t = run + where + run = (unblock $ forever $ do killThread t + i <- atomicModifyIORef r (\i -> (i + 1, i)) + evaluate i) + `catch` \(e::SomeException) -> run diff --git a/testsuite/tests/concurrent/should_run/throwto003.hs b/testsuite/tests/concurrent/should_run/throwto003.hs new file mode 100644 index 0000000000..6369c62352 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/throwto003.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DoRec, ScopedTypeVariables #-} +import Control.Concurrent +import Control.Exception +import Control.Monad +import Prelude hiding (catch) + +main = do + m <- newMVar 1 + t1 <- forkIO $ thread m + t2 <- forkIO $ forever $ killThread t1 + threadDelay 1000000 + takeMVar m + +thread m = run + where + run = (unblock $ forever $ modifyMVar_ m $ \v -> if v `mod` 2 == 1 then return (v*2) else return (v-1)) + `catch` \(e::SomeException) -> run |