Параллельная Быстрая Сортировка На Haskell И Как Сложно Ее Оказалось Написать

оригинальная статья Тони Хоара 1962 года о быстрой сортировке).

А именно перестановка [разбиение] массива без дополнительного выделения памяти [разбиение на месте с помощью свопов].

Столкнувшись с проблемой написания универсальной параллельной быстрой сортировки на Haskell, Джим Эппл (который пишет докторскую диссертацию по Haskell в Калифорнийском университете в Дэвисе) взялся за дело.

написав следующий код:

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

Этот алгоритм использует параллельные " стратегии «Haskell. Эта концепция была разработана, чтобы дать программистам Haskell больше контроля над распараллеливанием, но оказалось, что утечки памяти в единственной доступной реализации и никому не удалось заставить его работать в этом коде: решение Джима содержит ошибку параллелизма, из-за которой оно возвращает неправильные результаты почти при каждом вызове.

Тогда Пикер предложил ваше решение в Хаскеле:

import Data.Array.IO import Control.Monad import Control.Concurrent bool t _f True = t bool _t f False = f swap arr i j = do (iv, jv) <- liftM2 (,) (readArray arr i) (readArray arr j) writeArray arr i jv writeArray arr j iv parallel fg bg = do m <- newEmptyMVar forkIO (bg >> putMVar m ()) fg >> takeMVar m sort arr left right = when (left < right) $ do pivot <- read right loop pivot left (right - 1) (left - 1) right where read = readArray arr sw = swap arr find n pred i = bool (find n pred (n i)) (return i) .

pred i =<< read i move op d i pivot = bool (return op) (sw (d op) i >> return (d op)) =<< liftM (/=pivot) (read i) loop pivot oi oj op oq = do i <- find (+1) (const (<pivot)) oi j <- find (subtract 1) (\idx cell -> cell>pivot && idx/=left) oj if i < j then do sw i j p <- move op (+1) i pivot q <- move oq (subtract 1) j pivot loop pivot (i + 1) (j - 1) p q else do sw i right forM_ (zip [left.op-1] [i-1,i-2.]) $ uncurry sw forM_ (zip [right-1,right-2.oq+1] [i+1.]) $ uncurry sw let ni = if left >= op then i + 1 else right + i - oq nj = if right-1 <= oq then i - 1 else left + i - op let thresh = 1024 strat = if nj - left < thresh || right - ni < thresh then (>>) else parallel sort arr left nj `strat` sort arr ni right main = do arr <- newListArray (0, 5) [3,1,7,2,4,8] getElems arr >>= print sort (arr :: IOArray Int Int) 0 5 getElems arr >>= print

В этом решении также оказались ошибки.

Во-первых, он содержит более тонкую ошибку параллелизма, которая лишь изредка приводит к неверным результатам.

Сборщик исправил эту ошибку в следующем коде:

import System.Time import System.Random import Data.Array.IO import Control.Monad import Control.Concurrent import Control.Exception import qualified Data.List as L bool t _ True = t bool _ f False = f swap arr i j = do (iv, jv) <- liftM2 (,) (readArray arr i) (readArray arr j) writeArray arr i jv writeArray arr j iv background task = do m <- newEmptyMVar forkIO (task >>= putMVar m) return $ takeMVar m parallel fg bg = do wait <- background bg fg >> wait sort arr left right = when (left < right) $ do pivot <- read right loop pivot left (right - 1) (left - 1) right where read = readArray arr sw = swap arr find n pred i = bool (find n pred (n i)) (return i) .

pred i =<< read i move op d i pivot = bool (return op) (sw (d op) i >> return (d op)) =<< liftM (/=pivot) (read i) swapRange px x nx y ny = if px x then sw x y >> swapRange px (nx x) nx (ny y) ny else return y loop pivot oi oj op oq = do i <- find (+1) (const (<pivot)) oi j <- find (subtract 1) (\idx cell -> cell>pivot && idx/=left) oj if i < j then do sw i j p <- move op (+1) i pivot q <- move oq (subtract 1) j pivot loop pivot (i + 1) (j - 1) p q else do sw i right nj <- swapRange (<op) left (+1) (i-1) (subtract 1) ni <- swapRange (>oq) (right-1) (subtract 1) (i+1) (+1) let thresh = 1024000 strat = if nj - left < thresh || right - ni < thresh then (>>) else parallel sort arr left nj `strat` sort arr ni right timed act = do TOD beforeSec beforeUSec <- getClockTime x <- act TOD afterSec afterUSec <- getClockTime return (fromIntegral (afterSec - beforeSec) + fromIntegral (afterUSec - beforeUSec) / 1000000000000, x) main = do let n = 1000000 putStrLn "Making rands" arr <- newListArray (0, n-1) =<< replicateM n (randomRIO (0, 1000000) >>= evaluate) elems <- getElems arr putStrLn "Now starting sort" (timing, _) <- timed $ sort (arr :: IOArray Int Int) 0 (n-1) print .

(L.sort elems ==) =<< getElems arr putStrLn $ "Sort took " ++ show timing ++ " seconds"

Это решение работает с небольшими входными массивами, но увеличение размера массива до 1 000 000 элементов приводит к переполнению стека.

Были предприняты две попытки проанализировать эту ошибку, Здесь И Здесь , но оба оказались неправы.

На самом деле это ошибка в функции получитьЭлемс Стандартная библиотека Haskell, которая переполняет стек на больших массивах.

Как ни странно, исправление еще нескольких ошибок, похоже, привело к реализации первой в мире параллельной быстрой сортировки общего назначения, написанной на Haskell. Более того, окончательное решение на Haskell всего лишь примерно на 55% медленнее, чем эквивалентное решение на F#.

Будьте осторожны, для этого решения требуется последняя версия GHC, выпущенная несколько недель назад ( ок.

перевод: статья 2010 года, так что читателю не о чем волноваться ).