Haskell中的快速排序

Question

阅读了 Stack Overflow 上的问题 Using vectors for performance improvement in Haskell，介绍了在 Haskell 中快速实现原地快速排序的方法后，我给自己设定了两个目标：

• 使用中位数三取样来避免对预排序向量的性能影响，实现相同的算法；

• 制作并行版本。

以下是结果（为了简化，留下了一些小细节）：

import qualified Data.Vector.Unboxed.Mutable as MV
import qualified Data.Vector.Generic.Mutable as GM

type Vector = MV.IOVector Int
type Sort = Vector -> IO ()

medianofthreepartition :: Vector -> Int -> IO Int
medianofthreepartition uv li = do
    p1 <- MV.unsafeRead uv li
    p2 <- MV.unsafeRead uv $ li `div` 2
    p3 <- MV.unsafeRead uv 0
    let p = median p1 p2 p3
    GM.unstablePartition (< p) uv

vquicksort :: Sort
vquicksort uv = do
    let li = MV.length uv - 1
    j <- medianofthreepartition uv li
    when (j > 1) (vquicksort (MV.unsafeSlice 0 j uv))
    when (j + 1 < li) (vquicksort (MV.unsafeSlice (j+1) (li-j) uv))

vparquicksort :: Sort
vparquicksort uv = do
    let li = MV.length uv - 1
    j <- medianofthreepartition uv li
    t1 <- tryfork (j > 1) (vparquicksort (MV.unsafeSlice 0 j uv))
    t2 <- tryfork (j + 1 < li) (vparquicksort (MV.unsafeSlice (j+1) (li-j) uv))
    wait t1
    wait t2

tryfork :: Bool -> IO () -> IO (Maybe (MVar ()))
tryfork False _ = return Nothing
tryfork True action = do
  done <- newEmptyMVar :: IO (MVar ())
  _ <- forkFinally action (\_ -> putMVar done ())
  return $ Just done

wait :: Maybe (MVar ()) -> IO ()
wait Nothing = return ()
wait (Just done) = swapMVar done ()

median :: Int -> Int -> Int -> Int
median a b c
        | a > b =
                if b > c then b
                        else if a > c then c
                                else a
        | otherwise =
                if a > c then a
                        else if b > c then c
                                else b

对于1,000,000个元素的向量，我得到了以下结果：

"Number of threads: 4"

"**** Parallel ****"
"Testing sort with length: 1000000"
"Creating vector"
"Printing vector"
"Sorting random vector"
CPU time:  12.30 s
"Sorting ordered vector"
CPU time:   9.44 s

"**** Single thread ****"
"Testing sort with length: 1000000"
"Creating vector"
"Printing vector"
"Sorting random vector"
CPU time:   0.27 s
"Sorting ordered vector"
CPU time:   0.39 s

我的问题如下：

• 为什么使用预排序的向量性能仍在下降？
• 为什么使用forkIO和四个线程无法提高性能？

- Simon Bergot

---

我即将去睡觉，所以现在不进行分析，只说一些显而易见的事情。当你在每次递归调用时都进行分支(forking)，你会创建很多线程，线程调度开销会超过实际需要完成的工作量。如果涉及到访问数组的不同线程之间甚至需要同步，那么即使只有少量线程也会完全影响性能。如果你想加快速度，只在前几个递归调用中进行分支，以避免运行的线程数超过CPU核心数。 - Daniel Fischer

要实现快速的并行性，你应该使用par而不是forkIO。有关更多详细信息，请参见parallel包此处。 - Gabriella Gonzalez

@Simon par 的效果对应物是 Par monad，它是 monad-par 包的一部分，你可以在这里找到它。请查看 Control.Monad.Par.IO 模块。 - Gabriella Gonzalez

另外，如果您正在使用并行处理，您必须考虑计算机的核心数量。您不希望超负荷运行它们。您可以使用Control.Concurrent中的getNumCapabilities函数获取核心数。 - Jcao02

@Jcao02 Haskell应该使用绿色线程，所以只有在使用不完整的Haskell编译器时才会出现这个问题。 - Jeremy List

Answer 1

更好的做法是使用Control.Parallel.Strategies来并行化快速排序。采用这种方法，您不会为每个可以并行执行的代码创建昂贵的线程。您还可以创建一个纯计算而不是IO。

然后，您需要根据您拥有的核心数进行编译： http://www.haskell.org/ghc/docs/latest/html/users_guide/using-concurrent.html 例如，看看由Jim Apple编写的简单列表快速排序的示例：

import Data.HashTable as H
import Data.Array.IO
import Control.Parallel.Strategies
import Control.Monad
import System

exch a i r =
    do tmpi <- readArray a i
       tmpr <- readArray a r
       writeArray a i tmpr
       writeArray a i tmpi

bool a b c = if c then a else b

quicksort arr l r =
  if r <= l then return () else do
    i <- loop (l-1) r =<< readArray arr r
    exch arr i r
    withStrategy rpar $ quicksort arr l (i-1)
    quicksort arr (i+1) r
  where
    loop i j v = do
      (i', j') <- liftM2 (,) (find (>=v) (+1) (i+1)) (find (<=v) (subtract 1) (j-1))
      if (i' < j') then exch arr i' j' >> loop i' j' v
                   else return i'
    find p f i = if i == l then return i
                 else bool (return i) (find p f (f i)) . p =<< readArray arr i

main = 
    do [testSize] <- fmap (fmap read) getArgs
       arr <- testPar testSize
       ans <- readArray arr  (testSize `div` 2)
       print ans

testPar testSize =
    do x <- testArray testSize
       quicksort x 0 (testSize - 1)
       return x

testArray :: Int -> IO (IOArray Int Double)
testArray testSize = 
    do ans <- newListArray (0,testSize-1) [fromIntegral $ H.hashString $ show i | i <- [1..testSize]]
       return ans

- Boldizsár Németh

---

@JeremyList 我能问一下为什么吗？ - Abhinav Gauniyal

因为操作系统每个CPU内核只能看到一个线程，但这些线程在内部运行更轻量级的线程系统（不需要考虑页面、多用户等）。 - Jeremy List