Возможно ли ускорить быстродействующую сортировку с парной в Haskell?

Я получил эту, казалось бы, тривиальную параллельную реализацию быстрой сортировки, код выглядит следующим образом:

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

Независимо от того, что я делаю, я не могу заставить его работать быстрее, чем простая последовательная реализация, работающая на одном процессоре.

  1. Можно ли объяснить, почему это работает намного медленнее на нескольких процессорах, чем на одном?
  2. Можно ли сделать эту шкалу, по крайней мере, сублинейно, с количеством процессоров, выполнив какой-то трюк?

РЕДАКТИРОВАТЬ: @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

Ответ 1

Я не уверен, насколько хорошо он может работать для идиоматической быстрой сортировки, но он может работать (в несколько слабой степени) для истинной императивной быстрой сортировки, как показано Романом в "Искрящиеся императивы" .

Тем не менее, он никогда не получал хорошего ускорения. Для этого действительно нужен реальный рабочий краж, который не переполняется, как искровая очередь, для оптимальной оптимизации.

Ответ 2

Вы не получите заметного улучшения, так как ваша псевдо-быстрая сортировка включает в себя объединение списков, которое невозможно распараллелить и требует квадратичного времени (общее время для всех конкатенаций). Я бы посоветовал вам попробовать работать с объединением, которое O(n log n) в связанных списках.

Кроме того, чтобы запустить программу с большим количеством потоков, вы должны скомпилировать ее с помощью -rtsopts.

Ответ 3

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 ..., вероятно, не пригодится.

Ответ 4

Есть несколько проблем, которые уже были упомянуты:

  • Использование списков не даст желаемого результата. Даже в этом примере реализации, использующем вектор, коэффициент в 50 раз быстрее, чем при использовании списков, поскольку он выполняет замену элементов на месте. По этой причине мой ответ будет включать в себя реализацию с использованием библиотеки массив massiv, а не списки.
  • Я, как правило, найти Haskell планировщика далеко от совершенства для работы процессора задач, так как @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
  • То же, что и выше, но параллельно на компьютере со скромным 4-ядерным процессором 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

Подводя итог, мы получили ускорение в 3 раза на четырехъядерном процессоре и 8 возможностей, что для меня неплохо звучит. Спасибо за этот вопрос, теперь я могу добавить функцию сортировки в massiv ;)

Ответ 5

Я не уверен, что это стоит отметить, учитывая отличный ответ @lehins, но...

Почему ваш pQuickSort не работает

Есть две большие проблемы с вашим pQuickSort. Во-первых, вы используете System.Random, который слишком медленный и странно взаимодействует с параллельной сортировкой (см. Ниже). Во - вторых, ваш par ul зажигает вычисления для оценки:

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

с помощью -N4 до 5,5 секунд. Чтобы быть справедливым, даже непараллельная версия на самом деле немного быстрее с двумя 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 слоев рекурсии. Мой конкретный пример LCG с начальным iterate lcg 1 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 верхних слоев) является большой потерей.