Control/Concurrent/QSem.hs

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