X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Control%2FConcurrent%2FQSemN.hs;h=df3fa4207b754958c8d523f71a4e66beeb2ef10f;hb=3d4f3f4b8bc5571d3015816671457c88c0e697c3;hp=59e5e390e93ddb23aeee562f6f9b2d26bb3c6a0b;hpb=746ef6a7fd71bb1e9ebe3cd107c5f9f79f3b7a68;p=ghc-base.git

diff --git a/Control/Concurrent/QSemN.hs b/Control/Concurrent/QSemN.hs
index 59e5e39..df3fa42 100644
--- a/Control/Concurrent/QSemN.hs
+++ b/Control/Concurrent/QSemN.hs
@@ -2,57 +2,74 @@
 -- |
 -- Module      :  Control.Concurrent.QSemN
 -- 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)
 --
--- Quantity semaphores
+-- Quantity semaphores in which each thread may wait for an arbitrary
+-- \"amount\".
 --
 -----------------------------------------------------------------------------
 
 module Control.Concurrent.QSemN
-	( QSemN,	-- abstract
-	  newQSemN,	-- :: Int   -> IO QSemN
-	  waitQSemN,	-- :: QSemN -> Int -> IO ()
-	  signalQSemN	-- :: QSemN -> Int -> IO ()
+        (  -- * General Quantity Semaphores
+          QSemN,        -- abstract
+          newQSemN,     -- :: Int   -> IO QSemN
+          waitQSemN,    -- :: QSemN -> Int -> IO ()
+          signalQSemN   -- :: QSemN -> Int -> IO ()
       ) where
 
 import Prelude
 
 import Control.Concurrent.MVar
+import Control.Exception ( block )
+import Data.Typeable
 
+#include "Typeable.h"
+
+-- |A 'QSemN' is a quantity semaphore, in which the available
+-- \"quantity\" may be signalled or waited for in arbitrary amounts.
 newtype QSemN = QSemN (MVar (Int,[(Int,MVar ())]))
 
-newQSemN :: Int -> IO QSemN 
-newQSemN init = do
-   sem <- newMVar (init,[])
-   return (QSemN sem)
+INSTANCE_TYPEABLE0(QSemN,qSemNTc,"QSemN")
+
+-- |Build a new 'QSemN' with a supplied initial quantity.
+--  The initial quantity must be at least 0.
+newQSemN :: Int -> IO QSemN
+newQSemN initial =
+    if initial < 0
+    then fail "newQSemN: Initial quantity must be non-negative"
+    else do sem <- newMVar (initial, [])
+            return (QSemN sem)
 
+-- |Wait for the specified quantity to become available
 waitQSemN :: QSemN -> Int -> IO ()
-waitQSemN (QSemN sem) sz = do
+waitQSemN (QSemN sem) sz = block $ do
   (avail,blocked) <- takeMVar sem   -- gain ex. access
-  if (avail - sz) >= 0 then
+  let remaining = avail - sz
+  if remaining >= 0 then
        -- discharging 'sz' still leaves the semaphore
        -- in an 'unblocked' state.
-     putMVar sem (avail-sz,[])
+     putMVar sem (remaining,blocked)
    else do
-     block <- newEmptyMVar
-     putMVar sem (avail, blocked++[(sz,block)])
-     takeMVar block
+     b <- newEmptyMVar
+     putMVar sem (avail, blocked++[(sz,b)])
+     takeMVar b
 
+-- |Signal that a given quantity is now available from the 'QSemN'.
 signalQSemN :: QSemN -> Int  -> IO ()
-signalQSemN (QSemN sem) n = do
+signalQSemN (QSemN sem) n = block $ do
    (avail,blocked)   <- takeMVar sem
    (avail',blocked') <- free (avail+n) blocked
-   putMVar sem (avail',blocked')
+   avail' `seq` putMVar sem (avail',blocked')
  where
    free avail []    = return (avail,[])
-   free avail ((req,block):blocked)
+   free avail ((req,b):blocked)
      | avail >= req = do
-	putMVar block ()
-	free (avail-req) blocked
+        putMVar b ()
+        free (avail-req) blocked
      | otherwise    = do
-	(avail',blocked') <- free avail blocked
-        return (avail',(req,block):blocked')
+        (avail',blocked') <- free avail blocked
+        return (avail',(req,b):blocked')