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