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
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
|
#ifdef __GLASGOW_HASKELL__
{-# LANGUAGE Trustworthy #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Module : System.Posix.Semaphore
-- Copyright : (c) Daniel Franke 2007
-- License : BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer : libraries@haskell.org
-- Stability : experimental
-- Portability : non-portable (requires POSIX)
--
-- POSIX named semaphore support.
--
-----------------------------------------------------------------------------
module System.Posix.Semaphore
(OpenSemFlags(..), Semaphore(),
semOpen, semUnlink, semWait, semTryWait, semThreadWait,
semPost, semGetValue)
where
#include <semaphore.h>
#include <fcntl.h>
import Foreign.C
import Foreign.ForeignPtr hiding (newForeignPtr)
import Foreign.Concurrent
import Foreign.Marshal
import Foreign.Ptr
import Foreign.Storable
import System.Posix.Types
import Control.Concurrent
import Data.Bits
data OpenSemFlags = OpenSemFlags { semCreate :: Bool,
-- ^ If true, create the semaphore if it
-- does not yet exist.
semExclusive :: Bool
-- ^ If true, throw an exception if the
-- semaphore already exists.
}
newtype Semaphore = Semaphore (ForeignPtr ())
-- | Open a named semaphore with the given name, flags, mode, and initial
-- value.
semOpen :: String -> OpenSemFlags -> FileMode -> Int -> IO Semaphore
semOpen name flags mode value =
let cflags = (if semCreate flags then #{const O_CREAT} else 0) .|.
(if semExclusive flags then #{const O_EXCL} else 0)
semOpen' cname =
do sem <- throwErrnoPathIfNull "semOpen" name $
sem_open cname (toEnum cflags) mode (toEnum value)
fptr <- newForeignPtr sem (finalize sem)
return $ Semaphore fptr
finalize sem = throwErrnoPathIfMinus1_ "semOpen" name $
sem_close sem in
withCAString name semOpen'
-- | Delete the semaphore with the given name.
semUnlink :: String -> IO ()
semUnlink name = withCAString name semUnlink'
where semUnlink' cname = throwErrnoPathIfMinus1_ "semUnlink" name $
sem_unlink cname
-- | Lock the semaphore, blocking until it becomes available. Since this
-- is done through a system call, this will block the *entire runtime*,
-- not just the current thread. If this is not the behaviour you want,
-- use semThreadWait instead.
semWait :: Semaphore -> IO ()
semWait (Semaphore fptr) = withForeignPtr fptr semWait'
where semWait' sem = throwErrnoIfMinus1Retry_ "semWait" $
sem_wait sem
-- | Attempt to lock the semaphore without blocking. Immediately return
-- False if it is not available.
semTryWait :: Semaphore -> IO Bool
semTryWait (Semaphore fptr) = withForeignPtr fptr semTrywait'
where semTrywait' sem = do res <- sem_trywait sem
(if res == 0 then return True
else do errno <- getErrno
(if errno == eINTR
then semTrywait' sem
else if errno == eAGAIN
then return False
else throwErrno "semTrywait"))
-- | Poll the semaphore until it is available, then lock it. Unlike
-- semWait, this will block only the current thread rather than the
-- entire process.
semThreadWait :: Semaphore -> IO ()
semThreadWait sem = do res <- semTryWait sem
(if res then return ()
else ( do { yield; semThreadWait sem } ))
-- | Unlock the semaphore.
semPost :: Semaphore -> IO ()
semPost (Semaphore fptr) = withForeignPtr fptr semPost'
where semPost' sem = throwErrnoIfMinus1Retry_ "semPost" $
sem_post sem
-- | Return the semaphore's current value.
semGetValue :: Semaphore -> IO Int
semGetValue (Semaphore fptr) = withForeignPtr fptr semGetValue'
where semGetValue' sem = alloca (semGetValue_ sem)
semGetValue_ :: Ptr () -> Ptr CInt -> IO Int
semGetValue_ sem ptr = do throwErrnoIfMinus1Retry_ "semGetValue" $
sem_getvalue sem ptr
cint <- peek ptr
return $ fromEnum cint
foreign import ccall safe "sem_open"
sem_open :: CString -> CInt -> CMode -> CUInt -> IO (Ptr ())
foreign import ccall safe "sem_close"
sem_close :: Ptr () -> IO CInt
foreign import ccall safe "sem_unlink"
sem_unlink :: CString -> IO CInt
foreign import ccall safe "sem_wait"
sem_wait :: Ptr () -> IO CInt
foreign import ccall safe "sem_trywait"
sem_trywait :: Ptr () -> IO CInt
foreign import ccall safe "sem_post"
sem_post :: Ptr () -> IO CInt
foreign import ccall safe "sem_getvalue"
sem_getvalue :: Ptr () -> Ptr CInt -> IO Int
|
