diff options
Diffstat (limited to 'System/Posix')
-rw-r--r-- | System/Posix/Semaphore.hsc | 132 | ||||
-rw-r--r-- | System/Posix/SharedMem.hsc | 70 |
2 files changed, 202 insertions, 0 deletions
diff --git a/System/Posix/Semaphore.hsc b/System/Posix/Semaphore.hsc new file mode 100644 index 0000000..52bef18 --- /dev/null +++ b/System/Posix/Semaphore.hsc @@ -0,0 +1,132 @@ +{-# OPTIONS -fffi #-} + +----------------------------------------------------------------------------- +-- | +-- 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 +import Foreign.Marshal +import Foreign.Ptr +import Foreign.Storable +import System.Posix.Types +import System.Posix.Error +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) + finalizer <- mkCallback (finalize sem) + fptr <- newForeignPtr finalizer 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 "wrapper" + mkCallback :: (Ptr () -> IO ()) -> IO (FunPtr (Ptr () -> IO ())) + +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 diff --git a/System/Posix/SharedMem.hsc b/System/Posix/SharedMem.hsc new file mode 100644 index 0000000..52d4cb1 --- /dev/null +++ b/System/Posix/SharedMem.hsc @@ -0,0 +1,70 @@ +{-# OPTIONS -fffi #-} + +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.SharedMem +-- 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 shared memory support. +-- +----------------------------------------------------------------------------- + +module System.Posix.SharedMem + (ShmOpenFlags(..), shmOpen, shmUnlink) + where + +#include <sys/types.h> +#include <sys/mman.h> +#include <sys/fcntl.h> + +import System.Posix.Types +import System.Posix.Error +import Foreign.C +import Data.Bits + +data ShmOpenFlags = ShmOpenFlags + { shmReadWrite :: Bool, + -- ^ If true, open the shm object read-write rather than read-only. + shmCreate :: Bool, + -- ^ If true, create the shm object if it does not exist. + shmExclusive :: Bool, + -- ^ If true, throw an exception if the shm object already exists. + shmTrunc :: Bool + -- ^ If true, wipe the contents of the shm object after opening it. + } + +-- | Open a shared memory object with the given name, flags, and mode. +shmOpen :: String -> ShmOpenFlags -> FileMode -> IO Fd +shmOpen name flags mode = + do cflags <- return 0 + cflags <- return $ cflags .|. (if shmReadWrite flags + then #{const O_RDWR} + else #{const O_RDONLY}) + cflags <- return $ cflags .|. (if shmCreate flags then #{const O_CREAT} + else 0) + cflags <- return $ cflags .|. (if shmExclusive flags + then #{const O_EXCL} + else 0) + cflags <- return $ cflags .|. (if shmTrunc flags then #{const O_TRUNC} + else 0) + withCAString name (shmOpen' cflags mode) + where shmOpen' cflags mode cname = + do fd <- throwErrnoIfMinus1 "shmOpen" $ + shm_open cname cflags mode + return $ Fd fd + +-- | Delete the shared memory object with the given name. +shmUnlink :: String -> IO () +shmUnlink name = withCAString name shmUnlink' + where shmUnlink' cname = + throwErrnoIfMinus1_ "shmUnlink" $ shm_unlink cname + +foreign import ccall unsafe "shm_open" + shm_open :: CString -> CInt -> CMode -> IO CInt +foreign import ccall unsafe "shm_unlink" + shm_unlink :: CString -> IO CInt |