Control/Concurrent/QSem.hs

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