Question

注：此帖已完全改写2011-06-10;感谢彼得帮助我。另外，如果我不接受一个答案，请不要被冒犯，因为这个问题似乎相当开放。（但是，如果你解决它，你当然会得到复选标记。）

另一位用户发布了有关并行化合并排序的问题。我以为我会写一个简单的解决方案，但唉，它并不比顺序版快得多。

问题陈述

合并排序是一种分而治之的算法，计算的叶子可以并行化。

mergesort

代码的工作原理如下：列表转换为树，代表计算节点。然后，合并步骤返回每个节点的列表。从理论上讲，我们应该看到一些重要的性能增益，因为我们将从 O （n log n）算法转换为具有无限处理器的 O （n）算法。 / p>

当参数 l （level）大于零时，计算的第一步是并行化的。这是通过[via variable strat ]选择 rpar 策略完成的，这将使子计算 mergeSort'x 与 mergeSort'y 。然后，我们合并结果，并使用 rdeepseq 强制进行评估。

data Tree a = Leaf a | Node (Tree a) (Tree a) deriving (Show)

instance NFData a => NFData (Tree a) where
    rnf (Leaf v) = deepseq v ()
    rnf (Node x y) = deepseq (x, y) ()

listToTree [] = error "listToTree -- empty list"
listToTree [x] = Leaf x
listToTree xs = uncurry Node $ listToTree *** listToTree $
    splitAt (length xs `div` 2) xs

-- mergeSort' :: Ord a => Tree a -> Eval [a]
mergeSort' l (Leaf v) = return [v]
mergeSort' l (Node x y) = do
    xr <- strat $ runEval $ mergeSort' (l - 1) x
    yr <- rseq $ runEval $ mergeSort' (l - 1) y
    rdeepseq (merge xr yr)
    where
        merge [] y = y
        merge x [] = x
        merge (x:xs) (y:ys) | x < y = x : merge xs (y:ys)
                            | otherwise = y : merge (x:xs) ys
        strat | l > 0 = rpar
              | otherwise = rseq

mergeSort = runEval . mergeSort' 10

通过仅评估几个级别的计算，我们也应该具有良好的并行通信复杂度 - n 的一些常数因子顺序。

结果

