在Haskell中,使用par能否加速快速排序?

13

我有一个看似微不足道的并行快速排序实现,代码如下:

import System.Random
import Control.Parallel
import Data.List

quicksort :: Ord a => [a] -> [a]
quicksort xs = pQuicksort 16 xs -- 16 is the number of sparks used to sort

-- pQuicksort, parallelQuicksort  
-- As long as n > 0 evaluates the lower and upper part of the list in parallel,
-- when we have recursed deep enough, n==0, this turns into a serial quicksort.
pQuicksort :: Ord a => Int -> [a] -> [a]
pQuicksort _ [] = []
pQuicksort 0 (x:xs) =
  let (lower, upper) = partition (< x) xs
  in pQuicksort 0 lower ++ [x] ++ pQuicksort 0 upper
pQuicksort n (x:xs) =
  let (lower, upper) = partition (< x) xs
      l = pQuicksort (n `div` 2) lower
      u = [x] ++ pQuicksort (n `div` 2) upper
  in (par u l) ++ u

main :: IO ()
main = do
  gen <- getStdGen
  let randints = (take 5000000) $ randoms gen :: [Int]
  putStrLn . show . sum $ (quicksort randints)

我使用以下编译器

ghc --make -threaded -O2 quicksort.hs

并且跑步

./quicksort +RTS -N16 -RTS

无论我做什么,都不能使这个程序在多个CPU上运行得比在单个CPU上运行的简单顺序实现快。

  1. 能否解释一下为什么这个程序在多个CPU上运行得比单个CPU上慢那么多?
  2. 是否有可能通过某些技巧使其至少与CPU数量呈次线性缩放?

编辑:@tempestadept暗示快速排序本身就是问题所在。为了验证这一点,我按照上面的示例实现了一个简单的归并排序。它具有相同的行为,添加的处理能力越多,性能表现越差。

import System.Random
import Control.Parallel

splitList :: [a] -> ([a], [a])
splitList = helper True [] []
  where helper _ left right [] = (left, right)
        helper True  left right (x:xs) = helper False (x:left) right xs
        helper False left right (x:xs) = helper True  left (x:right) xs

merge :: (Ord a) => [a] -> [a] -> [a]
merge xs [] = xs
merge [] ys = ys
merge (x:xs) (y:ys) = case x<y of
  True  -> x : merge xs (y:ys)
  False -> y : merge (x:xs) ys

mergeSort :: (Ord a) => [a] -> [a]
mergeSort xs = pMergeSort 16 xs -- we use 16 sparks

-- pMergeSort, parallel merge sort. Takes an extra argument
-- telling how many sparks to create. In our simple test it is
-- set to 16
pMergeSort :: (Ord a) => Int -> [a] -> [a]
pMergeSort _ [] = []
pMergeSort _ [a] = [a]
pMergeSort 0 xs =
  let (left, right) = splitList xs
  in  merge (pMergeSort 0 left) (pMergeSort 0 right)
pMergeSort n xs =
  let (left, right) = splitList xs
      l = pMergeSort (n `div` 2) left
      r = pMergeSort (n `div` 2) right
  in  (r `par` l) `pseq` (merge l r)

ris :: Int -> IO [Int]
ris n = do
  gen <- getStdGen
  return . (take n) $ randoms gen

main = do
  r <- ris 100000
  putStrLn . show . sum $ mergeSort r

