是否有可能在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

已经提到了几个问题：

• 使用列表并不能提供您想要的性能。即使是使用vector的示例实现，也比使用list的实现快了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第二个参数，我们将只具有顺序快速排序，但是如果我们有一个可用的函数可以安排要同时计算的每个任务，那么我们将得到一个并行实现一个快速排序。幸运地为我们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
• 使用此答案中的向量进行就地快速排序
• 在中的实现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种功能上的速度提高了x3，这对我来说听起来不错。谢谢这个问题，现在我可以将排序功能添加到massiv;）

Answer 2

我不确定它对于惯用的快速排序是否能很好地起作用，但是对于真正的命令式快速排序，它可以（在某种程度上较弱）工作，如Roman在Sparking Imperatives中显示的那样。

不过，他从来没有取得过不错的提速。这确实需要一个真正的工作窃取双端队列，并且不会像火花队列那样溢出以正确优化。

Answer 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 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 [] = []

我们使用 来将速度加快到大约 5.5 秒-N4。公平地说，即使是非并行版本实际上也稍微快一些，用 2filters代替调用partition，至少在排序时是这样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递归的顶层并行化。我的特定 LCG 示例的种子为 1（即iterate lcg 1），递归最多 54 层，因此psort 55除了跟踪层的开销之外，应该具有与完全并行版本相同的性能。当我运行它时，我得到的时间约为 5.8 秒-N4，因此开销相当小。

现在，看看当我们减少层数时会发生什么：

| 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 层）是一个很大的损失。