{-# LINE 1 "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 qualified System.Posix.Internals as Base
import Control.Concurrent
import Data.Bits

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

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


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

{-# LINE 50 "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 :: CInt
cflags = (if OpenSemFlags -> Bool
semCreate OpenSemFlags
flags then CInt
Base.o_CREAT else CInt
0) CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
.|.
                 (if OpenSemFlags -> Bool
semExclusive OpenSemFlags
flags then CInt
Base.o_EXCL else CInt
0)
        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 (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
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

-- | 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 CInt
res <- Ptr () -> IO CInt
sem_wait_interruptible 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 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
"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 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
  -- 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
      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 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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

{-# LINE 141 "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
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_getvalue"
        sem_getvalue :: Ptr () -> Ptr CInt -> IO Int

{-# LINE 157 "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