{-# 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" #-}
{-# LANGUAGE CApiFFI #-}
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) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|.
{-# LINE 55 "libraries/unix/System/Posix/Semaphore.hsc" #-}
(if OpenSemFlags -> Bool
semExclusive OpenSemFlags
flags then Int
128 else Int
0)
{-# LINE 56 "libraries/unix/System/Posix/Semaphore.hsc" #-}
semOpen' :: CString -> IO Semaphore
semOpen' CString
cname =
do Ptr ()
sem <- String -> String -> IO (Ptr ()) -> IO (Ptr ())
forall a. String -> String -> IO (Ptr a) -> IO (Ptr a)
throwErrnoPathIfNull String
"semOpen" String
name (IO (Ptr ()) -> IO (Ptr ())) -> IO (Ptr ()) -> IO (Ptr ())
forall a b. (a -> b) -> a -> b
$
CString -> CInt -> FileMode -> CUInt -> IO (Ptr ())
sem_open CString
cname (Int -> CInt
forall a. Enum a => Int -> a
toEnum Int
cflags) FileMode
mode (Int -> CUInt
forall a. Enum a => Int -> a
toEnum Int
value)
ForeignPtr ()
fptr <- Ptr () -> IO () -> IO (ForeignPtr ())
forall a. Ptr a -> IO () -> IO (ForeignPtr a)
newForeignPtr Ptr ()
sem (Ptr () -> IO ()
finalize Ptr ()
sem)
Semaphore -> IO Semaphore
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Semaphore -> IO Semaphore) -> Semaphore -> IO Semaphore
forall a b. (a -> b) -> a -> b
$ ForeignPtr () -> Semaphore
Semaphore ForeignPtr ()
fptr
finalize :: Ptr () -> IO ()
finalize Ptr ()
sem = String -> String -> IO CInt -> IO ()
forall a. (Eq a, Num a) => String -> String -> IO a -> IO ()
throwErrnoPathIfMinus1_ String
"semOpen" String
name (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$
Ptr () -> IO CInt
sem_close Ptr ()
sem in
String -> (CString -> IO Semaphore) -> IO Semaphore
forall a. String -> (CString -> IO a) -> IO a
withCAString String
name CString -> IO Semaphore
semOpen'
semUnlink :: String -> IO ()
semUnlink :: String -> IO ()
semUnlink String
name = String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCAString String
name CString -> IO ()
semUnlink'
where semUnlink' :: CString -> IO ()
semUnlink' CString
cname = String -> String -> IO CInt -> IO ()
forall a. (Eq a, Num a) => String -> String -> IO a -> IO ()
throwErrnoPathIfMinus1_ String
"semUnlink" String
name (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$
CString -> IO CInt
sem_unlink CString
cname
semWait :: Semaphore -> IO ()
semWait :: Semaphore -> IO ()
semWait (Semaphore ForeignPtr ()
fptr) = ForeignPtr () -> (Ptr () -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr ()
fptr Ptr () -> IO ()
semWait'
where semWait' :: Ptr () -> IO ()
semWait' Ptr ()
sem = String -> IO CInt -> IO ()
forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1Retry_ String
"semWait" (IO CInt -> IO ()) -> IO CInt -> IO ()
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) = ForeignPtr () -> (Ptr () -> IO Bool) -> IO Bool
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 CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0 then Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else do Errno
errno <- IO Errno
getErrno
(if Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eINTR
then Ptr () -> IO Bool
semTrywait' Ptr ()
sem
else if Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eAGAIN
then Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
else String -> IO Bool
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 () -> IO ()
forall a. a -> IO a
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) = ForeignPtr () -> (Ptr () -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr ()
fptr Ptr () -> IO ()
semPost'
where semPost' :: Ptr () -> IO ()
semPost' Ptr ()
sem = String -> IO CInt -> IO ()
forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1Retry_ String
"semPost" (IO CInt -> IO ()) -> IO CInt -> IO ()
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) = ForeignPtr () -> (Ptr () -> IO Int) -> IO Int
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 = (Ptr CInt -> IO Int) -> IO Int
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 String -> IO Int -> IO ()
forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1Retry_ String
"semGetValue" (IO Int -> IO ()) -> IO Int -> IO ()
forall a b. (a -> b) -> a -> b
$
Ptr () -> Ptr CInt -> IO Int
sem_getvalue Ptr ()
sem Ptr CInt
ptr
CInt
cint <- Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
ptr
Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ CInt -> Int
forall a. Enum a => a -> Int
fromEnum CInt
cint
foreign import capi safe "semaphore.h sem_open"
sem_open :: CString -> CInt -> CMode -> CUInt -> IO (Ptr ())
foreign import capi safe "semaphore.h sem_close"
sem_close :: Ptr () -> IO CInt
foreign import capi safe "semaphore.h sem_unlink"
sem_unlink :: CString -> IO CInt
foreign import capi safe "semaphore.h sem_wait"
sem_wait :: Ptr () -> IO CInt
foreign import capi safe "semaphore.h sem_trywait"
sem_trywait :: Ptr () -> IO CInt
foreign import capi safe "semaphore.h sem_post"
sem_post :: Ptr () -> IO CInt
foreign import capi safe "semaphore.h sem_getvalue"
sem_getvalue :: Ptr () -> Ptr CInt -> IO Int