是否有可能在Haskell中加速快速排名？

Question

我有这个看似琐碎的并行快速实现，代码如下：

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上运行的简单顺序实现运行得更快。

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

Answer 1

已经提到了几个问题：

• 使用列表无法提供所需的性能。甚至this sample implementation使用向量也比使用列表快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 #-}

现在，如果我们查看参数numWorkers和schedule，它们是非常不透明的。假设如果我们为第一个参数提供1，为第二个参数提供id，我们将简单地进行顺序快速排序，但是如果我们有一个可用的函数可以安排要计算的每个任务同时，那么我们将获得Quicksort的并行实现。幸运的是，我们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)

这是一个纯版本，它将复制一个数组，然后使用在数组本身内指定的computation strategy对其进行排序：

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的简介
• 使用this answer中的向量进行就地快速排序
• 我从this question抢来的C中的实现方式
• 使用massiv的顺序快速排序
• 与上述相同，但在具有不起眼的第3代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;）

添加排序功能了

Answer 2

我不确定它对于惯用的快速排序有多好用，但它可以在真正的命令式快速排序中工作（在某种程度上很弱），如Sparking Imperatives中罗马所示。

但是，他从来没有获得过好的加速。这确实需要一个真正的work-stealing deque，它不像火花队列一样溢出来正确优化。

Answer 3

由于您的伪快速排序涉及列表并置，无法并行化并且需要二次时间（所有连接的总时间），因此您不会获得任何明显的改进。我建议你尝试使用mergesort，它是链接列表上的O(n log n)。

此外，要运行具有大量线程的程序，您应该使用-rtsopts编译它。

Answer 4

par仅评估弱头正常形式的第一个参数。这就是说：如果第一个参数的类型是Maybe Int，那么par将检查结果是Nothing还是Just 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 ...的情况可能没用。

Answer 5

鉴于@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秒内运行。

Ta da！一种改进。

（与之相反，具有System.Random的版本在非并行版本上运行大约需要13秒，在一种功能上，并行版本需要大约12秒运行（可能是由于某些较小的严格性改进），并且速度变慢降低每增加一个附加功能；时间也不固定，尽管我不确定为什么。

拆分partition

此版本的一个明显问题是，即使a' = qsort a和b' = 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秒。公平地讲，即使使用两个filters代替partition调用，甚至 non-parallel 版本实际上也稍快一些，至少在对Ints进行排序时。与分区相比，筛选器可能还可以进行一些其他优化，因此值得进行额外的比较。

减少火花数量

现在，您在上面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层。我特定的种子为1（即iterate lcg 1）的LCG示例最多可重复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层）是很大的损失。