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