{-# LINE 1 "System/Posix/Semaphore.hsc" #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE CApiFFI #-}
{-# LANGUAGE InterruptibleFFI #-}
module System.Posix.Semaphore
(OpenSemFlags(..), Semaphore(),
semOpen, semUnlink, semWait, semWaitInterruptible, semTryWait, semThreadWait,
semPost, semGetValue)
where
import Foreign.C
import Foreign.ForeignPtr hiding (newForeignPtr)
import Foreign.Concurrent
import Foreign.Ptr
import System.Posix.Types
import Control.Concurrent
import Data.Bits
{-# LINE 39 "System/Posix/Semaphore.hsc" #-}
import Foreign.Marshal
import Foreign.Storable
{-# LINE 42 "System/Posix/Semaphore.hsc" #-}
{-# LINE 44 "System/Posix/Semaphore.hsc" #-}
import System.Posix.Internals (hostIsThreaded)
{-# LINE 49 "System/Posix/Semaphore.hsc" #-}
data OpenSemFlags = OpenSemFlags { semCreate :: Bool,
semExclusive :: Bool
}
newtype Semaphore = Semaphore (ForeignPtr ())
semOpen :: String -> OpenSemFlags -> FileMode -> Int -> IO Semaphore
semOpen name flags mode value =
let cflags = (if semCreate flags then 64 else 0) .|.
{-# LINE 65 "System/Posix/Semaphore.hsc" #-}
(if semExclusive flags then 128 else 0)
{-# LINE 66 "System/Posix/Semaphore.hsc" #-}
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'
semUnlink :: String -> IO ()
semUnlink name = withCAString name semUnlink'
where semUnlink' cname = throwErrnoPathIfMinus1_ "semUnlink" name $
sem_unlink cname
semWait :: Semaphore -> IO ()
semWait (Semaphore fptr) = withForeignPtr fptr semWait'
where semWait' sem = throwErrnoIfMinus1Retry_ "semWait" $
sem_wait sem
semWaitInterruptible :: Semaphore -> IO Bool
semWaitInterruptible (Semaphore fptr) = withForeignPtr fptr semWait'
where semWait' sem =
do res <- sem_wait_interruptible sem
if res == 0 then return True
else do errno <- getErrno
if errno == eINTR
then return False
else throwErrno "semWaitInterrruptible"
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"))
semThreadWait :: Semaphore -> IO ()
semThreadWait sem
| hostIsThreaded = semWait sem
| otherwise = do
res <- semTryWait sem
if res then return ()
else do yield >> semThreadWait sem
semPost :: Semaphore -> IO ()
semPost (Semaphore fptr) = withForeignPtr fptr semPost'
where semPost' sem = throwErrnoIfMinus1Retry_ "semPost" $
sem_post sem
semGetValue :: Semaphore -> IO Int
{-# LINE 140 "System/Posix/Semaphore.hsc" #-}
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 capi safe "semaphore.h sem_getvalue"
sem_getvalue :: Ptr () -> Ptr CInt -> IO Int
{-# LINE 156 "System/Posix/Semaphore.hsc" #-}
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 interruptible "semaphore.h sem_wait"
sem_wait_interruptible :: 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