Add missing files

[ghc-base.git] / Control / Concurrent / QSem.hs

diff --git a/Control/Concurrent/QSem.hs b/Control/Concurrent/QSem.hs
new file mode 100644 (file)
index 0000000..87f5543
--- /dev/null
+++ b/Control/Concurrent/QSem.hs
@@ -0,0 +1,77 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Control.Concurrent.QSem
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable (concurrency)
+--
+-- Simple quantity semaphores.
+--
+-----------------------------------------------------------------------------
+
+module Control.Concurrent.QSem
+        ( -- * Simple Quantity Semaphores
+          QSem,         -- abstract
+          newQSem,      -- :: Int  -> IO QSem
+          waitQSem,     -- :: QSem -> IO ()
+          signalQSem    -- :: QSem -> IO ()
+        ) where
+
+import Prelude
+import Control.Concurrent.MVar
+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
+-- waited on when it is empty (==0). Implement this in the same way as
+-- shared variables are implemented - maintaining a list of @MVar@s
+-- representing threads currently waiting. The counter is a shared
+-- variable, ensuring the mutual exclusion on its access.
+
+-- |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 ()]))
+
+INSTANCE_TYPEABLE0(QSem,qSemTc,"QSem")
+
+-- |Build a new 'QSem'
+newQSem :: Int -> IO QSem
+newQSem initial = do
+   sem <- newMVar (initial, [])
+   return (QSem sem)
+
+-- |Wait for a unit to become available
+waitQSem :: QSem -> IO ()
+waitQSem (QSem sem) = do
+   (avail,blocked) <- takeMVar sem  -- gain ex. access
+   if avail > 0 then
+     putMVar sem (avail-1,[])
+    else do
+     block <- 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.
+
+        The version of waitQSem given in the paper could
+        lead to starvation.
+      -}
+     putMVar sem (0, blocked++[block])
+     takeMVar block
+
+-- |Signal that a unit of the 'QSem' is available
+signalQSem :: QSem -> IO ()
+signalQSem (QSem sem) = do
+   (avail,blocked) <- takeMVar sem
+   case blocked of
+     [] -> putMVar sem (avail+1,[])
+
+     (block:blocked') -> do
+           putMVar sem (0,blocked')
+           putMVar block ()