ghc/lib/concurrent/Semaphore.hs

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