%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1995-97
%
\section[Channel]{Unbounded Channels}
newChan, -- :: IO (Chan a)
{- operators -}
- putChan, -- :: Chan a -> a -> IO ()
- getChan, -- :: Chan a -> IO a
+ writeChan, -- :: Chan a -> a -> IO ()
+ readChan, -- :: Chan a -> IO a
dupChan, -- :: Chan a -> IO (Chan a)
unGetChan, -- :: Chan a -> a -> IO ()
+ isEmptyChan, -- :: Chan a -> IO Bool
+
{- stream interface -}
getChanContents, -- :: Chan a -> IO [a]
- putList2Chan -- :: Chan a -> [a] -> IO ()
+ writeList2Chan -- :: Chan a -> [a] -> IO ()
) where
import Prelude
-import IOBase ( IO(..) ) -- Suspicious!
-import ConcBase
-import STBase
+import PrelConc
+import PrelST
+import PrelIOBase ( unsafeInterleaveIO )
\end{code}
A channel is represented by two @MVar@s keeping track of the two ends
are used to handle consumers trying to read from an empty channel.
\begin{code}
-
data Chan a
= Chan (MVar (Stream a))
(MVar (Stream a))
type Stream a = MVar (ChItem a)
data ChItem a = ChItem a (Stream a)
-
-
\end{code}
See the Concurrent Haskell paper for a diagram explaining the
these two @MVar@s with an empty @MVar@.
\begin{code}
-
newChan :: IO (Chan a)
-newChan
- = newEmptyMVar >>= \ hole ->
- newMVar hole >>= \ read ->
- newMVar hole >>= \ write ->
+newChan = do
+ hole <- newEmptyMVar
+ read <- newMVar hole
+ write <- newMVar hole
return (Chan read write)
-
\end{code}
To put an element on a channel, a new hole at the write end is created.
new hole.
\begin{code}
+writeChan :: Chan a -> a -> IO ()
+writeChan (Chan read write) val = do
+ new_hole <- newEmptyMVar
+ old_hole <- takeMVar write
+ putMVar write new_hole
+ putMVar old_hole (ChItem val new_hole)
-putChan :: Chan a -> a -> IO ()
-putChan (Chan read write) val
- = newEmptyMVar >>= \ new_hole ->
- takeMVar write >>= \ old_hole ->
- putMVar write new_hole >>
- putMVar old_hole (ChItem val new_hole) >>
- return ()
-
-
-getChan :: Chan a -> IO a
-getChan (Chan read write)
- = takeMVar read >>= \ rend ->
- takeMVar rend >>= \ (ChItem val new_rend) ->
- putMVar read new_rend >>
- return val
+readChan :: Chan a -> IO a
+readChan (Chan read write) = do
+ read_end <- takeMVar read
+ (ChItem val new_read_end) <- takeMVar read_end
+ putMVar read new_read_end
+ return val
dupChan :: Chan a -> IO (Chan a)
-dupChan (Chan read write)
- = newEmptyMVar >>= \ new_read ->
- readMVar write >>= \ hole ->
- putMVar new_read hole >>
+dupChan (Chan read write) = do
+ new_read <- newEmptyMVar
+ hole <- readMVar write
+ putMVar new_read hole
return (Chan new_read write)
unGetChan :: Chan a -> a -> IO ()
-unGetChan (Chan read write) val
- = newEmptyMVar >>= \ new_rend ->
- takeMVar read >>= \ rend ->
- putMVar new_rend (ChItem val rend) >>
- putMVar read new_rend >>
- return ()
+unGetChan (Chan read write) val = do
+ new_read_end <- newEmptyMVar
+ read_end <- takeMVar read
+ putMVar new_read_end (ChItem val read_end)
+ putMVar read new_read_end
+
+isEmptyChan :: Chan a -> IO Bool
+isEmptyChan (Chan read write) = do
+ r <- takeMVar read
+ w <- readMVar write
+ let eq = r == w
+ eq `seq` putMVar read r
+ return eq
\end{code}
Operators for interfacing with functional streams.
\begin{code}
-
getChanContents :: Chan a -> IO [a]
getChanContents ch
-{- WAS:
- = unsafeInterleavePrimIO (
- getChan ch `thenPrimIO` \ ~(Right x) ->
- unsafeInterleavePrimIO (getChanContents ch) `thenPrimIO` \ ~(Right xs) ->
- returnPrimIO (Right (x:xs)))
--}
- = my_2_IO $ unsafeInterleavePrimIO (
- getChan_prim ch >>= \ ~(Right x) ->
- unsafeInterleavePrimIO (getChanContents_prim ch) >>= \ ~(Right xs) ->
- returnPrimIO (Right (x:xs)))
-
-my_2_IO :: PrimIO (Either IOError a) -> IO a -- simple; primIOToIO does too much!
-my_2_IO m = IO m
-
-getChan_prim :: Chan a -> PrimIO (Either IOError a)
-getChanContents_prim :: Chan a -> PrimIO (Either IOError [a])
-
-getChan_prim ch = ST $ \ s ->
- case (getChan ch) of { IO (ST get) ->
- get s }
-
-getChanContents_prim ch = ST $ \ s ->
- case (getChanContents ch) of { IO (ST get) ->
- get s }
+ = unsafeInterleaveIO (do
+ x <- readChan ch
+ xs <- getChanContents ch
+ return (x:xs)
+ )
-------------
-putList2Chan :: Chan a -> [a] -> IO ()
-putList2Chan ch ls = sequence (map (putChan ch) ls)
+writeList2Chan :: Chan a -> [a] -> IO ()
+writeList2Chan ch ls = sequence_ (map (writeChan ch) ls)
\end{code}