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