conc052: still fails profc/profasm for 6.8
[packages/stm.git] / tests / conc052.hs
1 -- STM stress test
2
3 {-# OPTIONS -fffi #-}
4 module Main (main) where
5
6 import Foreign
7 import Control.Concurrent
8 import Control.Exception
9 import GHC.Conc -- Control.Concurrent.STM
10 import System.Random
11 import Data.Array
12 import Data.List
13 import GHC.Conc ( unsafeIOToSTM )
14 import Control.Monad ( when )
15 import System.IO
16 import System.IO.Unsafe
17 import System.Environment
18 import Foreign.C
19
20 -- | The number of array elements
21 n_elems :: Int
22 n_elems = 20
23
24 -- | The number of threads swapping elements
25 n_threads :: Int
26 n_threads = 2
27
28 -- | The number of swaps for each thread to perform
29 iterations :: Int
30 iterations = 20000
31
32 type Elements = Array Int (TVar Int)
33
34 thread :: TVar Int -> Elements -> IO ()
35 thread done elements = loop iterations
36 where loop 0 = atomically $ do x <- readTVar done; writeTVar done (x+1)
37 loop n = do
38 i1 <- randomRIO (1,n_elems)
39 i2 <- randomRIO (1,n_elems)
40 let e1 = elements ! i1
41 let e2 = elements ! i2
42 atomically $ do
43 e1_v <- readTVar e1
44 e2_v <- readTVar e2
45 writeTVar e1 e2_v
46 writeTVar e2 e1_v
47 loop (n-1)
48
49 await_end :: TVar Int -> IO ()
50 await_end done = atomically $ do x <- readTVar done
51 if (x == n_threads) then return () else retry
52
53 main = do
54 Foreign.newStablePtr stdout
55 setStdGen (read "526454551 6356")
56 let init_vals = [1..n_elems] -- take n_elems
57 tvars <- atomically $ mapM newTVar init_vals
58 let elements = listArray (1,n_elems) tvars
59 done <- atomically (newTVar 0)
60 sequence [ forkIO (thread done elements) | id <- [1..n_threads] ]
61 await_end done
62 fin_vals <- mapM (\t -> atomically $ readTVar t) (elems elements)
63 putStr("Before: ")
64 mapM (\v -> putStr ((show v) ++ " " )) init_vals
65 putStr("\nAfter: ")
66 mapM (\v -> putStr ((show v) ++ " " )) (sort fin_vals)
67 putStr("\n")
68 if ((sort fin_vals) == init_vals) then return () else throwDyn "Mismatch"
69
70