Changeset 14478 for src/Pugs/Prim/List.hs

Timestamp:

10/22/06 01:38:03 (2 years ago)

Author:

audreyt

svk:copy_cache_prev:

21625

Message:

* Pugs.Prim.List: MVar-based synchronization is much better

also for hyper operators than Chan-based ones, so implement
them here too.

Files:

• src/Pugs/Prim/List.hs (modified) (2 diffs)

src/Pugs/Prim/List.hs

@@ -393 +393 @@
         env <- ask
         liftIO $ do
-            chan    <- newChan
-            forM ([(0::Int)..] `zip` xs) $ \(n, x) -> forkIO $ do
-                rv  <- runEvalIO env $ doHyper x
-                writeChan chan (n, rv)
-            fmap (map snd . sort) (replicateM (length xs) (readChan chan))
+            mvs <- forM xs $ \x -> do
+                mv  <- newEmptyMVar
+                forkIO $ do
+                    val <- runEvalIO env (doHyper x)
+                    putMVar mv val
+                return mv
+            mapM takeMVar mvs
 
 op1HyperPostfix :: VCode -> Val -> Eval Val
@@ -435 +437 @@
         env <- ask
         liftIO $ do
-            chan    <- newChan
-            len     <- doHyperLists env chan 0 xs ys
-            fmap (map snd . sort) (replicateM len (readChan chan))
-    doHyperLists :: Env -> Chan (Int, Val) -> Int -> [Val] -> [Val] -> IO Int
-    doHyperLists _ _    n [] [] = return n
-    doHyperLists _ chan n xs [] = do
-        forM ([n..] `zip` xs) (writeChan chan)
-        return (n + length xs)
-    doHyperLists _ chan n [] ys = do
-        forM ([n..] `zip` ys) (writeChan chan)
-        return (n + length ys)
-    doHyperLists env chan n (x:xs) (y:ys) = do
+            mvs <- doHyperLists env xs ys
+            mapM takeMVar mvs
+    doHyperLists _ [] [] = return []
+    doHyperLists _ xs [] = mapM newMVar xs
+    doHyperLists _ [] ys = mapM newMVar ys
+    doHyperLists env (x:xs) (y:ys) = do
+        mv  <- newEmptyMVar
         forkIO $ do
-            rv  <- runEvalIO env $ doHyper x y
-            writeChan chan (n, rv)
-        doHyperLists env chan (n+1) xs ys
+            val <- runEvalIO env $ doHyper x y
+            putMVar mv val
+        mvs <- doHyperLists env xs ys
+        return (mv:mvs)