{-# LINE 1 "libraries/unix/System/Posix/Semaphore.hsc" #-}
{-# LINE 2 "libraries/unix/System/Posix/Semaphore.hsc" #-}
{-# LANGUAGE Safe #-}
{-# LINE 6 "libraries/unix/System/Posix/Semaphore.hsc" #-}
module System.Posix.Semaphore
(OpenSemFlags(..), Semaphore(),
semOpen, semUnlink, semWait, semTryWait, semThreadWait,
semPost, semGetValue)
where
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 { OpenSemFlags -> Bool
semCreate :: Bool,
OpenSemFlags -> Bool
semExclusive :: Bool
}
newtype Semaphore = Semaphore (ForeignPtr ())
semOpen :: String -> OpenSemFlags -> FileMode -> Int -> IO Semaphore
semOpen :: String -> OpenSemFlags -> FileMode -> Int -> IO Semaphore
semOpen String
name OpenSemFlags
flags FileMode
mode Int
value =
let cflags :: Int
cflags = (if OpenSemFlags -> Bool
semCreate OpenSemFlags
flags then Int
64 else Int
0) forall a. Bits a => a -> a -> a
.|.
{-# LINE 54 "libraries/unix/System/Posix/Semaphore.hsc" #-}
(if OpenSemFlags -> Bool
semExclusive OpenSemFlags
flags then Int
128 else Int
0)
{-# LINE 55 "libraries/unix/System/Posix/Semaphore.hsc" #-}
semOpen' :: CString -> IO Semaphore
semOpen' CString
cname =
do Ptr ()
sem <- forall a. String -> String -> IO (Ptr a) -> IO (Ptr a)
throwErrnoPathIfNull String
"semOpen" String
name forall a b. (a -> b) -> a -> b
$
CString -> CInt -> FileMode -> CUInt -> IO (Ptr ())
sem_open CString
cname (forall a. Enum a => Int -> a
toEnum Int
cflags) FileMode
mode (forall a. Enum a => Int -> a
toEnum Int
value)
ForeignPtr ()
fptr <- forall a. Ptr a -> IO () -> IO (ForeignPtr a)
newForeignPtr Ptr ()
sem (Ptr () -> IO ()
finalize Ptr ()
sem)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ForeignPtr () -> Semaphore
Semaphore ForeignPtr ()
fptr
finalize :: Ptr () -> IO ()
finalize Ptr ()
sem = forall a. (Eq a, Num a) => String -> String -> IO a -> IO ()
throwErrnoPathIfMinus1_ String
"semOpen" String
name forall a b. (a -> b) -> a -> b
$
Ptr () -> IO CInt
sem_close Ptr ()
sem in
forall a. String -> (CString -> IO a) -> IO a
withCAString String
name CString -> IO Semaphore
semOpen'
semUnlink :: String -> IO ()
semUnlink :: String -> IO ()
semUnlink String
name = forall a. String -> (CString -> IO a) -> IO a
withCAString String
name CString -> IO ()
semUnlink'
where semUnlink' :: CString -> IO ()
semUnlink' CString
cname = forall a. (Eq a, Num a) => String -> String -> IO a -> IO ()
throwErrnoPathIfMinus1_ String
"semUnlink" String
name forall a b. (a -> b) -> a -> b
$
CString -> IO CInt
sem_unlink CString
cname
semWait :: Semaphore -> IO ()
semWait :: Semaphore -> IO ()
semWait (Semaphore ForeignPtr ()
fptr) = forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr ()
fptr Ptr () -> IO ()
semWait'
where semWait' :: Ptr () -> IO ()
semWait' Ptr ()
sem = forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1Retry_ String
"semWait" forall a b. (a -> b) -> a -> b
$
Ptr () -> IO CInt
sem_wait Ptr ()
sem
semTryWait :: Semaphore -> IO Bool
semTryWait :: Semaphore -> IO Bool
semTryWait (Semaphore ForeignPtr ()
fptr) = forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr ()
fptr Ptr () -> IO Bool
semTrywait'
where semTrywait' :: Ptr () -> IO Bool
semTrywait' Ptr ()
sem = do CInt
res <- Ptr () -> IO CInt
sem_trywait Ptr ()
sem
(if CInt
res forall a. Eq a => a -> a -> Bool
== CInt
0 then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else do Errno
errno <- IO Errno
getErrno
(if Errno
errno forall a. Eq a => a -> a -> Bool
== Errno
eINTR
then Ptr () -> IO Bool
semTrywait' Ptr ()
sem
else if Errno
errno forall a. Eq a => a -> a -> Bool
== Errno
eAGAIN
then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
else forall a. String -> IO a
throwErrno String
"semTrywait"))
semThreadWait :: Semaphore -> IO ()
semThreadWait :: Semaphore -> IO ()
semThreadWait Semaphore
sem = do Bool
res <- Semaphore -> IO Bool
semTryWait Semaphore
sem
(if Bool
res then forall (m :: * -> *) a. Monad m => a -> m a
return ()
else ( do { IO ()
yield; Semaphore -> IO ()
semThreadWait Semaphore
sem } ))
semPost :: Semaphore -> IO ()
semPost :: Semaphore -> IO ()
semPost (Semaphore ForeignPtr ()
fptr) = forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr ()
fptr Ptr () -> IO ()
semPost'
where semPost' :: Ptr () -> IO ()
semPost' Ptr ()
sem = forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1Retry_ String
"semPost" forall a b. (a -> b) -> a -> b
$
Ptr () -> IO CInt
sem_post Ptr ()
sem
semGetValue :: Semaphore -> IO Int
semGetValue :: Semaphore -> IO Int
semGetValue (Semaphore ForeignPtr ()
fptr) = forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr ()
fptr Ptr () -> IO Int
semGetValue'
where semGetValue' :: Ptr () -> IO Int
semGetValue' Ptr ()
sem = forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca (Ptr () -> Ptr CInt -> IO Int
semGetValue_ Ptr ()
sem)
semGetValue_ :: Ptr () -> Ptr CInt -> IO Int
semGetValue_ :: Ptr () -> Ptr CInt -> IO Int
semGetValue_ Ptr ()
sem Ptr CInt
ptr = do forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1Retry_ String
"semGetValue" forall a b. (a -> b) -> a -> b
$
Ptr () -> Ptr CInt -> IO Int
sem_getvalue Ptr ()
sem Ptr CInt
ptr
CInt
cint <- forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
ptr
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> Int
fromEnum CInt
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