在此获取第4版源代码[http://pastebin.com/DxYneAaC]，并使用以下命令运行它以检查线程使用情况，或后续命令行进行基准测试，

rm -f ParallelMergeSort; ghc -O2 -O3 -optc-O3 -optc-ffast-math -eventlog --make -rtsopts -threaded ParallelMergeSort.hs
./ParallelMergeSort +RTS -H512m -K512m -ls -N
threadscope ParallelMergeSort.eventlog

24核X5680 @ 3.33GHz的结果显示效果不大

> ./ParallelMergeSort 
initialization: 10.461204s sec.
sorting: 6.383197s sec.
> ./ParallelMergeSort +RTS -H512m -K512m -N
initialization: 27.94877s sec.
sorting: 5.228463s sec.

在我自己的机器上，一个四核的Phenom II，

> ./ParallelMergeSort 
initialization: 18.943919s sec.
sorting: 10.465077s sec.
> ./ParallelMergeSort +RTS -H512m -K512m -ls -N
initialization: 22.92075s sec.
sorting: 7.431716s sec.

检查threadscope中的结果可以很好地利用少量数据。（但遗憾的是，没有明显的加速）。但是，当我尝试在较大的列表上运行它时，如上所述，它在一半时间内使用大约2个cpus。似乎很多火花都被修剪了。它对内存参数也很敏感，其中256mb是最佳点，128mb给出9秒，512给出8.4，1024给出12.3！

我正在寻找的解决方案

最后，如果有人知道一些高功率的工具，我会很感激。（伊甸园？）。我对Haskell并行性的主要兴趣是能够为研究项目编写小型支持工具，我可以在实验室的集群中使用24或80核心服务器。由于它们不是我们小组研究的重点，我不想花太多时间在并行化效率上。所以，对我来说，更简单更好，即使我最终只能获得20％的使用率。

进一步讨论

我注意到threadscope中的第二个栏有时是绿色的（例如它的homepage，其中第二个栏似乎总是垃圾收集）。这是什么意思？
有没有办法回避垃圾收集？这似乎需要花费很多时间。例如，为什么不能分叉子计算，将结果返回到共享内存中，然后死掉？
有没有更好的方法（箭头，适用）来表达并行性？

Answer 1

答案很简单：因为你没有引入并行性。 Eval只是一个命令计算的monad，你必须要求手动并行执行的事情。你可能想要的是：

do xr <- rpar $ runEval $ mergeSort' x
   yr <- rseq $ runEval $ mergeSort' y
   rseq (merge xr yr)

这将使Haskell实际上为第一次计算创建一个火花，而不是试图在现场评估它。

标准提示也适用：

应对结果进行深入评估（例如使用evalTraversable rseq）。否则，您将只强制树的头部，并且大部分数据将仅返回未评估。
只要引发一切，很可能会吃掉任何收益。引入一个在较低递归级别停止引发的参数是个好主意。

修改：编辑问题后，以下内容实际上不再适用

但最糟糕的部分是最后一个：你所说的算法是非常有缺陷的。你的顶级seq只强制列表中的第一个cons-cell，这允许GHC使用懒惰来产生很好的效果。它永远不会实际构造结果列表，只是在搜索最小元素（甚至不是严格需要，但GHC仅在最小值已知之后生成单元格）之后浏览所有结果列表。

因此，当您开始引入并行性时假设您需要在程序中的某个位置使用整个列表时，不要惊讶于性能实际上急剧下降...

编辑2：对编辑的更多答案

您的程序最大的问题可能是它正在使用列表。如果你想制作一个不仅仅是玩具的例子，至少考虑使用（解包）数组。如果你想进行严肃的数字运算，可以考虑使用像repa这样的专业库。

关于“进一步讨论”：

颜色代表不同的GC状态，我不记得哪个。尝试查看相关事件的事件日志。
“回避”垃圾收集的方法是首先不要产生如此多的垃圾，例如：通过使用更好的数据结构。
好吧，如果你正在寻找强大的并行化的灵感，那么看看monad-par可能是值得的，这是相对较新的，但（我觉得）并行行为不那么“令人惊讶”

使用monad-par，你的例子可能会变成：

  do xr <- spawn $ mergeSort' x
     yr <- spawn $ mergeSort' y
     merge <$> get xr <*> get yr

所以这里get实际上强制你指定连接点 - 并且库会在幕后自动执行所需的deepseq。

Answer 2

我对在EDIT 3中使用这些变体的双核系统报告的内容有类似的好运。我使用较小的列表长度，因为我在一台较小的计算机上，使用ghc -O2 -rtsopts -threaded MergePar.hs编译，并使用./MergePar +RTS -H256M -N运行。这可能会提供一种更加结构化的方式来比较性能。请注意，RTS选项-qa有时可以帮助简化par变体。

import Control.Applicative
import Control.Parallel
import Control.Parallel.Strategies
import Criterion.Main
import GHC.Conc (numCapabilities)

data Tree a = Leaf a | Node (Tree a) (Tree a) deriving Show

listToTree [] = error "listToTree -- empty list"
listToTree [x] = Leaf x
listToTree xs = Node (listToTree (take half xs)) (listToTree (drop half xs))
  where half = length xs `div` 2

-- Merge two ordered lists
merge :: Ord a => [a] -> [a] -> [a]
merge [] y = y
merge x [] = x
merge (x:xs) (y:ys) | x < y = x : merge xs (y:ys)
                    | otherwise = y : merge (x:xs) ys

-- Simple merge sort
mergeSort' :: Ord a => Tree a -> [a]
mergeSort' (Leaf v) = [v]
mergeSort' (Node x y) = merge (mergeSort' x) (mergeSort' y)

mergeSort :: Ord a => [a] -> [a]
mergeSort = mergeSort' . listToTree

-- Merge sort with 'par' annotations on every recursive call
mergeSortP' :: Ord a => Tree a -> [a]
mergeSortP' (Leaf v) = [v]
mergeSortP' (Node x y) = let xr = mergeSortP' x
                             yr = mergeSortP' y
                         in xr `par` yr `pseq` merge xr yr

mergeSortP :: Ord a => [a] -> [a]
mergeSortP = mergeSortP' . listToTree

-- Merge sort with 'rpar' annotations on every recursive call
mergeSortR' :: Ord a => Tree a -> [a]
mergeSortR' (Leaf v) = [v]
mergeSortR' (Node x y) = 
  runEval $ merge <$> rpar (mergeSortR' x) <*> rpar (mergeSortR' y)

mergeSortR :: Ord a => [a] -> [a]
mergeSortR = mergeSortR' . listToTree

-- Parallel merge sort that stops looking for parallelism at a certain
-- depth
smartMerge' :: Ord a => Int -> Tree a -> [a]
smartMerge' _ (Leaf v) = [v]
smartMerge' n t@(Node x y)
  | n <= 1 = mergeSort' t
  | otherwise = let xr = smartMerge' (n-1) x
                    yr = smartMerge' (n-2) y
                in xr `par` yr `pseq` merge xr yr

smartMerge :: Ord a => [a] -> [a]
smartMerge = smartMerge' numCapabilities . listToTree

main = defaultMain $ [ bench "original" $ nf mergeSort lst
                     , bench "par" $ nf mergeSortP lst
                     , bench "rpar" $ nf mergeSortR lst
                     , bench "smart" $ nf smartMerge lst ]
  where lst = [100000,99999..0] :: [Int]

在Haskell中没有使用天真合并排序并行化的加速

问题陈述

结果

我正在寻找的解决方案

进一步讨论

2 个答案: