conc052: still fails profc/profasm for 6.8
[packages/stm.git] / tests / conc062.hs
1 module Main where
2
3 import GHC.Conc
4 import Control.Exception
5
6 -- Test invariants using multiple TVars
7 main = do
8 putStr "\nStarting\n"
9 (x1, x2, x3) <- atomically ( do x1 <- newTVar 0
10 x2 <- newTVar 0
11 x3 <- newTVar 0
12 return (x1, x2, x3))
13
14 putStr "\nAttaching invariant\n";
15 atomically ( alwaysSucceeds ( do v1 <- readTVar x1
16 v23 <- readTVar (if (v1 >= 0) then x2 else x3)
17 if (v23 > v1) then throwDyn "Exn" else return () ) )
18
19 putStr "\nTouching invariant (should keep on same TVars)\n"
20 atomically ( do writeTVar x1 1
21 writeTVar x2 1 )
22
23 putStr "\nTouching invariant (should move it to other TVars)\n"
24 atomically ( do writeTVar x1 (-1)
25 writeTVar x3 (-1) )
26
27 putStr "\nTouching invariant (should keep on same TVars)\n"
28 atomically ( do writeTVar x1 (-2)
29 writeTVar x3 (-3) )
30
31 putStr "\nChecking TVar contents\n"
32 (t1, t2, t3) <- atomically ( do t1 <- readTVar x1
33 t2 <- readTVar x2
34 t3 <- readTVar x3
35 return (t1, t2, t3))
36 putStr ("Contents = (" ++ (show t1) ++ "," ++ (show t2) ++ "," ++ (show t3) ++ ")\n")
37
38 putStr "\nDone\n"
39