{-# 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" #-}
-----------------------------------------------------------------------------
-- |
-- 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




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,
                                   -- ^ 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.
                                 }

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 :: 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
External instance of the constraint type Bits Int
.|.
{-# LINE 54 "libraries/unix/System/Posix/Semaphore.hsc" #-}
                 (if OpenSemFlags -> Bool
semExclusive OpenSemFlags
flags then Int
128 else Int
0)
{-# LINE 55 "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
External instance of the constraint type Enum CInt
toEnum Int
cflags) FileMode
mode (Int -> CUInt
forall a. Enum a => Int -> a
External instance of the constraint type Enum CUInt
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 (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type Monad IO
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 ()
External instance of the constraint type Num CInt
External instance of the constraint type Eq CInt
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'

-- | 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
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 ()
External instance of the constraint type Num CInt
External instance of the constraint type Eq CInt
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
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 ()
External instance of the constraint type Num CInt
External instance of the constraint type Eq CInt
throwErrnoIfMinus1Retry_ String
"semWait" (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$
                         Ptr () -> IO CInt
sem_wait Ptr ()
sem

-- | Attempt to lock the semaphore without blocking.  Immediately return
--   False if it is not available.
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
External instance of the constraint type Eq CInt
== CInt
0 then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type Monad IO
return Bool
True
                                else do Errno
errno <- IO Errno
getErrno
                                        (if Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
External instance of the constraint type Eq Errno
== Errno
eINTR
                                         then Ptr () -> IO Bool
semTrywait' Ptr ()
sem
                                         else if Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
External instance of the constraint type Eq Errno
== Errno
eAGAIN
                                              then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type Monad IO
return Bool
False
                                              else String -> IO Bool
forall a. String -> IO a
throwErrno String
"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 = do Bool
res <- Semaphore -> IO Bool
semTryWait Semaphore
sem
                       (if Bool
res then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type Monad IO
return ()
                        else ( do { IO ()
yield; 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
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 ()
External instance of the constraint type Num CInt
External instance of the constraint type Eq CInt
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 -> 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
External instance of the constraint type Storable CInt
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 ()
External instance of the constraint type Num Int
External instance of the constraint type Eq Int
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
External instance of the constraint type Storable CInt
peek Ptr CInt
ptr
                          Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type Monad IO
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ CInt -> Int
forall a. Enum a => a -> Int
External instance of the constraint type Enum CInt
fromEnum CInt
cint

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