conc052: still fails profc/profasm for 6.8
[packages/stm.git] / tests / conc053.hs
1 {-# OPTIONS_GHC -fglasgow-exts #-}
2 -- !!! test threadDelay, Random, and QSemN.
3
4 -- Variation of conc023, testing STM timeouts instead of IO
5
6 import Random
7 import Control.Concurrent
8 import Control.Exception
9 import Control.Concurrent.STM
10
11 n = 5000 -- no. of threads
12 m = 3000 -- maximum delay
13
14 main = do
15 s <- newQSemN n
16 is <- sequence (take n (repeat (getStdRandom (randomR (1,m)))))
17 mapM (fork_sleep s) is
18 waitQSemN s n
19 where
20 fork_sleep :: QSemN -> Int -> IO ThreadId
21 fork_sleep s i = forkIO (do waitQSemN s 1
22 t <- registerDelay (i*1000)
23 atomically $ (readTVar t >>= check)
24 signalQSemN s 1)