[project @ 1999-04-28 08:30:58 by simonm]

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

diff --git a/ghc/lib/concurrent/Merge.lhs b/ghc/lib/concurrent/Merge.lhs
index 3f79413..395bd2f 100644 (file)
--- a/ghc/lib/concurrent/Merge.lhs
+++ b/ghc/lib/concurrent/Merge.lhs
@@ -6,88 +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 ConcBase
-import UnsafeST  ( unsafeInterleavePrimIO )
-import IOBase
-
-max_buff_size = 1
-
-mergeIO :: [a] -> [a] -> IO [a]
-nmergeIO :: [[a]] -> IO [a]
-
-#ifndef __CONCURRENT_HASKELL__
-
-mergeIO _ _  = return []
-nmergeIO _   = return []
-
-#else
-
-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 ->
-               unsafeInterleavePrimIO ( ioToPrimIO $
-                       takeMVar next_node  >>= \ x ->
-                       signalQSem e        >>
-                       return x)           `thenIO_Prim` \ 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 = accumulate (map f xs)
-
-#endif {- __CONCURRENT_HASKELL__ -}
+import Concurrent
 \end{code}