-----------------------------------------------------------------------------
-- |
-- 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 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
-- 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' with a supplied initial quantity.
--  The initial quantity must be at least 0.
newQSem :: Int -> IO QSem
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) = mask_ $ do
   (avail,blocked) <- takeMVar sem  -- gain ex. access
   if avail > 0 then
     let avail' = avail-1
     in avail' `seq` putMVar sem (avail',[])
    else do
     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.

        The version of waitQSem given in the paper could
        lead to starvation.
      -}
     putMVar sem (0, blocked++[b])
     takeMVar b

-- |Signal that a unit of the 'QSem' is available
signalQSem :: QSem -> IO ()
signalQSem (QSem sem) = mask_ $ do
   (avail,blocked) <- takeMVar sem
   case blocked of
     [] -> let avail' = avail+1
           in avail' `seq` putMVar sem (avail',blocked)

     (b:blocked') -> do
           putMVar sem (0,blocked')
           putMVar b ()