Haskell Code by HsColour

-----------------------------------------------------------------------------
-- |
-- 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 ()