{-# 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" #-}
{-# LANGUAGE CApiFFI #-}
-----------------------------------------------------------------------------
-- |
-- 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
.|.
{-# LINE 55 "libraries/unix/System/Posix/Semaphore.hsc" #-}
                 (if OpenSemFlags -> Bool
semExclusive OpenSemFlags
flags then Int
128 else Int
0)
{-# LINE 56 "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
toEnum Int
cflags) FileMode
mode (Int -> CUInt
forall a. Enum a => Int -> a
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 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 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 ()
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 ()
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
== CInt
0 then Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                                else do Errno
errno <- IO Errno
getErrno
                                        (if Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eINTR
                                         then Ptr () -> IO Bool
semTrywait' Ptr ()
sem
                                         else if Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eAGAIN
                                              then Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
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 ()
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
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 ()
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
peek Ptr 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
fromEnum CInt
cint

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 safe "semaphore.h sem_trywait"
        sem_trywait :: Ptr () -> IO CInt
foreign import capi safe "semaphore.h sem_post"
        sem_post :: Ptr () -> IO CInt
foreign import capi safe "semaphore.h sem_getvalue"
        sem_getvalue :: Ptr () -> Ptr CInt -> IO Int