Control/Concurrent/QSem.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  Control.Concurrent.QSem
   4 -- Copyright   :  (c) The University of Glasgow 2001
   5 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   6 --
   7 -- Maintainer  :  libraries@haskell.org
   8 -- Stability   :  experimental
   9 -- Portability :  non-portable (concurrency)
  10 --
  11 -- Simple quantity semaphores.
  12 --
  13 -----------------------------------------------------------------------------
  14
  15 module Control.Concurrent.QSem
  16         ( -- * Simple Quantity Semaphores
  17           QSem,         -- abstract
  18           newQSem,      -- :: Int  -> IO QSem
  19           waitQSem,     -- :: QSem -> IO ()
  20           signalQSem    -- :: QSem -> IO ()
  21         ) where
  22
  23 import Prelude
  24 import Control.Concurrent.MVar
  25 import Control.Exception ( mask_ )
  26 import Data.Typeable
  27
  28 #include "Typeable.h"
  29
  30 -- General semaphores are also implemented readily in terms of shared
  31 -- @MVar@s, only have to catch the case when the semaphore is tried
  32 -- waited on when it is empty (==0). Implement this in the same way as
  33 -- shared variables are implemented - maintaining a list of @MVar@s
  34 -- representing threads currently waiting. The counter is a shared
  35 -- variable, ensuring the mutual exclusion on its access.
  36
  37 -- |A 'QSem' is a simple quantity semaphore, in which the available
  38 -- \"quantity\" is always dealt with in units of one.
  39 newtype QSem = QSem (MVar (Int, [MVar ()])) deriving Eq
  40
  41 INSTANCE_TYPEABLE0(QSem,qSemTc,"QSem")
  42
  43 -- |Build a new 'QSem' with a supplied initial quantity.
  44 --  The initial quantity must be at least 0.
  45 newQSem :: Int -> IO QSem
  46 newQSem initial =
  47     if initial < 0
  48     then fail "newQSem: Initial quantity must be non-negative"
  49     else do sem <- newMVar (initial, [])
  50             return (QSem sem)
  51
  52 -- |Wait for a unit to become available
  53 waitQSem :: QSem -> IO ()
  54 waitQSem (QSem sem) = mask_ $ do
  55    (avail,blocked) <- takeMVar sem  -- gain ex. access
  56    if avail > 0 then
  57      let avail' = avail-1
  58      in avail' `seq` putMVar sem (avail',[])
  59     else do
  60      b <- newEmptyMVar
  61       {-
  62         Stuff the reader at the back of the queue,
  63         so as to preserve waiting order. A signalling
  64         process then only have to pick the MVar at the
  65         front of the blocked list.
  66
  67         The version of waitQSem given in the paper could
  68         lead to starvation.
  69       -}
  70      putMVar sem (0, blocked++[b])
  71      takeMVar b
  72
  73 -- |Signal that a unit of the 'QSem' is available
  74 signalQSem :: QSem -> IO ()
  75 signalQSem (QSem sem) = mask_ $ do
  76    (avail,blocked) <- takeMVar sem
  77    case blocked of
  78      [] -> let avail' = avail+1
  79            in avail' `seq` putMVar sem (avail',blocked)
  80
  81      (b:blocked') -> do
  82            putMVar sem (0,blocked')
  83            putMVar b ()