Control/Concurrent/QSemN.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  Control.Concurrent.QSemN
   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 -- Quantity semaphores
  12 --
  13 -----------------------------------------------------------------------------
  14
  15 module Control.Concurrent.QSemN
  16         ( QSemN,        -- abstract
  17           newQSemN,     -- :: Int   -> IO QSemN
  18           waitQSemN,    -- :: QSemN -> Int -> IO ()
  19           signalQSemN   -- :: QSemN -> Int -> IO ()
  20       ) where
  21
  22 import Prelude
  23
  24 import Control.Concurrent.MVar
  25
  26 newtype QSemN = QSemN (MVar (Int,[(Int,MVar ())]))
  27
  28 newQSemN :: Int -> IO QSemN
  29 newQSemN init = do
  30    sem <- newMVar (init,[])
  31    return (QSemN sem)
  32
  33 waitQSemN :: QSemN -> Int -> IO ()
  34 waitQSemN (QSemN sem) sz = do
  35   (avail,blocked) <- takeMVar sem   -- gain ex. access
  36   if (avail - sz) >= 0 then
  37        -- discharging 'sz' still leaves the semaphore
  38        -- in an 'unblocked' state.
  39      putMVar sem (avail-sz,[])
  40    else do
  41      block <- newEmptyMVar
  42      putMVar sem (avail, blocked++[(sz,block)])
  43      takeMVar block
  44
  45 signalQSemN :: QSemN -> Int  -> IO ()
  46 signalQSemN (QSemN sem) n = do
  47    (avail,blocked)   <- takeMVar sem
  48    (avail',blocked') <- free (avail+n) blocked
  49    putMVar sem (avail',blocked')
  50  where
  51    free avail []    = return (avail,[])
  52    free avail ((req,block):blocked)
  53      | avail >= req = do
  54         putMVar block ()
  55         free (avail-req) blocked
  56      | otherwise    = do
  57         (avail',blocked') <- free avail blocked
  58         return (avail',(req,block):blocked')