-----------------------------------------------------------------------------
-- |
-- 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 init = do
   sem <- newMVar (init,[])
   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 ()