X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Control%2FConcurrent%2FQSem.hs;h=22f6c0c8f6be1eba665998fd90ef377536e7771f;hb=41e8fba828acbae1751628af50849f5352b27873;hp=87f5543033616dc8eae933f014513bbec5d1e7c2;hpb=d07c47f3080ebae7bed4a94c258a90f07d911415;p=ghc-base.git

diff --git a/Control/Concurrent/QSem.hs b/Control/Concurrent/QSem.hs
index 87f5543..22f6c0c 100644
--- a/Control/Concurrent/QSem.hs
+++ b/Control/Concurrent/QSem.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Control.Concurrent.QSem
@@ -22,6 +24,7 @@ module Control.Concurrent.QSem
 
 import Prelude
 import Control.Concurrent.MVar
+import Control.Exception ( mask_ )
 import Data.Typeable
 
 #include "Typeable.h"
@@ -35,24 +38,28 @@ import Data.Typeable
 
 -- |A 'QSem' is a simple quantity semaphore, in which the available
 -- \"quantity\" is always dealt with in units of one.
-newtype QSem = QSem (MVar (Int, [MVar ()]))
+newtype QSem = QSem (MVar (Int, [MVar ()])) deriving Eq
 
 INSTANCE_TYPEABLE0(QSem,qSemTc,"QSem")
 
--- |Build a new 'QSem'
+-- |Build a new 'QSem' with a supplied initial quantity.
+--  The initial quantity must be at least 0.
 newQSem :: Int -> IO QSem
-newQSem initial = do
-   sem <- newMVar (initial, [])
-   return (QSem sem)
+newQSem initial =
+    if initial < 0
+    then fail "newQSem: Initial quantity must be non-negative"
+    else do sem <- newMVar (initial, [])
+            return (QSem sem)
 
 -- |Wait for a unit to become available
 waitQSem :: QSem -> IO ()
-waitQSem (QSem sem) = do
+waitQSem (QSem sem) = mask_ $ do
    (avail,blocked) <- takeMVar sem  -- gain ex. access
    if avail > 0 then
-     putMVar sem (avail-1,[])
+     let avail' = avail-1
+     in avail' `seq` putMVar sem (avail',[])
     else do
-     block <- newEmptyMVar
+     b <- newEmptyMVar
       {-
         Stuff the reader at the back of the queue,
         so as to preserve waiting order. A signalling
@@ -62,16 +69,17 @@ waitQSem (QSem sem) = do
         The version of waitQSem given in the paper could
         lead to starvation.
       -}
-     putMVar sem (0, blocked++[block])
-     takeMVar block
+     putMVar sem (0, blocked++[b])
+     takeMVar b
 
 -- |Signal that a unit of the 'QSem' is available
 signalQSem :: QSem -> IO ()
-signalQSem (QSem sem) = do
+signalQSem (QSem sem) = mask_ $ do
    (avail,blocked) <- takeMVar sem
    case blocked of
-     [] -> putMVar sem (avail+1,[])
+     [] -> let avail' = avail+1
+           in avail' `seq` putMVar sem (avail',blocked)
 
-     (block:blocked') -> do
+     (b:blocked') -> do
            putMVar sem (0,blocked')
-           putMVar block ()
+           putMVar b ()