-----BEGIN PGP SIGNED MESSAGE----- Hash: SHA1 New patches: [Add support for named semaphores and shared memory objects Daniel Franke **20070503220003] < > { hunk ./System/Posix.hs 28 module System.Posix.Terminal, module System.Posix.Time, module System.Posix.User, - - module System.Posix.Resource + module System.Posix.Resource, + module System.Posix.Semaphore, + module System.Posix.SharedMem ) where import System.Posix.Types hunk ./System/Posix.hs 46 import System.Posix.Time import System.Posix.User import System.Posix.Resource +import System.Posix.Semaphore +import System.Posix.SharedMem {- TODO addfile ./System/Posix/Semaphore.hsc hunk ./System/Posix/Semaphore.hsc 1 +{-# 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 +#include + +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 addfile ./System/Posix/SharedMem.hsc hunk ./System/Posix/SharedMem.hsc 1 +{-# 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 +#include +#include + +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 hunk ./unix.cabal 32 System.Posix.Unistd System.Posix.User System.Posix.Signals.Exts + System.Posix.Semaphore + System.Posix.SharedMem extra-source-files: configure.ac configure unix.buildinfo.in include/HsUnixConfig.h.in } Context: [Make it more obvious that the forkprocess01 test is really working Ian Lynagh **20070418114542] [Follow Cabal changes in Setup.hs Ian Lynagh **20070418114510] [Handle sysconf(3) return value -1 when checking _SC_GETGR_R_SIZE_MAX and _SC_GETPW_R_SIZE_MAX. bjorn@bringert.net**20070416214837 sysconf(3) returns -1 on failure, but this was not handled when checking _SC_GETGR_R_SIZE_MAX and _SC_GETPW_R_SIZE_MAX in System.Posix.User. This made getUserEntryForID, getUserEntryForName, getGroupEntryForID and getGroupEntryForName fail on OS X 10.4.9 on i386. Just checking that unistd.h defines _SC_GETGR_R_SIZE_MAX and _SC_GETPW_R_SIZE_MAX as was done before does not guarantee that sysconf(3) will succeed. sysconf(3) failure is now handled by using the same default values as were already used when sysconf(3) is not available, or the parameter names are not defined. ] [Added tests/user001.hs which tests all the get* functions in System.Posix.User. bjorn@bringert.net**20070416220012 I added this since I noticed that getUserEntryForID, getUserEntryForName, getGroupEntryForID and getGroupEntryForName failed on OS X 10.4.9 on i386. ] [Fix -Wall warnings Ian Lynagh **20070411005028] [Add missing case in removePrefix Ian Lynagh **20070411002604] [parse (but don't pass on) options for ./configure Ian Lynagh **20070406153756] [make Setup suitable for building the libraries with GHC Ian Lynagh **20061112214741] [Don't use Fd/FD in foreign decls Ian Lynagh **20070404155930 Using CInt makes it much easier to verify that it is right, and we won't get caught out by possible newtype switches between CInt/Int. ] [Fix C/Haskell type mismatches Ian Lynagh **20070404003625] [Follow type changes in base Ian Lynagh **20070403195237 (of the dubiously exported c_access and c_fcntl_write) ] [fix cut-and-pasto in error message Simon Marlow **20070308134418] [add tests from GHC testsuite Simon Marlow **20070305145258] [export the file-type modes, so that createDevice can be used Simon Marlow **20070305113316] [Provide nanosleep if we have it, and use it to implement usleep Simon Marlow **20070302132818 Fixes #1156 ] [don't retry usleep() on EINTR (see #850/#1156) Simon Marlow **20070302114118] [expand docs for forkProcess Simon Marlow **20070301151220] [add C wrappers for lstat() and mknod(). Fixes #1086. Simon Marlow **20070226110311] [README about building from darcs Ross Paterson **20070218110201] [TAG 6.6 release Ian Lynagh **20061011124740] Patch bundle hash: 9e22a94c081d2378553774032fdcc4ae83fe9207 -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.6 (GNU/Linux) iD8DBQFGOl0uKTA17JAC/eYRAimQAKC+OpKb+peTO+gnkd93l1cVg0+LUwCeNYey EHpPhaN98raufE2Imxg/lc4= =zRQO -----END PGP SIGNATURE-----