summaryrefslogtreecommitdiff
path: root/testsuite/tests/concurrent/should_run/conc015a.hs
diff options
context:
space:
mode:
authorHerbert Valerio Riedel <hvr@gnu.org>2014-01-12 11:40:09 +0100
committerHerbert Valerio Riedel <hvr@gnu.org>2014-01-12 12:47:17 +0100
commit66693401b98cb5aa912948af7bbd2182474f50c4 (patch)
treeab176320c561668c9ac13e684c9cc8ae6e4535f6 /testsuite/tests/concurrent/should_run/conc015a.hs
parenta924debcbb3dc5c004f988fcc1b480a01ba276dd (diff)
parentad233cf68ea436c84e931c5bdb9f803308708e09 (diff)
downloadhaskell-66693401b98cb5aa912948af7bbd2182474f50c4.tar.gz
Fold testsuite.git into ghc.git (re #8545)
This commit performs a subtree merge of testsuite.git into ghc.git; The next commit will adapt `sync-all` et al. to the new situation. At the time of merge, testsuite.git was at commit [998a816ae89c4fd573f4abd7c6abb346cf7ee9af/testsuite] The following steps have been used to accomplish this merge: 1. Clone a fresh testsuite.git copy (& cd into) 2. Remove accidentally committed binary files from history git filter-branch \ --index-filter "git rm -r --cached --ignore-unmatch \ tests/haddock/should_compile_flag_nohaddock/a.out \ tests/haddock/should_compile_noflag_nohaddock/a.out \ tests/ghc-regress/haddock/should_compile_flag_nohaddock/a.out \ tests/ghc-regress/haddock/should_compile_noflag_nohaddock/a.out \ tests/ghc-regress/dph/diophantine/dph-diophantine-fast \ tests/ghc-regress/dph/diophantine/dph-diophantine-opt \ tests/ghc-regress/dph/primespj/dph-primespj-fast \ tests/ghc-regress/dph/quickhull/dph-quickhull-fast \ tests/ghc-regress/dph/smvm/dph-smvm \ tests/ghc-regress/dph/sumnats/dph-sumnats \ tests/ghc-regress/dph/words/dph-words-fast \ tests/ghc-regress/plugins/plugins01" \ HEAD 3. Rename all paths in testsuite.git to be prefixed with `testsuite/` git filter-branch -f --prune-empty --tree-filter \ "mkdir -p testsuite; \ git ls-tree --name-only \$GIT_COMMIT | xargs -I files mv files testsuite/" 4. cd into ghc/ checkout, and perform subtree merge of testsuite into ghc (see also http://nuclearsquid.com/writings/subtree-merging-and-you/) cd ../ghc/ git remote add -f testsuite ../testsuite/.git git merge -s ours --no-commit testsuite/master git read-tree --prefix=/ -u testsuite/master git commit Signed-off-by: Herbert Valerio Riedel <hvr@gnu.org>
Diffstat (limited to 'testsuite/tests/concurrent/should_run/conc015a.hs')
-rw-r--r--testsuite/tests/concurrent/should_run/conc015a.hs47
1 files changed, 47 insertions, 0 deletions
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