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