223d86539d97c539a5517ebecbfe0f4639f31314
[ghc.git] / libraries / base / Control / Concurrent / QSem.hs
1 {-# LANGUAGE Trustworthy #-}
2 {-# LANGUAGE AutoDeriveTypeable, BangPatterns #-}
3 {-# OPTIONS_GHC -funbox-strict-fields #-}
4
5 -----------------------------------------------------------------------------
6 -- |
7 -- Module : Control.Concurrent.QSem
8 -- Copyright : (c) The University of Glasgow 2001
9 -- License : BSD-style (see the file libraries/base/LICENSE)
10 --
11 -- Maintainer : libraries@haskell.org
12 -- Stability : experimental
13 -- Portability : non-portable (concurrency)
14 --
15 -- Simple quantity semaphores.
16 --
17 -----------------------------------------------------------------------------
18
19 module Control.Concurrent.QSem
20 ( -- * Simple Quantity Semaphores
21 QSem, -- abstract
22 newQSem, -- :: Int -> IO QSem
23 waitQSem, -- :: QSem -> IO ()
24 signalQSem -- :: QSem -> IO ()
25 ) where
26
27 import Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar, tryTakeMVar
28 , putMVar, newMVar, tryPutMVar)
29 import Control.Exception
30 import Data.Maybe
31
32 -- | 'QSem' is a quantity semaphore in which the resource is aqcuired
33 -- and released in units of one. It provides guaranteed FIFO ordering
34 -- for satisfying blocked `waitQSem` calls.
35 --
36 -- The pattern
37 --
38 -- > bracket_ waitQSem signalQSem (...)
39 --
40 -- is safe; it never loses a unit of the resource.
41 --
42 data QSem = QSem !(MVar (Int, [MVar ()], [MVar ()]))
43
44 -- The semaphore state (i, xs, ys):
45 --
46 -- i is the current resource value
47 --
48 -- (xs,ys) is the queue of blocked threads, where the queue is
49 -- given by xs ++ reverse ys. We can enqueue new blocked threads
50 -- by consing onto ys, and dequeue by removing from the head of xs.
51 --
52 -- A blocked thread is represented by an empty (MVar ()). To unblock
53 -- the thread, we put () into the MVar.
54 --
55 -- A thread can dequeue itself by also putting () into the MVar, which
56 -- it must do if it receives an exception while blocked in waitQSem.
57 -- This means that when unblocking a thread in signalQSem we must
58 -- first check whether the MVar is already full; the MVar lock on the
59 -- semaphore itself resolves race conditions between signalQSem and a
60 -- thread attempting to dequeue itself.
61
62 -- |Build a new 'QSem' with a supplied initial quantity.
63 -- The initial quantity must be at least 0.
64 newQSem :: Int -> IO QSem
65 newQSem initial
66 | initial < 0 = fail "newQSem: Initial quantity must be non-negative"
67 | otherwise = do
68 sem <- newMVar (initial, [], [])
69 return (QSem sem)
70
71 -- |Wait for a unit to become available
72 waitQSem :: QSem -> IO ()
73 waitQSem (QSem m) =
74 mask_ $ do
75 (i,b1,b2) <- takeMVar m
76 if i == 0
77 then do
78 b <- newEmptyMVar
79 putMVar m (i, b1, b:b2)
80 wait b
81 else do
82 let !z = i-1
83 putMVar m (z, b1, b2)
84 return ()
85 where
86 wait b = takeMVar b `onException` do
87 (uninterruptibleMask_ $ do -- Note [signal uninterruptible]
88 (i,b1,b2) <- takeMVar m
89 r <- tryTakeMVar b
90 r' <- if isJust r
91 then signal (i,b1,b2)
92 else do putMVar b (); return (i,b1,b2)
93 putMVar m r')
94
95 -- |Signal that a unit of the 'QSem' is available
96 signalQSem :: QSem -> IO ()
97 signalQSem (QSem m) =
98 uninterruptibleMask_ $ do -- Note [signal uninterruptible]
99 r <- takeMVar m
100 r' <- signal r
101 putMVar m r'
102
103 -- Note [signal uninterruptible]
104 --
105 -- If we have
106 --
107 -- bracket waitQSem signalQSem (...)
108 --
109 -- and an exception arrives at the signalQSem, then we must not lose
110 -- the resource. The signalQSem is masked by bracket, but taking
111 -- the MVar might block, and so it would be interruptible. Hence we
112 -- need an uninterruptibleMask here.
113 --
114 -- This isn't ideal: during high contention, some threads won't be
115 -- interruptible. The QSemSTM implementation has better behaviour
116 -- here, but it performs much worse than this one in some
117 -- benchmarks.
118
119 signal :: (Int,[MVar ()],[MVar ()]) -> IO (Int,[MVar ()],[MVar ()])
120 signal (i,a1,a2) =
121 if i == 0
122 then loop a1 a2
123 else let !z = i+1 in return (z, a1, a2)
124 where
125 loop [] [] = return (1, [], [])
126 loop [] b2 = loop (reverse b2) []
127 loop (b:bs) b2 = do
128 r <- tryPutMVar b ()
129 if r then return (0, bs, b2)
130 else loop bs b2