{-# LINE 1 "System/Posix/Semaphore.hsc" #-}{-# LANGUAGE Safe #-}{-# LANGUAGE CApiFFI #-}{-# LANGUAGE InterruptibleFFI #-}------------------------------------------------------------------------------- |-- 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.-------------------------------------------------------------------------------moduleSystem.Posix.Semaphore(OpenSemFlags (..),Semaphore (),semOpen ,semUnlink ,semWait ,semWaitInterruptible ,semTryWait ,semThreadWait ,semPost ,semGetValue )whereimportForeign.CimportForeign.ForeignPtrhiding(newForeignPtr)importForeign.ConcurrentimportForeign.PtrimportSystem.Posix.TypesimportControl.ConcurrentimportData.Bits{-# LINE 39 "System/Posix/Semaphore.hsc" #-}importForeign.MarshalimportForeign.Storable{-# LINE 42 "System/Posix/Semaphore.hsc" #-}{-# LINE 44 "System/Posix/Semaphore.hsc" #-}importSystem.Posix.Internals(hostIsThreaded){-# LINE 49 "System/Posix/Semaphore.hsc" #-}dataOpenSemFlags =OpenSemFlags {OpenSemFlags -> Bool
semCreate ::Bool,-- ^ If true, create the semaphore if it-- does not yet exist.OpenSemFlags -> Bool
semExclusive ::Bool-- ^ If true, throw an exception if the-- semaphore already exists.}newtypeSemaphore =Semaphore (ForeignPtr())-- | Open a named semaphore with the given name, flags, mode, and initial-- value.semOpen ::String->OpenSemFlags ->FileMode->Int->IOSemaphore semOpen :: String -> OpenSemFlags -> FileMode -> Int -> IO Semaphore
semOpen String
name OpenSemFlags
flags FileMode
mode Int
value =letcflags :: Int
cflags =(ifOpenSemFlags -> Bool
semCreate OpenSemFlags
flags thenInt
64elseInt
0)Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|.{-# LINE 65 "System/Posix/Semaphore.hsc" #-}(ifOpenSemFlags -> Bool
semExclusive OpenSemFlags
flags thenInt
128elseInt
0){-# LINE 66 "System/Posix/Semaphore.hsc" #-}semOpen' :: CString -> IO Semaphore
semOpen' CString
cname =doPtr ()
sem <-String -> String -> IO (Ptr ()) -> IO (Ptr ())
forall a. String -> String -> IO (Ptr a) -> IO (Ptr a)
throwErrnoPathIfNullString
"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
toEnumInt
cflags )FileMode
mode (Int -> CUInt
forall a. Enum a => Int -> a
toEnumInt
value )ForeignPtr ()
fptr <-Ptr () -> IO () -> IO (ForeignPtr ())
forall a. Ptr a -> IO () -> IO (ForeignPtr a)
newForeignPtrPtr ()
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 inString -> (CString -> IO Semaphore) -> IO Semaphore
forall a. String -> (CString -> IO a) -> IO a
withCAStringString
name CString -> IO Semaphore
semOpen' -- | Delete the semaphore with the given name.semUnlink ::String->IO()semUnlink :: String -> IO ()
semUnlink String
name =String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCAStringString
name CString -> IO ()
semUnlink' wheresemUnlink' :: 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 -- | 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 -> IO ()
semWait (Semaphore ForeignPtr ()
fptr )=ForeignPtr () -> (Ptr () -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtrForeignPtr ()
fptr Ptr () -> IO ()
semWait' wheresemWait' :: 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 -- | Lock the semaphore, blocking until it becomes available.---- Unlike 'semWait', this wait operation can be interrupted with-- an asynchronous exception (e.g. a call to 'throwTo' from another thread).semWaitInterruptible ::Semaphore ->IOBoolsemWaitInterruptible :: Semaphore -> IO Bool
semWaitInterruptible (Semaphore ForeignPtr ()
fptr )=ForeignPtr () -> (Ptr () -> IO Bool) -> IO Bool
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtrForeignPtr ()
fptr Ptr () -> IO Bool
semWait' wheresemWait' :: Ptr () -> IO Bool
semWait' Ptr ()
sem =doCInt
res <-Ptr () -> IO CInt
sem_wait_interruptible Ptr ()
sem ifCInt
res CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
==CInt
0thenBool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
returnBool
TrueelsedoErrno
errno <-IO Errno
getErrnoifErrno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
==Errno
eINTRthenBool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
returnBool
FalseelseString -> IO Bool
forall a. String -> IO a
throwErrnoString
"semWaitInterrruptible"-- | Attempt to lock the semaphore without blocking. Immediately return-- False if it is not available.semTryWait ::Semaphore ->IOBoolsemTryWait :: Semaphore -> IO Bool
semTryWait (Semaphore ForeignPtr ()
fptr )=ForeignPtr () -> (Ptr () -> IO Bool) -> IO Bool
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtrForeignPtr ()
fptr Ptr () -> IO Bool
semTrywait' wheresemTrywait' :: Ptr () -> IO Bool
semTrywait' Ptr ()
sem =doCInt
res <-Ptr () -> IO CInt
sem_trywait Ptr ()
sem (ifCInt
res CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
==CInt
0thenBool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
returnBool
TrueelsedoErrno
errno <-IO Errno
getErrno(ifErrno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
==Errno
eINTRthenPtr () -> IO Bool
semTrywait' Ptr ()
sem elseifErrno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
==Errno
eAGAINthenBool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
returnBool
FalseelseString -> IO Bool
forall a. String -> IO a
throwErrnoString
"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 :: Semaphore -> IO ()
semThreadWait Semaphore
sem -- N.B. semWait can be safely used in the case of the threaded runtime, where-- the safe foreign call will be performed in its own thread, thereby not-- blocking the process.|Bool
hostIsThreaded=Semaphore -> IO ()
semWait Semaphore
sem |Bool
otherwise=doBool
res <-Semaphore -> IO Bool
semTryWait Semaphore
sem ifBool
res then() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return()elsedoIO ()
yieldIO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>Semaphore -> IO ()
semThreadWait Semaphore
sem -- | Unlock the semaphore.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
withForeignPtrForeignPtr ()
fptr Ptr () -> IO ()
semPost' wheresemPost' :: 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 -- | Return the semaphore's current value.semGetValue ::Semaphore ->IOInt{-# LINE 140 "System/Posix/Semaphore.hsc" #-}semGetValue(Semaphorefptr)=withForeignPtrfptrsemGetValue'wheresemGetValue'sem=alloca(semGetValue_sem)semGetValue_ ::Ptr()->PtrCInt->IOIntsemGetValue_ :: Ptr () -> Ptr CInt -> IO Int
semGetValue_ Ptr ()
sem Ptr CInt
ptr =doString -> 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
peekPtr 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
fromEnumCInt
cint foreignimportcapisafe"semaphore.h sem_getvalue"sem_getvalue ::Ptr()->PtrCInt->IOInt{-# LINE 156 "System/Posix/Semaphore.hsc" #-}foreignimportcapisafe"semaphore.h sem_open"sem_open ::CString->CInt->CMode->CUInt->IO(Ptr())foreignimportcapisafe"semaphore.h sem_close"sem_close ::Ptr()->IOCIntforeignimportcapisafe"semaphore.h sem_unlink"sem_unlink ::CString->IOCIntforeignimportcapisafe"semaphore.h sem_wait"sem_wait ::Ptr()->IOCIntforeignimportcapiinterruptible"semaphore.h sem_wait"sem_wait_interruptible ::Ptr()->IOCIntforeignimportcapisafe"semaphore.h sem_trywait"sem_trywait ::Ptr()->IOCIntforeignimportcapisafe"semaphore.h sem_post"sem_post ::Ptr()->IOCInt