X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Control%2FConcurrent%2FQSem.hs;h=6b9a059e285c5f1cb472acc7b03c7b4b0efada54;hb=4475dcabbc206d1cf0fc3fee88f600a4791d948c;hp=d439a8ac577d2ee9da4f5bc81bf1c42da5efddff;hpb=746ef6a7fd71bb1e9ebe3cd107c5f9f79f3b7a68;p=ghc-base.git

diff --git a/Control/Concurrent/QSem.hs b/Control/Concurrent/QSem.hs
index d439a8a..6b9a059 100644
--- a/Control/Concurrent/QSem.hs
+++ b/Control/Concurrent/QSem.hs
@@ -1,26 +1,36 @@
+{-# LANGUAGE CPP #-}
+#ifdef __GLASGOW_HASKELL__
+{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
+#endif
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Control.Concurrent.QSem
 -- Copyright   :  (c) The University of Glasgow 2001
--- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
 -- 
 -- Maintainer  :  libraries@haskell.org
 -- Stability   :  experimental
--- Portability :  non-portable
+-- Portability :  non-portable (concurrency)
 --
--- General semaphores
+-- Simple quantity semaphores.
 --
 -----------------------------------------------------------------------------
 
 module Control.Concurrent.QSem
-	( QSem,		-- abstract
-	  newQSem,	-- :: Int  -> IO QSem
-	  waitQSem,	-- :: QSem -> IO ()
-	  signalQSem	-- :: QSem -> IO ()
-	) where
+        ( -- * Simple Quantity Semaphores
+          QSem,         -- abstract
+          newQSem,      -- :: Int  -> IO QSem
+          waitQSem,     -- :: QSem -> IO ()
+          signalQSem    -- :: QSem -> IO ()
+        ) where
 
 import Prelude
 import Control.Concurrent.MVar
+import Control.Exception ( mask_ )
+import Data.Typeable
+
+#include "Typeable.h"
 
 -- General semaphores are also implemented readily in terms of shared
 -- @MVar@s, only have to catch the case when the semaphore is tried
@@ -29,38 +39,50 @@ import Control.Concurrent.MVar
 -- representing threads currently waiting. The counter is a shared
 -- variable, ensuring the mutual exclusion on its access.
 
-newtype QSem = QSem (MVar (Int, [MVar ()]))
+-- |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 ()])) deriving Eq
+
+INSTANCE_TYPEABLE0(QSem,qSemTc,"QSem")
 
+-- |Build a new 'QSem' with a supplied initial quantity.
+--  The initial quantity must be at least 0.
 newQSem :: Int -> IO QSem
-newQSem init = do
-   sem <- newMVar (init,[])
-   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
-	process then only have to pick the MVar at the
-	front of the blocked list.
+        Stuff the reader at the back of the queue,
+        so as to preserve waiting order. A signalling
+        process then only have to pick the MVar at the
+        front of the blocked list.
 
-	The version of waitQSem given in the paper could
-	lead to starvation.
+        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
-	   putMVar sem (0,blocked')
-	   putMVar block ()
+     (b:blocked') -> do
+           putMVar sem (0,blocked')
+           putMVar b ()