Control/Concurrent/QSemN.hs

   1 {-# LANGUAGE CPP #-}
   2
   3 -----------------------------------------------------------------------------
   4 -- |
   5 -- Module      :  Control.Concurrent.QSemN
   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 -- Quantity semaphores in which each thread may wait for an arbitrary
  14 -- \"amount\".
  15 --
  16 -----------------------------------------------------------------------------
  17
  18 module Control.Concurrent.QSemN
  19         (  -- * General Quantity Semaphores
  20           QSemN,        -- abstract
  21           newQSemN,     -- :: Int   -> IO QSemN
  22           waitQSemN,    -- :: QSemN -> Int -> IO ()
  23           signalQSemN   -- :: QSemN -> Int -> IO ()
  24       ) where
  25
  26 import Prelude
  27
  28 import Control.Concurrent.MVar
  29 import Control.Exception ( mask_ )
  30 import Data.Typeable
  31
  32 #include "Typeable.h"
  33
  34 -- |A 'QSemN' is a quantity semaphore, in which the available
  35 -- \"quantity\" may be signalled or waited for in arbitrary amounts.
  36 newtype QSemN = QSemN (MVar (Int,[(Int,MVar ())])) deriving Eq
  37
  38 INSTANCE_TYPEABLE0(QSemN,qSemNTc,"QSemN")
  39
  40 -- |Build a new 'QSemN' with a supplied initial quantity.
  41 --  The initial quantity must be at least 0.
  42 newQSemN :: Int -> IO QSemN
  43 newQSemN initial =
  44     if initial < 0
  45     then fail "newQSemN: Initial quantity must be non-negative"
  46     else do sem <- newMVar (initial, [])
  47             return (QSemN sem)
  48
  49 -- |Wait for the specified quantity to become available
  50 waitQSemN :: QSemN -> Int -> IO ()
  51 waitQSemN (QSemN sem) sz = mask_ $ do
  52   (avail,blocked) <- takeMVar sem   -- gain ex. access
  53   let remaining = avail - sz
  54   if remaining >= 0 then
  55        -- discharging 'sz' still leaves the semaphore
  56        -- in an 'unblocked' state.
  57      putMVar sem (remaining,blocked)
  58    else do
  59      b <- newEmptyMVar
  60      putMVar sem (avail, blocked++[(sz,b)])
  61      takeMVar b
  62
  63 -- |Signal that a given quantity is now available from the 'QSemN'.
  64 signalQSemN :: QSemN -> Int  -> IO ()
  65 signalQSemN (QSemN sem) n = mask_ $ do
  66    (avail,blocked)   <- takeMVar sem
  67    (avail',blocked') <- free (avail+n) blocked
  68    avail' `seq` putMVar sem (avail',blocked')
  69  where
  70    free avail []    = return (avail,[])
  71    free avail ((req,b):blocked)
  72      | avail >= req = do
  73         putMVar b ()
  74         free (avail-req) blocked
  75      | otherwise    = do
  76         (avail',blocked') <- free avail blocked
  77         return (avail',(req,b):blocked')