1
请注意,这实际上是快速排序的一种实现:https://dev59.com/j2sz5IYBdhLWcg3wsaHN - ErikR
1
至少我无法通过使用pseq来使其表现更好,即使使用sum清除了任何可能的thunks。也许涉及到完全不同的问题。 ——由于我已经删除了我的答案,所以在这里再次作为评论:1.将该函数命名为quicksort可能会引起混淆,因为您不会期望这样的函数接受额外的并行性参数;2.对于顶级函数,始终使用类型签名,尤其是当它们的工作方式略有不同于名称所示时;3.如果可能,请使用库函数,例如partition。 ——顺便说一句,这是一个很好的问题。 - leftaroundabout
4
我没有足够的时间发布完整的答案,但我猜有两个可能的问题:(1) 你应该使用l `par` u `pseq`(u ++ l)。(2) 虽然你在并行运行子计算,但它们直到需要时才真正被评估。因此,你应该强制每个子列表到 NF(或至少其完整结构),类似于forceList l `par` forceList u `pseq` (u ++ l),其中forceList是(你自己的)强制评估列表的函数。另外,为了进行适当的基准测试,我建议使用criterion - Petr
1
实际上,在我的机器上,只要我不使用比核心更多的线程,归并排序实现就几乎以恒定的速度运行。我开始认为我们主要的问题与内存/缓存有关;在这方面,列表并不是很好。如果所有核心大部分时间都在等待获取内存页,那么并行化带来的收益就很小。在快速排序中,这显然比归并排序更为关键。 - leftaroundabout
我正在一个24核集群上运行这些示例。如果使用16个核心而不是一个核心,它不应该在缓存方面表现更好吗?至少以这种方式有更多的缓存可用。减速是否来自合并阶段,当列表必须从两个核心移动到一个核心时? - lysgaard
显示剩余7条评论
5个回答

5

已经提到了几个问题:

  • 使用列表不会给出您所寻找的性能。即使使用向量的此示例实现比使用列表快50倍,因为它在原地交换元素。因此,我的答案将包括使用数组库massiv而不是列表的实现。
  • 我倾向于发现Haskell调度程序对于CPU绑定任务远非完美,因此,正如@Edward Kmett在他的回答中指出的那样,我们需要一个工作窃取调度程序,我方便地为上述提到的库实现了这一点:scheduler
-- A helper function that partitions a region of a mutable array.
unstablePartitionRegionM ::
     forall r e m. (Mutable r Ix1 e, PrimMonad m)
  => MArray (PrimState m) r Ix1 e
  -> (e -> Bool)
  -> Ix1 -- ^ Start index of the region
  -> Ix1 -- ^ End index of the region
  -> m Ix1
