summaryrefslogtreecommitdiff
path: root/ghc/lib/concurrent/Channel.lhs
diff options
context:
space:
mode:
authorsimonpj <unknown>1996-12-19 18:36:20 +0000
committersimonpj <unknown>1996-12-19 18:36:20 +0000
commitbb521c6bba76f19474f12195b990b29eda66a4e8 (patch)
treefecb11771c7d9f25634e6bd5857c991686707b8d /ghc/lib/concurrent/Channel.lhs
parentc3e7e772db4fbc7171de7b7e98d578ab9cff167c (diff)
downloadhaskell-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.lhs144
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}