Control/Concurrent/QSemN.hs

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