conc052: still fails profc/profasm for 6.8
[packages/stm.git] / tests / conc063.hs
1 module Main where
2
3 import GHC.Conc
4 import Control.Exception
5 import IO
6 import Foreign.StablePtr
7 import System.IO
8
9 -- Test invariants using updates & blocking in invariants
10 main = do
11 m <- newEmptyMVar
12 forkIO (do_test m)
13 -- We do the test in a separate thread, because this test relies on
14 -- being able to catch BlockedIndefinitely, and the main thread
15 -- won't receive that exception under GHCi because it is held alive
16 -- by the interrupt (^C) handler thread.
17 newStablePtr m
18 -- the MVar m must be kept alive, otherwise when the subthread is
19 -- BlockedIndefinitely, the MVar will be unreachable and the main
20 -- thread will also be considered to be BlockedIndefinitely.
21 takeMVar m
22
23 do_test m = do
24 newStablePtr stdout
25
26 putStr "\nStarting\n"
27 (x1, x2, x3) <- atomically ( do x1 <- newTVar 0
28 x2 <- newTVar 0
29 x3 <- newTVar 0
30 return (x1, x2, x3))
31
32 putStr "\nAttaching successful invariant that makes an update\n";
33 atomically ( alwaysSucceeds ( writeTVar x1 42 ) )
34
35 putStr "\nAttaching successful invariant that uses retry&orelse internally\n";
36 atomically ( alwaysSucceeds ( retry `orElse` return () ) )
37
38 putStr "\nAttaching a failed invariant that makes an update\n";
39 Control.Exception.catch (atomically ( do writeTVar x1 17
40 alwaysSucceeds ( throwDyn "Exn raised in invariant" ) ) )
41 (\e -> putStr ("Caught: " ++ (show e) ++ "\n"))
42
43 putStr "\nAttaching an invariant that blocks\n";
44 forkIO ( do threadDelay 1000000
45 atomically ( writeTVar x1 10 )
46 return ())
47 atomically ( do alwaysSucceeds ( do v1 <- readTVar x1
48 if (v1 == 0) then retry else return () )
49 )
50
51 putStr "\nAnother update to the TVar with the blocking invariant\n"
52 atomically ( writeTVar x1 20 )
53
54 putStr "\nUpdate the TVar to cause the invariant to block again (expect thread blocked indef)\n"
55 Control.Exception.catch (atomically ( writeTVar x1 0 ))
56 (\e -> putStr ("Caught: " ++ (show e) ++ "\n"))
57
58 putMVar m ()