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
  10 --
  11 -- General semaphores
  12 --
  13 -----------------------------------------------------------------------------
  14
  15 module Control.Concurrent.QSem
  16         ( QSem,         -- abstract
  17           newQSem,      -- :: Int  -> IO QSem
  18           waitQSem,     -- :: QSem -> IO ()
  19           signalQSem    -- :: QSem -> IO ()
  20         ) where
  21
  22 import Prelude
  23 import Control.Concurrent.MVar
  24
  25 -- General semaphores are also implemented readily in terms of shared
  26 -- @MVar@s, only have to catch the case when the semaphore is tried
  27 -- waited on when it is empty (==0). Implement this in the same way as
  28 -- shared variables are implemented - maintaining a list of @MVar@s
  29 -- representing threads currently waiting. The counter is a shared
  30 -- variable, ensuring the mutual exclusion on its access.
  31
  32 newtype QSem = QSem (MVar (Int, [MVar ()]))
  33
  34 newQSem :: Int -> IO QSem
  35 newQSem init = do
  36    sem <- newMVar (init,[])
  37    return (QSem sem)
  38
  39 waitQSem :: QSem -> IO ()
  40 waitQSem (QSem sem) = do
  41    (avail,blocked) <- takeMVar sem  -- gain ex. access
  42    if avail > 0 then
  43      putMVar sem (avail-1,[])
  44     else do
  45      block <- newEmptyMVar
  46       {-
  47         Stuff the reader at the back of the queue,
  48         so as to preserve waiting order. A signalling
  49         process then only have to pick the MVar at the
  50         front of the blocked list.
  51
  52         The version of waitQSem given in the paper could
  53         lead to starvation.
  54       -}
  55      putMVar sem (0, blocked++[block])
  56      takeMVar block
  57
  58 signalQSem :: QSem -> IO ()
  59 signalQSem (QSem sem) = do
  60    (avail,blocked) <- takeMVar sem
  61    case blocked of
  62      [] -> putMVar sem (avail+1,[])
  63
  64      (block:blocked') -> do
  65            putMVar sem (0,blocked')
  66            putMVar block ()