[project @ 1999-05-11 17:05:43 by keithw]

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

diff --git a/ghc/lib/concurrent/Merge.lhs b/ghc/lib/concurrent/Merge.lhs
index 5414c97..395bd2f 100644 (file)
--- a/ghc/lib/concurrent/Merge.lhs
+++ b/ghc/lib/concurrent/Merge.lhs
@@ -6,79 +6,14 @@
 Avoiding the loss of ref. transparency by attaching the merge to the
 IO monad.
 
+(The ops. are now defined in Concurrent to avoid module loop trouble).
+
 \begin{code}
 module Merge
-
        (
-        mergeIO,       -- :: [a]   -> [a] -> IO [a]
-        nmergeIO       -- :: [[a]] -> IO [a]
+         mergeIO
+       , nmergeIO
        ) where
 
-import Semaphore
-import PrelConc
-import PrelIOBase
-
-max_buff_size :: Int
-max_buff_size = 1
-
-mergeIO :: [a] -> [a] -> IO [a]
-nmergeIO :: [[a]] -> IO [a]
-
-mergeIO ls rs
- = newEmptyMVar                       >>= \ tail_node ->
-   newMVar tail_node          >>= \ tail_list ->
-   newQSem max_buff_size       >>= \ e ->
-   newMVar 2                   >>= \ branches_running ->
-   let
-    buff = (tail_list,e)
-   in
-    forkIO (suckIO branches_running buff ls) >>
-    forkIO (suckIO branches_running buff rs) >>
-    takeMVar tail_node >>= \ val ->
-    signalQSem e       >>
-    return val
-
-type Buffer a 
- = (MVar (MVar [a]), QSem)
-
-suckIO :: MVar Int -> Buffer a -> [a] -> IO ()
-
-suckIO branches_running buff@(tail_list,e) vs
- = case vs of
-       [] -> takeMVar branches_running >>= \ val ->
-             if val == 1 then
-                takeMVar tail_list     >>= \ node ->
-                putMVar node []        >>
-                putMVar tail_list node
-             else      
-                putMVar branches_running (val-1)
-       (x:xs) ->
-               waitQSem e                       >>
-               takeMVar tail_list               >>= \ node ->
-               newEmptyMVar                     >>= \ next_node ->
-               unsafeInterleaveIO (
-                       takeMVar next_node  >>= \ x ->
-                       signalQSem e        >>
-                       return x)                >>= \ next_node_val ->
-               putMVar node (x:next_node_val)   >>
-               putMVar tail_list next_node      >>
-               suckIO branches_running buff xs
-
-nmergeIO lss
- = let
-    len = length lss
-   in
-    newEmptyMVar         >>= \ tail_node ->
-    newMVar tail_node    >>= \ tail_list ->
-    newQSem max_buff_size >>= \ e ->
-    newMVar len                  >>= \ branches_running ->
-    let
-     buff = (tail_list,e)
-    in
-    mapIO (\ x -> forkIO (suckIO branches_running buff x)) lss >>
-    takeMVar tail_node >>= \ val ->
-    signalQSem e       >>
-    return val
-  where
-    mapIO f xs = sequence (map f xs)
+import Concurrent
 \end{code}