ghc/lib/concurrent/Semaphore.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1995
   3 %
   4 \section[Semaphore]{Quantity semaphores}
   5
   6 General/quantity semaphores
   7
   8 \begin{code}
   9 module Semaphore
  10       (
  11        {- abstract -}
  12        QSem,
  13
  14        newQSem,         -- :: Int  -> IO QSem
  15        waitQSem,        -- :: QSem -> IO ()
  16        signalQSem,      -- :: QSem -> IO ()
  17
  18        {- abstract -}
  19        QSemN,
  20        newQSemN,        -- :: Int   -> IO QSemN
  21        waitQSemN,       -- :: QSemN -> Int -> IO ()
  22        signalQSemN      -- :: QSemN -> Int -> IO ()
  23
  24       ) where
  25
  26 import PrelConc
  27 \end{code}
  28
  29 General semaphores are also implemented readily in terms of shared
  30 @MVar@s, only have to catch the case when the semaphore is tried
  31 waited on when it is empty (==0). Implement this in the same way as
  32 shared variables are implemented - maintaining a list of @MVar@s
  33 representing threads currently waiting. The counter is a shared
  34 variable, ensuring the mutual exclusion on its access.
  35
  36 \begin{code}
  37 newtype QSem = QSem (MVar (Int, [MVar ()]))
  38
  39 newQSem :: Int -> IO QSem
  40 newQSem init = do
  41    sem <- newMVar (init,[])
  42    return (QSem sem)
  43
  44 waitQSem :: QSem -> IO ()
  45 waitQSem (QSem sem) = do
  46    (avail,blocked) <- takeMVar sem  -- gain ex. access
  47    if avail > 0 then
  48      putMVar sem (avail-1,[])
  49     else do
  50      block <- newEmptyMVar
  51       {-
  52         Stuff the reader at the back of the queue,
  53         so as to preserve waiting order. A signalling
  54         process then only have to pick the MVar at the
  55         front of the blocked list.
  56
  57         The version of waitQSem given in the paper could
  58         lead to starvation.
  59       -}
  60      putMVar sem (0, blocked++[block])
  61      takeMVar block
  62
  63 signalQSem :: QSem -> IO ()
  64 signalQSem (QSem sem) = do
  65    (avail,blocked) <- takeMVar sem
  66    case blocked of
  67      [] -> putMVar sem (avail+1,[])
  68
  69      (block:blocked') -> do
  70            putMVar sem (0,blocked')
  71            putMVar block ()
  72
  73 \end{code}
  74
  75
  76 \begin{code}
  77 newtype QSemN = QSemN (MVar (Int,[(Int,MVar ())]))
  78
  79 newQSemN :: Int -> IO QSemN
  80 newQSemN init = do
  81    sem <- newMVar (init,[])
  82    return (QSemN sem)
  83
  84 waitQSemN :: QSemN -> Int -> IO ()
  85 waitQSemN (QSemN sem) sz = do
  86   (avail,blocked) <- takeMVar sem   -- gain ex. access
  87   if (avail - sz) > 0 then
  88        -- discharging 'sz' still leaves the semaphore
  89        -- in an 'unblocked' state.
  90      putMVar sem (avail-sz,[])
  91    else do
  92      block <- newEmptyMVar
  93      putMVar sem (avail, blocked++[(sz,block)])
  94      takeMVar block
  95
  96 signalQSemN :: QSemN -> Int  -> IO ()
  97 signalQSemN (QSemN sem) n = do
  98    (avail,blocked)   <- takeMVar sem
  99    (avail',blocked') <- free (avail+n) blocked
 100    putMVar sem (avail',blocked')
 101  where
 102    free avail []    = return (avail,[])
 103    free avail ((req,block):blocked)
 104      | avail >= req = do
 105         putMVar block ()
 106         free (avail-req) blocked
 107      | otherwise    = do
 108         (avail',blocked') <- free avail blocked
 109         return (avail',(req,block):blocked')
 110
 111 \end{code}