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
130
131
|
#if __GLASGOW_HASKELL__ >= 709
{-# LANGUAGE Safe #-}
#else
{-# 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
|
