blob: 999d3335d8cddcdacb56f4899c8d1730f1cf734e (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
|
import Control.Concurrent
import Control.Exception
import Data.Array
import System.Random
import System.Environment
import Control.Monad
import GHC.Conc
-- A fiendish throwTo test. A bunch of threads take random MVars from
-- a shared array; if the MVar has Nothing in it, replace it with Just
-- of the current thread's ThreadId. If the MVar has another ThreadId
-- in it, then killThread that thread, and replace it with the current
-- thread's ThreadId. We keep going until only one thread is left
-- standing.
--
-- On multiple CPUs this should give throwTo a good workout.
--
main = do
[m, t] <- fmap (fmap read) getArgs
ms <- replicateM m $ newMVar Nothing
let arr = listArray (1,m) ms
dead <- newTVarIO 0
ts <- replicateM t $ forkIO (thread m arr `onException`
(atomically $ do d <- readTVar dead
writeTVar dead $! d+1))
atomically $ do
d <- readTVar dead
when (d < t-1) $ retry
thread m arr = do
x <- randomIO
id <- myThreadId
modifyMVar_ (arr ! ((x `mod` m) + 1)) $ \b ->
case b of
Nothing -> return (Just id)
Just other -> do when (other /= id) $ killThread other
return (Just id)
thread m arr
|
