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