ghc/lib/concurrent/SampleVar.hs

   1 {-
   2 %
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1995
   4 %
   5 \section[SampleVar]{Sample variables}
   6
   7 Sample variables are slightly different from a normal @MVar@:
   8
   9 \begin{itemize}
  10 \item Reading an empty @SampleVar@ causes the reader to block.
  11     (same as @takeMVar@ on empty @MVar@)
  12 \item Reading a filled @SampleVar@ empties it and returns value.
  13     (same as @takeMVar@)
  14 \item Writing to an empty @SampleVar@ fills it with a value, and
  15 potentially, wakes up a blocked reader  (same as for @putMVar@ on empty @MVar@).
  16 \item Writing to a filled @SampleVar@ overwrites the current value.
  17  (different from @putMVar@ on full @MVar@.)
  18 \end{itemize}
  19 -}
  20
  21 module SampleVar
  22        (
  23          SampleVar,        --:: type _ =
  24
  25          newSampleVar,     --:: IO (SampleVar a)
  26          emptySampleVar,   --:: SampleVar a -> IO ()
  27          readSample,       --:: SampleVar a -> IO a
  28          writeSample       --:: SampleVar a -> a -> IO ()
  29
  30        ) where
  31
  32 import GHCbase
  33
  34 type SampleVar a
  35  = MVar (Int,           -- 1  == full
  36                         -- 0  == empty
  37                         -- <0 no of readers blocked
  38           MVar a)
  39
  40 -- Initally, a @SampleVar@ is empty/unfilled.
  41
  42 newSampleVar :: IO (SampleVar a)
  43 newSampleVar
  44  = newEmptyMVar          >>= \ val ->
  45    newMVar (0,val)
  46
  47 emptySampleVar :: SampleVar a -> IO ()
  48 emptySampleVar v
  49  = takeMVar v         >>= \ (readers,var) ->
  50    if readers >= 0 then
  51      putMVar v (0,var)
  52    else
  53      putMVar v (readers,var)
  54
  55 --
  56 -- filled => make empty and grab sample
  57 -- not filled => try to grab value, empty when read val.
  58 --
  59 readSample :: SampleVar a -> IO a
  60 readSample svar
  61  = takeMVar svar                >>= \ (readers,val) ->
  62    putMVar svar (readers-1,val) >>
  63    takeMVar val
  64
  65 --
  66 -- filled => overwrite
  67 -- not filled => fill, write val
  68 --
  69 writeSample :: SampleVar a -> a -> IO ()
  70 writeSample svar v
  71  = takeMVar svar  >>= \ (readers, val) ->
  72    case readers of
  73      1 ->
  74        swapMVar val v       >>
  75        putMVar svar (1,val)
  76      _ ->
  77        putMVar val v >>
  78        putMVar svar (min 1 (readers+1), val)