+{-# LANGUAGE CPP #-}
+#ifdef __GLASGOW_HASKELL__
+{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
+#endif
+
-----------------------------------------------------------------------------
---
+-- |
-- Module : Control.Concurrent.QSem
-- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/core/LICENSE)
+-- License : BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer : libraries@haskell.org
-- Stability : experimental
--- Portability : non-portable
---
--- $Id: QSem.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+-- Portability : non-portable (concurrency)
--
--- General semaphores
+-- Simple quantity semaphores.
--
-----------------------------------------------------------------------------
module Control.Concurrent.QSem
- ( QSem, -- abstract
- newQSem, -- :: Int -> IO QSem
- waitQSem, -- :: QSem -> IO ()
- signalQSem -- :: QSem -> IO ()
- ) where
+ ( -- * 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
-- representing threads currently waiting. The counter is a shared
-- variable, ensuring the mutual exclusion on its access.
-newtype QSem = QSem (MVar (Int, [MVar ()]))
+-- |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 ()])) deriving Eq
+
+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 init = do
- sem <- newMVar (init,[])
- return (QSem sem)
+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) = do
+waitQSem (QSem sem) = mask_ $ do
(avail,blocked) <- takeMVar sem -- gain ex. access
if avail > 0 then
- putMVar sem (avail-1,[])
+ let avail' = avail-1
+ in avail' `seq` putMVar sem (avail',[])
else do
- block <- newEmptyMVar
+ 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.
+ 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.
+ The version of waitQSem given in the paper could
+ lead to starvation.
-}
- putMVar sem (0, blocked++[block])
- takeMVar block
+ putMVar sem (0, blocked++[b])
+ takeMVar b
+-- |Signal that a unit of the 'QSem' is available
signalQSem :: QSem -> IO ()
-signalQSem (QSem sem) = do
+signalQSem (QSem sem) = mask_ $ do
(avail,blocked) <- takeMVar sem
case blocked of
- [] -> putMVar sem (avail+1,[])
+ [] -> let avail' = avail+1
+ in avail' `seq` putMVar sem (avail',blocked)
- (block:blocked') -> do
- putMVar sem (0,blocked')
- putMVar block ()
+ (b:blocked') -> do
+ putMVar sem (0,blocked')
+ putMVar b ()