QSem.hs

{- |
Module      :  <File name or $Header$ to be replaced automatically>
Description :  This module implements a quantity semaphores with buffers
Maintainer  :  willig@ki.informatik.uni-frankfurt.de
Stability   :  experimental
Portability :  non-portable (requires Futures)

This module implements a quantity semaphore using buffers that block on
futures.

A QSem equals to QSemN in Control.Concurrent.
A Buffer equals to QSem in Control.Concurrent.

Warning: All operations on quantity semaphores should only be used within the 
global wrapper function 'Futures.withFuturesDo'!
-}
module Control.Concurrent.Futures.QSem (
            QSem,
			newQSem,
			up,
			down,
			enter
) where

import qualified Control.Concurrent
import System.IO.Unsafe		( unsafeInterleaveIO )
import Control.Concurrent.Futures.Futures
import Control.Concurrent.Futures.Buffer

-- | A quantity semaphores contains of a capacity and a waiting queue containing 
-- buffers.
type QSem = Buffer (Int, [Buffer Bool])

-- | Creates a new quantity semaphore of capacity cnt.
newQSem :: Int -> IO (Buffer (Int, [Buffer Bool]))
newQSem cnt = do
 b <- newBuf
 putBuf b (cnt,[])
 return b
 -- For comparison the implementation of the Concurrent Haskell Library 
--newQSem :: Int -> IO QSem
--newQSem init = do
--sem <- newMVar (init,[])
--return (QSem sem)


-- | Increments the semaphore's value, if there are no waiters.
-- 'up' reads out of the waiting queue and writes True into a waiting 'Buffer'.
-- Note: This operation equals to signalQSemN in Control.Concurrent.QSemN.
up :: QSem -> IO ()
up qsem = do
 (cnt,ls) <- getBuf qsem
 case ls of
          [] -> do putBuf qsem (cnt+1,ls)
          x:xs -> do
            putBuf x True
            putBuf qsem (cnt,ls)

-- | Decrements the semaphore's value. If the value has already reached zero, then 
-- 'down' creates a new empty 'Buffer' that is being added to the semaphore's waiting queue.
-- It blocks until the buffer gets filled by a 'up'.
-- Note: This operation equals to waitQSemN in Control.Concurrent.QSemN.
down :: QSem -> IO Bool
down qsem = do
 b <-getBuf qsem
 case b of
     (cnt,ls) -> case (cnt==0) of
         True -> do
           b1 <- newBuf
           putBuf qsem (cnt,b1:ls)
           getBuf b1
         False -> do
           putBuf qsem (cnt-1,ls)
           return True

-- | Use the quantity semaphore to limit the computation of code. This function
-- performs a down on the given q. s., executues the code and returns after a up
-- on the q.s. .
enter :: QSem -> IO a -> IO ()
enter qsem code = do
 x <- down qsem
 case x of
  True -> do
   code 
   up qsem
  False -> return ()