3c1e2326c59bcf267065cbfe42f5215ea090e3d9
[packages/stm.git] / tests / conc047.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 inittvar :: STM (TVar String)
10 inittvar = newTVar "Hello world"
11
12 deadlock0 :: STM String
13 deadlock0 = retry
14
15 deadlock1 :: TVar String -> STM String
16 deadlock1 v1 = do s1 <- readTVar v1
17 retry
18
19 -- Basic single-threaded operations with retry
20 main = do newStablePtr stdout
21 putStr "Before\n"
22 t1 <- atomically ( newTVar 0 )
23
24 -- Atomic block that contains a retry but does not perform it
25 r <- atomically ( do r1 <- readTVar t1
26 if (r1 /= 0) then retry else return ()
27 return r1 )
28 putStr ("Survived unused retry\n")
29
30 -- Atomic block that retries after reading 0 TVars
31 s1 <- Control.Exception.catch (atomically retry )
32 (\e -> return ("Caught: " ++ (show e) ++ "\n"))
33 putStr s1
34
35 -- Atomic block that retries after reading 1 TVar
36 t1 <- atomically ( inittvar )
37 s1 <- Control.Exception.catch (atomically ( deadlock1 t1 ))
38 (\e -> return ("Caught: " ++ (show e) ++ "\n"))
39 putStr s1
40
41
42 return ()
43
44
45
46
47
48
49
50