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 ConcBase
  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 data QSem = QSem (MVar (Int, [MVar ()]))
  38
  39 newQSem :: Int -> IO QSem
  40 newQSem init
  41  = newMVar (init,[])      >>= \ sem ->
  42    return (QSem sem)
  43
  44 waitQSem :: QSem -> IO ()
  45 waitQSem (QSem sem)
  46  = takeMVar sem         >>= \ (avail,blocked) ->    -- gain ex. access
  47    if avail > 0 then
  48      putMVar sem (avail-1,[]) >>
  49      return ()
  50    else
  51      newEmptyMVar       >>= \ block ->
  52      {-
  53         Stuff the reader at the back of the queue,
  54         so as to preserve waiting order. A signalling
  55         process then only have to pick the MVar at the
  56         front of the blocked list.
  57
  58         The version of waitQSem given in the paper could
  59         lead to starvation.
  60      -}
  61      putMVar sem (0, blocked++[block]) >>
  62      takeMVar block                    >>= \ v ->
  63      return v
  64
  65 signalQSem :: QSem -> IO ()
  66 signalQSem (QSem sem)
  67  = takeMVar sem   >>= \ (avail,blocked) ->
  68    case blocked of
  69      [] -> putMVar sem (avail+1,[]) >>
  70            return ()
  71      (block:blocked') ->
  72            putMVar sem (0,blocked') >>
  73            putMVar block ()         >>
  74            return ()
  75
  76 data QSemN
  77  = QSemN (MVar (Int,[(Int,MVar ())]))
  78
  79 newQSemN :: Int -> IO QSemN
  80 newQSemN init
  81  = newMVar (init,[])      >>= \ sem ->
  82    return (QSemN sem)
  83
  84 waitQSemN :: QSemN -> Int -> IO ()
  85 waitQSemN (QSemN sem) sz
  86  = takeMVar sem >>= \ (avail,blocked) ->    -- gain ex. access
  87    if avail > 0 then
  88      putMVar sem (avail-1,[]) >>
  89      return ()
  90    else
  91      newEmptyMVar                           >>= \ block ->
  92      putMVar sem (0, blocked++[(sz,block)]) >>
  93      takeMVar block                         >>
  94      return ()
  95
  96
  97 signalQSemN :: QSemN -> Int  -> IO ()
  98 signalQSemN (QSemN sem) n
  99  = takeMVar sem                  >>= \ (avail,blocked) ->
 100    free (avail+n) blocked        >>= \ (avail',blocked') ->
 101    putMVar sem (avail',blocked') >>
 102    return ()
 103    where
 104     free avail [] = return (avail,[])
 105     free avail ((req,block):blocked) =
 106      if avail > req then
 107         putMVar block () >>
 108         free (avail-req) blocked
 109      else
 110         free avail blocked >>= \ (avail',blocked') ->
 111         return (avail',(req,block):blocked')
 112 \end{code}