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
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
|
-----------------------------------------------------------------------------
-- |
-- Module : Control.Concurrent.STM.TSem
-- Copyright : (c) The University of Glasgow 2012
-- License : BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer : libraries@haskell.org
-- Stability : experimental
-- Portability : non-portable (requires STM)
--
-- 'TSem': transactional semaphores.
--
-- @since 2.4.2
-----------------------------------------------------------------------------
{-# LANGUAGE DeriveDataTypeable #-}
module Control.Concurrent.STM.TSem
( TSem
, newTSem
, waitTSem
, signalTSem
, signalTSemN
) where
import Control.Concurrent.STM
import Control.Monad
import Data.Typeable
import Numeric.Natural
-- | 'TSem' is a transactional semaphore. It holds a certain number
-- of units, and units may be acquired or released by 'waitTSem' and
-- 'signalTSem' respectively. When the 'TSem' is empty, 'waitTSem'
-- blocks.
--
-- Note that 'TSem' has no concept of fairness, and there is no
-- guarantee that threads blocked in `waitTSem` will be unblocked in
-- the same order; in fact they will all be unblocked at the same time
-- and will fight over the 'TSem'. Hence 'TSem' is not suitable if
-- you expect there to be a high number of threads contending for the
-- resource. However, like other STM abstractions, 'TSem' is
-- composable.
--
-- @since 2.4.2
newtype TSem = TSem (TVar Integer)
deriving (Eq, Typeable)
-- | Construct new 'TSem' with an initial counter value.
--
-- A positive initial counter value denotes availability of
-- units 'waitTSem' can acquire.
--
-- The initial counter value can be negative which denotes a resource
-- \"debt\" that requires a respective amount of 'signalTSem'
-- operations to counter-balance.
--
-- @since 2.4.2
newTSem :: Integer -> STM TSem
newTSem i = fmap TSem (newTVar $! i)
-- NOTE: we can't expose a good `TSem -> STM Int' operation as blocked
-- 'waitTSem' aren't reliably reflected in a negative counter value.
-- | Wait on 'TSem' (aka __P__ operation).
--
-- This operation acquires a unit from the semaphore (i.e. decreases
-- the internal counter) and blocks (via 'retry') if no units are
-- available (i.e. if the counter is /not/ positive).
--
-- @since 2.4.2
waitTSem :: TSem -> STM ()
waitTSem (TSem t) = do
i <- readTVar t
when (i <= 0) retry
writeTVar t $! (i-1)
-- Alternatively, the implementation could block (via 'retry') when
-- the next increment would overflow, i.e. testing for 'maxBound'
-- | Signal a 'TSem' (aka __V__ operation).
--
-- This operation adds\/releases a unit back to the semaphore
-- (i.e. increments the internal counter).
--
-- @since 2.4.2
signalTSem :: TSem -> STM ()
signalTSem (TSem t) = do
i <- readTVar t
writeTVar t $! i+1
-- | Multi-signal a 'TSem'
--
-- This operation adds\/releases multiple units back to the semaphore
-- (i.e. increments the internal counter).
--
-- > signalTSem == signalTSemN 1
--
-- @since 2.4.5
signalTSemN :: Natural -> TSem -> STM ()
signalTSemN 0 _ = return ()
signalTSemN 1 s = signalTSem s
signalTSemN n (TSem t) = do
i <- readTVar t
writeTVar t $! i+(toInteger n)
|
