Add semWaitInterruptible

The semWaitInterruptible function allows us to start a thread
that blocks on the semaphore but can be interrupted.

(cherry picked from commit 9c50f37)

Author: mpickering

System/Posix/Semaphore.hsc

@@ -1,5 +1,6 @@
 {-# LANGUAGE Safe #-}
 {-# LANGUAGE CApiFFI #-}
+{-# LANGUAGE InterruptibleFFI #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  System.Posix.Semaphore
@@ -16,7 +17,7 @@
 
 module System.Posix.Semaphore
     (OpenSemFlags(..), Semaphore(),
-     semOpen, semUnlink, semWait, semTryWait, semThreadWait,
+     semOpen, semUnlink, semWait, semWaitInterruptible, semTryWait, semThreadWait,
      semPost, semGetValue)
     where
 
@@ -86,6 +87,20 @@ semWait (Semaphore fptr) = withForeignPtr fptr semWait'
     where semWait' sem = throwErrnoIfMinus1Retry_ "semWait" $
                          sem_wait 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 fptr) = withForeignPtr fptr semWait'
+    where semWait' sem =
+            do res <- sem_wait_interruptible 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
@@ -145,9 +160,10 @@ 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"

tests/SemaphoreInterrupt.hs

@@ -0,0 +1,32 @@
+module Main (main) where
+
+import Control.Concurrent
+import Control.Monad
+import Data.IORef
+import System.Posix
+
+main :: IO ()
+main = do
+
+  sem <- semOpen "/test" OpenSemFlags {semCreate = True, semExclusive = False} stdFileMode 0
+  ref <- newIORef False
+  _ <- forkIO $ do
+    res <- semWaitInterruptible sem
+    writeIORef ref res
+  threadDelay 100000 -- 100 ms
+  semPost sem
+  threadDelay 100000 -- 100 ms
+  succ1 <- readIORef ref
+  unless succ1 $
+    error "SemaphoreInterrupt: semWaitInterruptible failed"
+
+  writeIORef ref False
+  tid <- forkIO $ do
+    res <- semWaitInterruptible sem
+    writeIORef ref res
+  threadDelay 100000 -- 100 ms
+  killThread tid
+  threadDelay 100000 -- 100 ms
+  succ2 <- readIORef ref
+  when succ2 $
+    error "SemaphoreInterrupt: semWaitInterruptible not interrupted"

unix.cabal

@@ -270,3 +270,11 @@ test-suite Semaphore002
     default-language: Haskell2010
     build-depends: base, unix
     ghc-options: -Wall -threaded
+
+test-suite SemaphoreInterrupt
+    hs-source-dirs: tests
+    main-is: SemaphoreInterrupt.hs
+    type: exitcode-stdio-1.0
+    default-language: Haskell2010
+    build-depends: base, unix
+    ghc-options: -Wall -threaded