aboutsummaryrefslogtreecommitdiffhomepage
path: root/tests/signals004.hs
blob: 711a6eb592f56377568b7c2294fbea218c9e9cee (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
import Control.Concurrent
import System.Posix
import Control.Monad

-- signal stress test: threads installing signal handlers while
-- signals are being constantly thrown and caught.

installers = 50
sigs = 10000

main = do
  c <- newChan
  m <- newEmptyMVar
  installHandler sigUSR1 (handler c) Nothing
  replicateM_ installers (forkIO $ do replicateM_ 1000 (install c); putMVar m ())
  replicateM_ sigs (forkIO $ raiseSignal sigUSR1)
  replicateM_ installers (takeMVar m)
  replicateM_ sigs (readChan c)

handler c = Catch (writeChan c ())

install c = do
  old <- installHandler sigUSR1 (handler c) Nothing
  installHandler sigUSR1 old Nothing