分裂与并行的并行性征服算法

时间:2011-02-07 10:15:07

标签: haskell concurrency functional-programming parallel-processing

我遇到了让我的代码并行运行的问题。它是一个3D Delaunay发生器,使用分频器和分频器。征服名为DeWall的算法。

主要功能是:

deWall::[SimplexPointer] -> SetSimplexFace -> Box -> StateT DeWallSets IO ([Simplex], [Edge])
deWall p afl box = do
   ...
   ...
   get >>= recursion box1 box2 p1 p2 sigma edges
   ...
   ...

它调用可能会调用dewall函数的“递归”函数。正是在这里出现了平行机会。以下代码显示了顺序解决方案。

recursion::Box -> Box -> [SimplexPointer] -> [SimplexPointer] -> [Simplex] -> [Edge] -> DeWallSets -> StateT DeWallSets IO ([Simplex], [Edge])    
recursion box1 box2 p1 p2 sigma edges deWallSet
        | null afl1 && null afl2 = return (sigma, edges)
        | (null) afl1 = do
            (s, e) <- deWall p2 afl2 box2
            return (s ++ sigma, e ++ edges)
        | (null) afl2 = do
            (s,e) <- deWall p1 afl1 box1
            return (s ++ sigma, e ++ edges)
        | otherwise   = do
            x <- get
            liftIO $ do
                (s1, e1) <- evalStateT (deWall p1 afl1 box1) x
                (s2, e2) <- evalStateT (deWall p2 afl2 box2) x
                return (s1 ++ s2 ++ sigma, e1 ++ e2 ++ edges)

        where   afl1 = aflBox1 deWallSet
                afl2 = aflBox2 deWallSet

状态和IO monad用于管道状态并为使用MVar找到的每个四面体生成UID。我的第一次尝试是添加一个forkIO,但它不起作用。由于在合并部分期间缺乏控制而不等待两个线程完成,因此输出错误。我不知道如何让它等待它们。

            liftIO $ do
                let 
                    s1 = evalStateT (deWall p1 afl1 box1) x
                    s2 = evalStateT (deWall p2 afl2 box2) x
                    concatThread var (a1, b1) = takeMVar var >>= \(a2, b2) -> putMVar var (a1 ++ a2, b1 ++ b2)
                mv <- newMVar ([],[])
                forkIO (s1 >>= concatThread mv)
                forkIO (s2 >>= concatThread mv)
                takeMVar mv >>= \(s, e) -> return (s ++ sigma, e ++ edges)

因此,我的下一次尝试是使用更好的并行策略“par”和“pseq”,它提供了正确的结果,但根据threadScope没有并行执行。

        liftIO $ do
            let
                s1 = evalStateT (deWall p1 afl1 box1) x
                s2 = evalStateT (deWall p2 afl2 box2) x
                conc = liftM2 (\(a1, b1) (a2, b2) -> (a1 ++ a2, b1 ++ b2))
            (stotal, etotal) = s1 `par` (s2 `pseq` (s1 `conc` s2))
            return (stotal ++ sigma, etotal ++ edges)

我做错了什么?

UPDATE :不知何故,这个问题似乎与IO monads的存在有关。在没有IO monad的其他(旧)版本中,只有State monad,并行执行与'par''pseq'一起运行。 GHC -sstderr给出了SPARKS: 1160 (69 converted, 1069 pruned)

recursion::Box -> Box -> [SimplexPointer] -> [SimplexPointer] -> [Simplex] -> [Edge] -> DeWallSets -> State DeWallSets ([Simplex], [Edge])  
recursion p1 p2 sigma deWallSet
     | null afl1 && null afl2 = return sigma
     | (null) afl1 = do
         s <- deWall p2 afl2 box2
         return (s ++ sigma)
     | (null) afl2 = do
         s <- deWall p1 afl1 box1
         return (s ++ sigma)
     | otherwise   = do
                     x <- get
                     let s1 = evalState (deWall p1 afl1 box1) x
                     let s2 = evalState (deWall p2 afl2 box2) x
                     return $ s1 `par` (s2 `pseq` (s1 ++ s2 ++ sigma))
     where   afl1 = aflBox1 deWallSet
             afl2 = aflBox2 deWallSet
云有人解释一下吗?

3 个答案:

答案 0 :(得分:3)

parpseq的使用应发生在“执行路径”上,即不在本地let内。试试这个(修改你的最后一个片段)

let s1 = ...
    s2 = ...
    conc = ...
case s1 `par` (s2 `pseq` (s1 `conc` s2)) of
  (stotal, etotal) ->
     return (stotal ++ sigma, etotal ++ edges)

case强制评估其参数为弱头正常形式(WHNF),然后继续其中一个分支。 WHNF意味着在最外层构造函数可见之前对参数进行求值。字段可能仍未被评估。

要强制完整评估参数,请使用deepseq。但是要小心,因为deepseq有时可以通过做太多的工作来减慢速度。

增加严格性的更轻量级方法是使字段严格:

data Foo = Foo !Int String

现在,每当类型Foo的值被评估为WHNF时,它的第一个参数(但不是第二个参数)也是如此。

答案 1 :(得分:2)

实现这项工作的最简单方法是使用类似:

liftIO $ do
            let 
                s1 = evalStateT (deWall p1 afl1 box1) x
                s2 = evalStateT (deWall p2 afl2 box2) x
            mv1 <- newMVar ([],[])
            mv2 <- newMVar ([],[])
            forkIO (s1 >>= putMVar mv1)
            forkIO (s2 >>= putMVar mv2)
            (a1,b1) <- takeMVar mv1
            (a2,b2) <- takeMVar mv2
            return (a1++a2++sigma, b1++b2++edges)

这有效,但有一些不必要的开销。更好的解决方案是:

liftIO $ do
            let 
                s1 = evalStateT (deWall p1 afl1 box1) x
                s2 = evalStateT (deWall p2 afl2 box2) x
            mv <- newMVar ([],[])
            forkIO (s2 >>= putMVar mv2)
            (a1,b1) <- s1
            (a2,b2) <- takeMVar mv2
             return (a1++a2++sigma, b1++b2++edges)

如果结果没有被评估到你想要的地方,那么可能会这样:

liftIO $ do
        let 
            s1 = evalStateT (deWall p1 afl1 box1) x
            s2 = evalStateT (deWall p2 afl2 box2) x
        mv <- newMVar ([],[])
        forkIO (s2 >>= evaluate >>= putMVar mv2)
        (a1,b1) <- s1
        (a2,b2) <- takeMVar mv2
         return (a1++a2++sigma, b1++b2++edges)

(这些是我给#haskell的海报的答案,我觉得这里也很有用)

编辑:删除了不必要的评估。

答案 2 :(得分:1)

如果你想坚持显式线程,而不是pseq,正如你所指出的那样,你需要一些方法来等待工作线程结束。对于数量信号量来说,这是一个很好的用例。在完成要完成的工作之后,让每个工作线程在终止时向信号量发出信号,告知它已经完成了多少工作。

然后等待所有工作单元完成。

http://www.haskell.org/ghc/docs/6.8.3/html/libraries/base/Control-Concurrent-QSemN.html

编辑:一些伪代码来帮助解释这个概念

do
 let workchunks :: [(WorkChunk, Size)]
     workchunks = dividework work

  let totalsize = sum $ map snd workchunks

 sem <- newQSem 0

 let forkworkThread (workchunk, size) = do
        executeWorkChunk workchunk
        signalQSem size

 mapM_ forkWorkThread workchunks
 waitQSem totalsize

 -- now all your work is done.