diff options
author | simonpj <unknown> | 1996-12-19 18:36:20 +0000 |
---|---|---|
committer | simonpj <unknown> | 1996-12-19 18:36:20 +0000 |
commit | bb521c6bba76f19474f12195b990b29eda66a4e8 (patch) | |
tree | fecb11771c7d9f25634e6bd5857c991686707b8d /ghc/lib/concurrent/Channel.lhs | |
parent | c3e7e772db4fbc7171de7b7e98d578ab9cff167c (diff) | |
download | haskell-bb521c6bba76f19474f12195b990b29eda66a4e8.tar.gz |
[project @ 1996-12-19 18:35:23 by simonpj]
Adding and removing files
Diffstat (limited to 'ghc/lib/concurrent/Channel.lhs')
-rw-r--r-- | ghc/lib/concurrent/Channel.lhs | 144 |
1 files changed, 144 insertions, 0 deletions
diff --git a/ghc/lib/concurrent/Channel.lhs b/ghc/lib/concurrent/Channel.lhs new file mode 100644 index 0000000000..2a947bb727 --- /dev/null +++ b/ghc/lib/concurrent/Channel.lhs @@ -0,0 +1,144 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\section[Channel]{Unbounded Channels} + +Standard, unbounded channel abstraction. + +\begin{code} +module Channel + ( + {- abstract type defined -} + Chan, + + {- creator -} + newChan, -- :: IO (Chan a) + + {- operators -} + putChan, -- :: Chan a -> a -> IO () + getChan, -- :: Chan a -> IO a + dupChan, -- :: Chan a -> IO (Chan a) + unGetChan, -- :: Chan a -> a -> IO () + + {- stream interface -} + getChanContents, -- :: Chan a -> IO [a] + putList2Chan -- :: Chan a -> [a] -> IO () + + ) where + +import IOBase ( IO(..) ) -- Suspicious! +import ConcBase +import STBase +\end{code} + +A channel is represented by two @MVar@s keeping track of the two ends +of the channel contents,i.e., the read- and write ends. Empty @MVar@s +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 +how the different channel operations proceed. + +@newChan@ sets up the read and write end of a channel by initialising +these two @MVar@s with an empty @MVar@. + +\begin{code} + +newChan :: IO (Chan a) +newChan + = newEmptyMVar >>= \ hole -> + newMVar hole >>= \ read -> + newMVar hole >>= \ write -> + return (Chan read write) + +\end{code} + +To put an element on a channel, a new hole at the write end is created. +What was previously the empty @MVar@ at the back of the channel is then +filled in with a new stream element holding the entered value and the +new hole. + +\begin{code} + +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 + + +dupChan :: Chan a -> IO (Chan a) +dupChan (Chan read write) + = newEmptyMVar >>= \ new_read -> + readMVar write >>= \ hole -> + 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 () + +\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 } + +------------- +putList2Chan :: Chan a -> [a] -> IO () +putList2Chan ch ls = sequence (map (putChan ch) ls) + +\end{code} |