conc052: still fails profc/profasm for 6.8
[packages/stm.git] / tests / conc048.hs
1 module Main where
2
3 import GHC.Conc
4 import Control.Concurrent
5 import Control.Exception
6 import IO
7 import Foreign.StablePtr
8 import System.IO
9
10 -- Create two tvars each holding 0
11 initTVars :: STM (TVar Int, TVar Int)
12 initTVars = do v1 <- newTVar 0
13 v2 <- newTVar 0
14 return (v1, v2)
15
16 -- Increment v1, retry
17 optionOne :: TVar Int -> TVar Int -> STM ()
18 optionOne v1 v2 = do x <- readTVar v1
19 writeTVar v1 (x + 10)
20 retry
21
22 -- Increment v2, don't retry
23 optionTwo :: TVar Int -> TVar Int -> STM ()
24 optionTwo v1 v2 = do x <- readTVar v2
25 writeTVar v2 (x + 10)
26
27 -- Combine options one and two. We should be left with optionTwo because
28 -- optionOne attempts to retry while valid.
29 elseTestA :: TVar Int -> TVar Int -> STM ()
30 elseTestA v1 v2 = (optionOne v1 v2) `orElse` (optionTwo v1 v2)
31
32 -- Combine options one and two. We should be left with optionTwo because
33 -- optionOne attempts to retry while valid.
34 elseTestB :: TVar Int -> TVar Int -> STM ()
35 elseTestB v1 v2 = (optionTwo v1 v2) `orElse` (optionOne v1 v2)
36
37 -- Combine options two and one. We should be left with optionTwo because
38 -- it completes successfully.
39 elseTestC :: TVar Int -> TVar Int -> STM ()
40 elseTestC v1 v2 = (optionTwo v1 v2) `orElse` (optionTwo v1 v2)
41
42 -- Nested use of `orElse`: combine (optionOne and OptionOne) with optionTwo
43 elseTestD :: TVar Int -> TVar Int -> STM ()
44 elseTestD v1 v2 = ((optionOne v1 v2) `orElse` (optionOne v1 v2)) `orElse` (optionTwo v1 v2)
45
46 -- Nested use of `orElse`: combine (optionOne and optionTwo) with optionTwo
47 elseTestE :: TVar Int -> TVar Int -> STM ()
48 elseTestE v1 v2 = ((optionOne v1 v2) `orElse` (optionTwo v1 v2)) `orElse` (optionTwo v1 v2)
49
50 -- Combine options one and one. Retry should propagate.
51 elseTestZ :: TVar Int -> TVar Int -> STM ()
52 elseTestZ v1 v2 = (optionOne v1 v2) `orElse` (optionOne v1 v2)
53
54 -- return (v1, v2)
55 snapshot :: TVar Int -> TVar Int -> STM (Int, Int)
56 snapshot v1 v2 = do s1 <- readTVar v1
57 s2 <- readTVar v2
58 return (s1, s2)
59
60 main :: IO ()
61 main = do newStablePtr stdout
62 iteration 10
63
64 iteration :: Int -> IO ()
65 iteration n =
66 do putStrLn ("Iter " ++ show n)
67 (sv1, sv2) <- atomically ( initTVars )
68
69 putStrLn "T1"
70 atomically ( elseTestA sv1 sv2 )
71 vs <- atomically ( snapshot sv1 sv2 )
72 print vs
73
74 putStrLn "T2"
75 atomically ( elseTestB sv1 sv2 )
76 vs <- atomically ( snapshot sv1 sv2 )
77 print vs
78
79 putStrLn "T3"
80 atomically ( elseTestC sv1 sv2 )
81 vs <- atomically ( snapshot sv1 sv2 )
82 print vs
83
84 putStrLn "T4"
85 atomically ( elseTestD sv1 sv2 )
86 vs <- atomically ( snapshot sv1 sv2 )
87 print vs
88
89 putStrLn "T5"
90 atomically ( elseTestE sv1 sv2 )
91 vs <- atomically ( snapshot sv1 sv2 )
92 print vs
93
94 putStrLn "T6"
95 Control.Exception.catch (atomically ( elseTestZ sv1 sv2 ))
96 (\e -> putStr ("Caught: " ++ (show e) ++ "\n"))
97 vs <- atomically ( snapshot sv1 sv2 )
98 print vs
99
100 putStrLn "T7"
101 if (n == 0) then return () else iteration (n - 1)
102
103
104