[project @ 1999-01-25 10:26:18 by sof]

[ghc-hetmet.git] / ghc / lib / concurrent / Channel.lhs

diff --git a/ghc/lib/concurrent/Channel.lhs b/ghc/lib/concurrent/Channel.lhs
index 2a947bb..fca29df 100644 (file)
--- a/ghc/lib/concurrent/Channel.lhs
+++ b/ghc/lib/concurrent/Channel.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1995-97
 %
 \section[Channel]{Unbounded Channels}
 
@@ -15,20 +15,23 @@ module Channel
        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 IOBase  ( IO(..) )              -- Suspicious!
-import ConcBase
-import STBase
+import Prelude
+import PrelConc
+import PrelST
+import PrelIOBase ( unsafeInterleaveIO )
 \end{code}
 
 A channel is represented by two @MVar@s keeping track of the two ends
@@ -36,7 +39,6 @@ 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))
@@ -44,8 +46,6 @@ data Chan 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
@@ -55,14 +55,12 @@ how the different channel operations proceed.
 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.
@@ -71,74 +69,58 @@ filled in with a new stream element holding the entered value and the
 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}