unstablePartitionRegionM marr f start end = fromLeft start (end + 1)
  where
    fromLeft i j
      | i == j = pure i
      | otherwise = do
        x <- A.unsafeRead marr i
        if f x
          then fromLeft (i + 1) j
          else fromRight i (j - 1)
    fromRight i j
      | i == j = pure i
      | otherwise = do
        x <- A.unsafeRead marr j
        if f x
          then do
            A.unsafeWrite marr j =<< A.unsafeRead marr i
            A.unsafeWrite marr i x
            fromLeft (i + 1) j
          else fromRight i (j - 1)
{-# INLINE unstablePartitionRegionM #-}

这是原地快速排序算法。
quicksortMArray ::
     (Ord e, Mutable r Ix1 e, PrimMonad m)
  => Int
  -> (m () -> m ())
  -> A.MArray (PrimState m) r Ix1 e
  -> m ()
quicksortMArray numWorkers schedule marr =
  schedule $ qsort numWorkers 0 (unSz (msize marr) - 1)
  where
    qsort n !lo !hi =
      when (lo < hi) $ do
        p <- A.unsafeRead marr hi
        l <- unstablePartitionRegionM marr (< p) lo hi
        A.unsafeWrite marr hi =<< A.unsafeRead marr l
        A.unsafeWrite marr l p
        if n > 0
          then do
            let !n' = n - 1
            schedule $ qsort n' lo (l - 1)
            schedule $ qsort n' (l + 1) hi
          else do
            qsort n lo (l - 1)
            qsort n (l + 1) hi
{-# INLINE quicksortMArray #-}

现在,如果我们看一下参数numWorkersschedule,它们非常不透明。如果我们为第一个参数提供1,并为第二个参数提供id,那么我们将只获得一个顺序快速排序,但是如果我们有一个可用于将每个任务并行计算的函数,那么我们将得到一个快速排序的并行实现。幸运的是,massiv已经为我们提供了这个功能:withMArray
withMArray ::
     (Mutable r ix e, MonadUnliftIO m)
  => Array r ix e
  -> (Int -> (m () -> m ()) -> MArray RealWorld r ix e -> m a)
  -> m (Array r ix e)

这是一个纯净的版本,它将复制一个数组,然后使用数组本身指定的计算策略对其进行原地排序:计算策略
quicksortArray :: (Mutable r Ix1 e, Ord e) => Array r Ix1 e -> Array r Ix1 e
quicksortArray arr = unsafePerformIO $ withMArray arr quicksortMArray
{-# INLINE quicksortArray #-}

这里是最佳部分,基准测试的顺序如下:
  • 使用vector-algorithms中的 Intro sort
  • 使用向量的原地快速排序,参考这个答案
  • 使用 C 实现的快速排序,从这个问题获取
  • 使用 massiv 的顺序快速排序
  • 在一台只有第三代 i7 四核心处理器和超线程技术的电脑上并行运行与上述相同的算法
benchmarking QuickSort/Vector Algorithms
time                 101.3 ms   (93.75 ms .. 107.8 ms)
                     0.991 R²   (0.974 R² .. 1.000 R²)
mean                 97.13 ms   (95.17 ms .. 100.2 ms)
std dev              4.127 ms   (2.465 ms .. 5.663 ms)

benchmarking QuickSort/Vector  
time                 89.51 ms   (87.69 ms .. 91.92 ms)
                     0.999 R²   (0.997 R² .. 1.000 R²)
mean                 92.67 ms   (91.54 ms .. 94.50 ms)
std dev              2.438 ms   (1.468 ms .. 3.493 ms)

benchmarking QuickSort/C       
time                 88.14 ms   (86.71 ms .. 89.41 ms)
                     1.000 R²   (0.999 R² .. 1.000 R²)
mean                 90.11 ms   (89.17 ms .. 93.35 ms)
std dev              2.744 ms   (387.1 μs .. 4.686 ms)

benchmarking QuickSort/Array   
time                 76.07 ms   (75.77 ms .. 76.41 ms)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 76.08 ms   (75.75 ms .. 76.28 ms)
std dev              453.7 μs   (247.8 μs .. 699.6 μs)

benchmarking QuickSort/Array Par
time                 25.25 ms   (24.84 ms .. 25.61 ms)
                     0.999 R²   (0.997 R² .. 1.000 R²)
mean                 25.13 ms   (24.80 ms .. 25.75 ms)
std dev              991.6 μs   (468.5 μs .. 1.782 ms)

基准测试是对1,000,000个随机的Int64进行排序。如果您想查看完整代码,可以在这里找到:https://github.com/lehins/haskell-quicksort 总之,我们在四核处理器和8个并发能力上获得了3倍的速度提升,这听起来对我来说相当不错。感谢这个问题,现在我可以将排序函数添加到massiv中 ;)
注意,接受的答案使用列表而不是更适合此问题的可变数组等更合适的数据结构,在相同输入上慢了100倍。
benchmarking List/random/List Par
time                 2.712 s    (2.566 s .. 3.050 s)
                     0.998 R²   (0.996 R² .. 1.000 R²)
mean                 2.696 s    (2.638 s .. 2.745 s)
std dev              59.09 ms   (40.83 ms .. 72.04 ms)
variance introduced by outliers: 19% (moderately inflated)

1
这确实是一些令人印象深刻的表现!可惜它是那种超级不自然、不安全、可变的代码,已经从Data.Vector.Unboxed中挤出了最大的性能。scheduler也可以用于更高级别的代码来完成这个任务吗?(我的奖励的目的不是为了看到一个超级优化的解决方案,而是一个_简单_的解决方案,它实际上证明了Haskell适合编写漂亮的、纯函数式的并行代码,不一定在绝对意义上提供最佳性能,但提供良好的性能和易于扩展。) - leftaroundabout
1
是的,您可以在数组上下文之外使用“scheduler”库。但请记住,由于它使用“forkIO”进行调度,因此必须在“IO”中运行,因此纯函数并行化代码将不可能实现。另外,快速排序必须在原地完成,因此如果没有变异和至少“ST”单子,这个问题无法得到令人满意的答复 ;) - lehins
分区就地进行是否真的是最好的选择?我认为通过将数组分成段,让每个线程将一个段分区到自己的桶中,然后并行合并桶,可以获得更多的并行性。 - dfeuer

4

我不确定它在惯用的快速排序中能够很好地工作,但正如Roman在激发命令式中所展示的那样,它可以工作(在某种程度上比较弱)。

然而,他从未获得良好的加速。这确实需要一个真正的工作窃取双端队列来进行适当的优化,而不像Spark队列一样溢出。


我在Spark队列中遇到了瓶颈吗?我只使用了16个并行操作将问题分解为我的16个能力。之后算法是顺序执行的。也许我没有理解关于par、pseq和sparks本质的一些基本知识? - lysgaard

3

par仅对第一个参数进行弱头规范化的评估。也就是说:如果第一个参数的类型是Maybe Int,那么par将检查结果是否为NothingJust something并停止。它不会评估something。同样地,对于列表,它只评估足够的内容以检查列表是否为[]something:something_else。要并行评估整个列表:您不直接将列表传递给par,而是创建一个表达式,该表达式以某种方式依赖于列表,以便在将其传递给par时需要整个列表。例如:

evalList :: [a] -> ()
evalList [] = ()
evalList (a:r) = a `pseq` evalList r

pMergeSort :: (Ord a) => Int -> [a] -> [a]
pMergeSort _ [] = []
pMergeSort _ [a] = [a]
pMergeSort 0 xs =
  let (left, right) = splitList xs
  in  merge (pMergeSort 0 left) (pMergeSort 0 right)
pMergeSort n xs =
  let (left, right) = splitList xs
      l = pMergeSort (n `div` 2) left
      r = pMergeSort (n `div` 2) right
  in  (evalList r `par` l) `pseq` (merge l r)

另外需要注意的是,Haskell中启动新线程的开销非常低,因此使用pMergeSort 0 ... 的情况可能并不实用。

0这个情况仍然很有用,因为仍然存在一些开销,并且当Spark队列溢出时运行时会停止工作。请参见Kmett的“类似答案”。 - dfeuer

3

鉴于 @lehins 的优秀答案,我不确定这是否值得注意,但是...

为什么你的 pQuickSort 不起作用

你的 pQuickSort 有两个大问题。首先,你正在使用 System.Random,它非常缓慢,并且在并行排序时与其交互方式很奇怪(请参见下文)。其次,你的 par u l 引发了一个计算来评估:

u = [x] ++ pQuicksort (n `div` 2) upper

对于WHNF,即u = x : UNEVALUATED_THUNK,因此你的火花并没有起到实际作用。

使用简单伪快排观察改进

事实上,在并行化一个朴素的非就地伪快速排序时,很容易观察到性能的提高。如前所述,重要的考虑是避免使用System.Random。通过快速的LCG,我们可以基准测试实际的排序时间,而不是一些奇怪的混合排序和随机数生成。以下是伪快速排序:

import Data.List

qsort :: Ord a => [a] -> [a]
qsort (x:xs)
  = let (a,b) = partition (<=x) xs
    in qsort a ++ x:qsort b
qsort [] = []

randomList :: Int -> [Int]
randomList n = take n $ tail (iterate lcg 1)
  where lcg x = (a * x + c) `rem` m
        a = 1664525
        c = 1013904223
        m = 2^32

main :: IO ()
main = do
  let randints = randomList 5000000
  print . sum $ qsort randints

当使用 GHC 8.6.4 和 -O2 进行编译时,运行约需9.7秒。以下是“并行化”版本:

qsort :: Ord a => [a] -> [a]
qsort (x:xs)
  = let (a,b) = partition (<=x) xs
        a' = qsort a
        b' = qsort b
    in (b' `par` a') ++ x:b'
qsort [] = []

ghc -O2 -threaded 编译的版本在一个执行单元上运行约11.0秒。加入 +RTS -N4,它就可以在7.1秒内运行。

哎呀!有所改善。

(相比之下,使用 System.Random 的版本,在非并行版本上大约需要13秒,在一个执行单元上的并行版本大约需要12秒(可能只是由于一些轻微的严格性改进),并且随着添加的每个执行单元而明显变慢;计时也不稳定,尽管我不太确定为什么.)

分割 partition

这个版本的一个明显问题是,即使使用a' = qsort ab' = qsort b并行运行,它们仍然与同一个顺序的 partition 调用绑定。通过将其拆分成两个过滤器:

qsort :: Ord a => [a] -> [a]
qsort (x:xs)
  = let a = qsort $ filter (<=x) xs
        b = qsort $ filter (>x)  xs
    in b `par` a ++ x:b
qsort [] = []

我们使用-N4加快了速度,大约为5.5秒。公正地说,即使是非并行版本在排序Ints时,使用两个filters替换partition调用实际上稍微更快一些。使用过滤器可能有一些额外的优化,与分区相比,这使得额外的比较值得。

减少火花数量

现在,你在上面的pQuickSort中尝试的是将并行计算限制在最顶层的递归中。让我们使用以下psort进行实验:

psort :: Ord a => Int -> [a] -> [a]
psort n (x:xs)
  = let a = psort (n-1) $ filter (<=x) xs
        b = psort (n-1) $ filter (>x)  xs
    in if n > 0 then b `par` a ++ x:b else a ++ x:b
psort _ [] = []

这将并行处理递归的前面n层。我的特定 LCG 示例使用种子1 (即 iterate lcg 1)时,可以递归到54层,因此 psort 55 应该与完全并行版本具有相同的性能,除了需要跟踪层数的开销之外。运行时,我使用 -N4 得到大约 5.8 秒的时间,因此开销非常小。
现在,看看我们减少层数时会发生什么:
| Layers |  55 |  40 |  30 |  20 |  10 |   5 |   3 |    1 |
|--------+-----+-----+-----+-----+-----+-----+-----+------|
| time   | 5.5 | 5.6 | 5.7 | 5.4 | 7.0 | 8.9 | 9.8 | 10.2 |

请注意,在最底层,很难从并行计算中获得收益。这主要是因为树的平均深度可能在25层左右,因此在50层只有少数计算,许多计算具有奇怪的、不对称的分区,并且它们显然太小而无法并行化。另一方面,额外的"par"调用似乎没有任何惩罚。
与此同时,一直到至少20层都会有不断增加的收益,因此尝试人为地限制火花的总数为16(例如前4或5层)是一个巨大的损失。

尽管并行性收益在这里并不是非常惊人,但将赏金授予这个答案,因为它实际上遵循了可以称之为函数式编程的东西。令人不舒服的结论是,即使在今天,要从现代处理器中获得真正好的性能,仍然需要将大量工作负载放入丑陋的低级代码中。 (幸运的是,Haskell适用于将低级代码包装成库,但仍然可惜。) - leftaroundabout

3
你的伪快速排序涉及列表连接,无法并行化且需要二次时间(所有连接的总时间),因此不会有明显的改进。我建议你尝试使用归并排序,在链接列表上的时间复杂度为 O(n log n)。
此外,要在大量线程上运行程序,应编译时使用 -rtsopts 参数。

我已添加合并排序的实现。我注意确保算法在拆分和合并期间仅遍历列表一次,这应该是最优的。然而,它显示了与快速排序相同的症状。越多能力,速度越慢。-rtsopts 只需要在使用超过 24 个能力时才需要。 - lysgaard
列表连接在时间上为什么是二次的? - leftaroundabout
我的意思是,所有连接的总时间是二次的。 - tempestadept
列表连接可以并行化。诀窍是让主线程设置连接,并在结果中保存段之间边界的指针。这些指针可以与适当大小一起传递给新线程;然后每个线程使用“drop”强制执行其结果的共享部分。 - dfeuer

网页内容由stack overflow 提供, 点击上面的
可以查看英文原文,
原文链接