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

  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
4

5 回答 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 #-}

这是最好的部分,基准。结果顺序:

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 个随机Int64s 进行排序。如果您想查看完整代码,可以在这里找到:https ://github.com/lehins/haskell-quicksort

总而言之,我们在四核处理器和 8 种功能上获得了 3 倍的速度提升,这对我来说听起来很不错。感谢这个问题,现在我可以添加排序功能massiv;)

编辑

请注意,对于这个问题,使用列表而不是更合适的数据结构(例如可变数组)的公认答案在相同输入上慢 x100 倍:

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)
于 2019-04-27T21:44:19.880 回答
4

我不确定它对于惯用的快速排序有多好,但它可以(在某种程度上)对真正的命令式快速排序起作用,如 Roman 在Sparking Imperatives中所示。

不过,他从来没有得到很好的加速。这确实需要一个真正的工作窃取双端队列,它不会像火花队列那样溢出来正确优化。

于 2013-11-04T05:05:52.837 回答
3

您不会得到任何明显的改进,因为您的伪快速排序涉及列表连接,它不能并行化并且需要二次时间(所有连接的总时间)。我建议您尝试使用链表O(n log n)上的合并排序。

此外,要使用大量线程运行程序,您应该使用-rtsopts.

于 2013-11-04T06:41:08.317 回答
3

par只评估弱头范式的第一个参数。也就是说:如果第一个参数的类型是Maybe Intthenpar将检查结果是否为NothingorJust 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 中启动新线程的开销非常低,因此 for 的情况pMergeSort 0 ...可能没有用。

于 2015-07-08T03:42:39.860 回答
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。公平地说,即使是非并行filters版本,用两个代替调用实际上也稍微快一些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递归的顶层。我的种子为 1(即iterate lcg 1)的特定 LCG 示例最多可递归 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 层)是一个很大的损失。

于 2019-04-28T21:03:08.517 回答