{-# LINE 1 "System/Posix/Semaphore.hsc" #-}

{-# LINE 2 "System/Posix/Semaphore.hsc" #-}
{-# LANGUAGE Safe #-}

{-# LINE 6 "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 { 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 64 else 0) .|.
{-# LINE 54 "System/Posix/Semaphore.hsc" #-}
                 (if semExclusive flags then 128 else 0)
{-# LINE 55 "System/Posix/Semaphore.hsc" #-}
        semOpen' cname =
            do sem <- throwErrnoPathIfNull "semOpen" name $
                      sem_open cname (toEnum cflags) mode (toEnum value)
               fptr <- newForeignPtr sem (finalize 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 "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