    {-# LINE 1 "libraries/unix/System/Posix/Semaphore.hsc" #-}
    {-# LANGUAGE Safe #-}
    {-# LANGUAGE CApiFFI #-}
    {-# LANGUAGE InterruptibleFFI #-}
    -----------------------------------------------------------------------------
    -- |
    -- 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, semWaitInterruptible, semTryWait, semThreadWait,
         semPost, semGetValue)
        where

    import Foreign.C
    import Foreign.ForeignPtr hiding (newForeignPtr)
    import Foreign.Concurrent
    import Foreign.Ptr
    import System.Posix.Types
    import Control.Concurrent
    import Data.Bits

    {-# LINE 39 "libraries/unix/System/Posix/Semaphore.hsc" #-}
    import Foreign.Marshal
    import Foreign.Storable

    {-# LINE 42 "libraries/unix/System/Posix/Semaphore.hsc" #-}

    {-# LINE 44 "libraries/unix/System/Posix/Semaphore.hsc" #-}
    import System.Posix.Internals (hostIsThreaded)

    {-# LINE 49 "libraries/unix/System/Posix/Semaphore.hsc" #-}

    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 65 "libraries/unix/System/Posix/Semaphore.hsc" #-}
                     (if OpenSemFlags -> Bool
    semExclusive OpenSemFlags
    flags then Int
    128 else Int
    0)
    {-# LINE 66 "libraries/unix/System/Posix/Semaphore.hsc" #-}
            semOpen' :: CString -> IO Semaphore
    semOpen' CString
    cname =
                do 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)
                   fptr <- newForeignPtr sem (finalize sem)
                   return $ Semaphore 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

    -- | Lock the semaphore, blocking until it becomes available.
    --
    -- Unlike 'semWait', this wait operation can be interrupted with
    -- an asynchronous exception (e.g. a call to 'throwTo' from another thread).
    semWaitInterruptible :: Semaphore -> IO Bool
    semWaitInterruptible :: Semaphore -> IO Bool
    semWaitInterruptible (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
    semWait'
        where semWait' :: Ptr () -> IO Bool
    semWait' Ptr ()
    sem =
                do res <- Ptr () -> IO CInt
    sem_wait_interruptible Ptr ()
    sem
                   if res == 0 then return True
                               else do errno <- getErrno
                                       if errno == eINTR
                                         then return False
                                         else throwErrno "semWaitInterrruptible"

    -- | 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 res <- Ptr () -> IO CInt
    sem_trywait Ptr ()
    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 :: Semaphore -> IO ()
    semThreadWait Semaphore
    sem
      -- N.B. semWait can be safely used in the case of the threaded runtime, where
      -- the safe foreign call will be performed in its own thread, thereby not
      -- blocking the process.
      | Bool
    hostIsThreaded = Semaphore -> IO ()
    semWait Semaphore
    sem
      | Bool
    otherwise = do
          res <- Semaphore -> IO Bool
    semTryWait Semaphore
    sem
          if res then return ()
                 else do yield >> semThreadWait 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

    {-# LINE 140 "libraries/unix/System/Posix/Semaphore.hsc" #-}
    semGetValue (Semaphore fptr) = withForeignPtr fptr semGetValue'
        where semGetValue' sem = alloca (semGetValue_ 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 <- Ptr CInt -> IO CInt
    forall a. Storable a => Ptr a -> IO a
    peek Ptr CInt
    ptr
                              return $ fromEnum cint

    foreign import capi safe "semaphore.h sem_getvalue"
            sem_getvalue :: Ptr () -> Ptr CInt -> IO Int

    {-# LINE 156 "libraries/unix/System/Posix/Semaphore.hsc" #-}

    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 interruptible "semaphore.h sem_wait"
            sem_wait_interruptible :: 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