logo标签列表

在Haskell中使用简单的归并排序并行化没有加速效果

haskellmergesortparallel-processing
9

注意：本文已于2011-06-10进行了完全重写；感谢Peter的帮助。此外，请不要因为我没有接受一个答案而感到不满，因为这个问题似乎是比较开放的。（但是，如果你解决了它，当然会得到勾选标记）。

另一个用户发布了一个关于并行化归并排序的问题。我想写一个简单的解决方案，但不幸的是，它并没有比顺序版本快多少。

问题陈述

归并排序是一种分治算法，其中计算的叶子可以并行化。

mergesort

代码的工作方式如下：将列表转换为表示计算节点的树。然后，合并步骤返回每个节点的列表。理论上，我们应该看到一些显著的性能提升，因为我们从一个O(n log n)算法转换为具有无限处理器的O(n)算法。

当参数l（级别）小于零时，计算的前几步是并行化的。这是通过[通过变量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的一些常数因子次方。

结果

在此处获取第四版源代码[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个CPU。看起来有很多火花被修剪了。它还对内存参数敏感，256MB是最佳选择，128MB需要9秒，512MB需要8.4秒，1024MB需要12.3秒！

我正在寻找的解决方案

最后，如果有人知道一些高效工具可以应对这个问题，我会非常感激。（Eden？）我对Haskell并行性的主要兴趣是能够编写小型研究项目的辅助工具，我可以将其放在我们实验室群集的24或80个核心服务器上。由于它们不是我们小组研究的重点，所以我不想花费太多时间在并行化效率上。因此，对我来说，简单就是更好的，即使我只能得到20％的使用率。

进一步讨论

  • 我注意到Threadscope中的第二个条形图有时是绿色的（参见其主页，在那里第二个条形图似乎总是垃圾回收）。这是什么意思？
  • 有没有办法绕过垃圾回收？它似乎花费了很多时间。例如，为什么不能分叉一个子计算，将结果返回到共享内存中，然后死亡？
  • 有没有更好的方法（箭头、应用程序）来表达并行性？
只是一个小笔记：listToTree 的最后一个情况可以写作 uncurry Node $ splitAt (length xs `div` 2) xs。 - hammar
你是如何得到一个顺序版本的？看起来像是纯函数式的归并排序实现会产生两个火花，用于两个递归调用，这可能会被分配到不同的本地操作系统线程。（抱歉，我现在没有在这台电脑上安装 GHC 来尝试它。） - Lambdageek
@hammar，你仍然需要递归调用，所以 listToTree xs = uncurry Node $ listToTree *** listToTree $ splitAt (length xs \div` 2) xs`。 - gatoatigrado
1
@gatoatigrado：你当然是正确的。无论如何，好处在于splitAt只会遍历一次列表。 - hammar
1
关于您的第三次编辑，我想简单说明一下：我故意在第一个计算中使用了rpar，而在第二个计算中使用了rseq。因为当您激活这两个时，merge的计算会立即开始，然后您将有三个线程同时计算xr和yr。 - Peter Wortmann
显示剩余2条评论
2个回答
5
答案非常简单：因为您没有引入并行性。 Eval只是一种命令计算的单子，您必须手动要求以并行方式执行操作。 您可能想要的是：
do xr <- rpar $ runEval $ mergeSort' x
   yr <- rseq $ runEval $ mergeSort' y
   rseq (merge xr yr)

这将使Haskell实际上为第一次计算创建一个火花，而不是试图在现场评估它。
标准提示也有点适用：
1. 结果应该深度评估(例如使用evalTraversable rseq)。否则，您只会强制树的头部，大部分数据将返回未评估的状态。 2. 仅仅激发所有内容很可能会消耗任何收益。最好引入一个参数，在较低的递归级别停止激发。
但最糟糕的部分在最后：如你所述，你的算法非常有缺陷。你的顶层seq仅强制了列表的第一个cons-cell，这允许GHC利用惰性。它实际上永远不会构造结果列表，只是在搜索最小元素时浏览所有元素(甚至没有严格需要，但GHC只在知道最小值之后才生成单元格)。
因此，在假设某些时候需要整个列表的情况下引入并行性时，当性能实际上急剧下降时，请不要感到惊讶...
您的程序最大的问题可能是使用了列表。如果要创建更多的示例，请考虑至少使用（未打包的）数组。如果要进行严格的数字计算，可以考虑使用专门的库，例如repa。
关于“进一步讨论”：
- 颜色代表不同的GC状态，我记不清是哪一个。请尝试查看相关事件的事件日志。 - “回避”垃圾收集的方法是首先不要产生太多垃圾，例如使用更好的数据结构。 - 如果您正在寻找稳健并行化的灵感，那么有必要看看monad-par，它相对较新，但（我觉得）在其并行行为方面不那么“令人惊讶”。
使用monad-par，您的示例可能会变成这样：
  do xr <- spawn $ mergeSort' x
     yr <- spawn $ mergeSort' y
     merge <$> get xr <*> get yr

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

谢谢，抱歉我还没有注意到你的编辑，我会尽快尝试一下。 - gatoatigrado
那就是编辑的问题所在，不是吗......毕竟，你的问题也发生了重大变化。 如果你把新部分提交为另一个问题可能会更清晰。 - Peter Wortmann
"monad-par" 真是太棒了，谢谢！现在 CPU 利用率已经达到了 100%，虽然在我的机器上效率稍微低了一些，但在 24 核服务器上执行时间减少了一半。这正是我想要的。我将开始新的调查，以提高数组效率，并希望能够缩短运行时间。 - gatoatigrado
1

我在一台双核系统上使用这些变体时，遇到了与您在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]
谢谢你运行它！另外，很高兴知道Criterion，我会尽快尝试使用它！ - gatoatigrado
网页内容由stack overflow 提供, 点击上面的
可以查看英文原文，
原文链接