ghc/lib/concurrent/Channel.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1995
   3 %
   4 \section[Channel]{Unbounded Channels}
   5
   6 Standard, unbounded channel abstraction.
   7
   8 \begin{code}
   9 module Channel
  10        (
  11          {- abstract type defined -}
  12         Chan,
  13
  14          {- creator -}
  15         newChan,         -- :: IO (Chan a)
  16
  17          {- operators -}
  18         putChan,         -- :: Chan a -> a -> IO ()
  19         getChan,         -- :: Chan a -> IO a
  20         dupChan,         -- :: Chan a -> IO (Chan a)
  21         unGetChan,       -- :: Chan a -> a -> IO ()
  22
  23          {- stream interface -}
  24         getChanContents, -- :: Chan a -> IO [a]
  25         putList2Chan     -- :: Chan a -> [a] -> IO ()
  26
  27        ) where
  28
  29 import Prelude
  30 import IOBase   ( IO(..) )              -- Suspicious!
  31 import ConcBase
  32 import STBase
  33 \end{code}
  34
  35 A channel is represented by two @MVar@s keeping track of the two ends
  36 of the channel contents,i.e.,  the read- and write ends. Empty @MVar@s
  37 are used to handle consumers trying to read from an empty channel.
  38
  39 \begin{code}
  40
  41 data Chan a
  42  = Chan (MVar (Stream a))
  43         (MVar (Stream a))
  44
  45 type Stream a = MVar (ChItem a)
  46
  47 data ChItem a = ChItem a (Stream a)
  48
  49
  50 \end{code}
  51
  52 See the Concurrent Haskell paper for a diagram explaining the
  53 how the different channel operations proceed.
  54
  55 @newChan@ sets up the read and write end of a channel by initialising
  56 these two @MVar@s with an empty @MVar@.
  57
  58 \begin{code}
  59
  60 newChan :: IO (Chan a)
  61 newChan
  62  = newEmptyMVar      >>= \ hole ->
  63    newMVar hole      >>= \ read ->
  64    newMVar hole      >>= \ write ->
  65    return (Chan read write)
  66
  67 \end{code}
  68
  69 To put an element on a channel, a new hole at the write end is created.
  70 What was previously the empty @MVar@ at the back of the channel is then
  71 filled in with a new stream element holding the entered value and the
  72 new hole.
  73
  74 \begin{code}
  75
  76 putChan :: Chan a -> a -> IO ()
  77 putChan (Chan read write) val
  78  = newEmptyMVar             >>= \ new_hole ->
  79    takeMVar write           >>= \ old_hole ->
  80    putMVar write new_hole   >>
  81    putMVar old_hole (ChItem val new_hole) >>
  82    return ()
  83
  84
  85 getChan :: Chan a -> IO a
  86 getChan (Chan read write)
  87  = takeMVar read          >>= \ rend ->
  88    takeMVar rend          >>= \ (ChItem val new_rend) ->
  89    putMVar read new_rend  >>
  90    return val
  91
  92
  93 dupChan :: Chan a -> IO (Chan a)
  94 dupChan (Chan read write)
  95  = newEmptyMVar           >>= \ new_read ->
  96    readMVar write         >>= \ hole ->
  97    putMVar new_read hole  >>
  98    return (Chan new_read write)
  99
 100 unGetChan :: Chan a -> a -> IO ()
 101 unGetChan (Chan read write) val
 102  = newEmptyMVar                       >>= \ new_rend ->
 103    takeMVar read                      >>= \ rend ->
 104    putMVar new_rend (ChItem val rend) >>
 105    putMVar read new_rend              >>
 106    return ()
 107
 108 \end{code}
 109
 110 Operators for interfacing with functional streams.
 111
 112 \begin{code}
 113
 114 getChanContents :: Chan a -> IO [a]
 115 getChanContents ch
 116 {- WAS:
 117   = unsafeInterleavePrimIO (
 118       getChan ch                                   `thenPrimIO` \ ~(Right x) ->
 119       unsafeInterleavePrimIO (getChanContents ch)  `thenPrimIO` \ ~(Right xs) ->
 120       returnPrimIO  (Right (x:xs)))
 121 -}
 122   = my_2_IO $ unsafeInterleavePrimIO (
 123         getChan_prim ch                                  >>= \ ~(Right x) ->
 124         unsafeInterleavePrimIO (getChanContents_prim ch) >>= \ ~(Right xs) ->
 125         returnPrimIO  (Right (x:xs)))
 126
 127 my_2_IO :: PrimIO (Either IOError a) -> IO a -- simple; primIOToIO does too much!
 128 my_2_IO m = IO m
 129
 130 getChan_prim         :: Chan a -> PrimIO (Either IOError  a)
 131 getChanContents_prim :: Chan a -> PrimIO (Either IOError [a])
 132
 133 getChan_prim ch = ST $ \ s ->
 134     case (getChan ch) of { IO (ST get) ->
 135     get s }
 136
 137 getChanContents_prim ch = ST $ \ s ->
 138     case (getChanContents ch) of { IO (ST get) ->
 139     get s }
 140
 141 -------------
 142 putList2Chan :: Chan a -> [a] -> IO ()
 143 putList2Chan ch ls = sequence (map (putChan ch) ls)
 144
 145 \end{code}