Нет ускорения с наивным распараллеливанием сортировки слиянием в Haskell

Question

Примечание. Эта запись была полностью переписана 2011-06-10;спасибо Петру за помощь .Также, пожалуйста, не обижайтесь, если я не приму один ответ, так как этот вопрос кажется довольно открытым.(Но, если вы решите это, вы, конечно, отметите галочкой.)

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

Постановка задачи

Сортировка слиянием - это алгоритм "разделяй и властвуй", гдеЛисты вычислений можно распараллелить.

Код работает следующим образом: список преобразуется в дерево, представляющее вычислительные узлы.Затем шаг слияния возвращает список для каждого узла.Теоретически, мы должны увидеть некоторые существенные улучшения производительности, поскольку мы переходим от алгоритма O (n log n) к алгоритму O (n) с бесконечными процессорами.

Первые этапы вычисления распараллеливаются, когда параметр l (уровень) ниже нуля ниже.Это делается с помощью [через переменную strat ] выбора стратегии rpar , в результате чего подвычисления mergeSort 'x будут выполняться параллельно с mergeSort'у .Затем мы объединяем результаты и форсируем их оценку с помощью rdeepseq .

data Tree a = Leaf a | Node (Tree a) (Tree a) deriving (Show)

instance NFData a => NFData (Tree a) where
    rnf (Leaf v) = deepseq v ()
    rnf (Node x y) = deepseq (x, y) ()

listToTree [] = error "listToTree -- empty list"
listToTree [x] = Leaf x
listToTree xs = uncurry Node $ listToTree *** listToTree $
    splitAt (length xs `div` 2) xs

-- mergeSort' :: Ord a => Tree a -> Eval [a]
mergeSort' l (Leaf v) = return [v]
mergeSort' l (Node x y) = do
    xr <- strat $ runEval $ mergeSort' (l - 1) x
    yr <- rseq $ runEval $ mergeSort' (l - 1) y
    rdeepseq (merge xr yr)
    where
        merge [] y = y
        merge x [] = x
        merge (x:xs) (y:ys) | x < y = x : merge xs (y:ys)
                            | otherwise = y : merge (x:xs) ys
        strat | l > 0 = rpar
              | otherwise = rseq

mergeSort = runEval . mergeSort' 10

. Оценивая только несколько уровней вычислений, мы должны иметь приличную параллельную сложность связи также - некоторый постоянный коэффициент порядка n .

Results

Получите исходный код 4-й версии здесь [http://pastebin.com/DxYneAaC] и выполнитеэто с помощью следующего для проверки использования потоков или последующих командных строк для тестирования,

rm -f ParallelMergeSort; ghc -O2 -O3 -optc-O3 -optc-ffast-math -eventlog --make -rtsopts -threaded ParallelMergeSort.hs
./ParallelMergeSort +RTS -H512m -K512m -ls -N
threadscope ParallelMergeSort.eventlog

Результаты на 24-ядерном X5680 @ 3,33 ГГц показывают небольшое улучшение

> ./ParallelMergeSort 
initialization: 10.461204s sec.
sorting: 6.383197s sec.
> ./ParallelMergeSort +RTS -H512m -K512m -N
initialization: 27.94877s sec.
sorting: 5.228463s sec.

и на моемсобственная машина, четырехъядерный Phenom II,

> ./ParallelMergeSort 
initialization: 18.943919s sec.
sorting: 10.465077s sec.
> ./ParallelMergeSort +RTS -H512m -K512m -ls -N
initialization: 22.92075s sec.
sorting: 7.431716s sec.

Проверка результатов в потоковой области показывает хорошее использование для небольших объемов данных.(хотя, к сожалению, ощутимого ускорения нет).Однако, когда я пытаюсь запустить его в больших списках, как указано выше, он использует около 2 процессоров в половину времени.Кажется, что многие искры подрезаются.Он также чувствителен к параметрам памяти, где 256 МБ - это лучшее место, 128 МБ - 9 секунд, 512 - 8,4, а 1024 - 12,3!

Решения, которые я ищу

Наконец, еслиКто-нибудь знает мощные инструменты, чтобы бросить на это, я был бы признателен.(Eden?).Мой основной интерес к параллелизму на Haskell - уметь писать небольшие вспомогательные инструменты для исследовательских проектов, которые я могу использовать на 24 или 80 основных серверах в кластере нашей лаборатории.Поскольку они не являются основной целью исследований нашей группы, я не хочу тратить много времени на эффективность распараллеливания.Так что для меня проще - лучше, даже если я получу только 20% использования.

Дальнейшее обсуждение

• Я заметил, что вторая полоса в Threadsccope иногда зеленая (ср.ее домашняя страница , где вторая полоса, кажется, всегда является сборщиком мусора).Что это значит?
• Есть ли способ обойти сборку мусора?Кажется, это занимает много времени.Например, почему нельзя выполнить разветвление подкомпьютера, вернуть результат в совместно используемую память и затем умереть?
• Есть ли лучший способ (стрелки, аппликативный) для выражения параллелизма?

Answer 1

Ответ довольно прост: потому что вы никогда не вводили параллелизм. Eval - это просто монада для заказа вычислений, вам нужно попросить, чтобы вещи выполнялись параллельно вручную. Что вы, вероятно, хотите, это:

do xr <- rpar $ runEval $ mergeSort' x
   yr <- rseq $ runEval $ mergeSort' y
   rseq (merge xr yr)

Это заставит Хаскель фактически создать искру для первого вычисления, вместо того, чтобы пытаться оценить его на месте.

Стандартные советы также применяются:

1. Результат должен быть глубоко оценен (например, с использованием evalTraversable rseq). В противном случае вы будете принудительно использовать только верхушку дерева, и большая часть данных будет возвращена без оценки.
2. Простое зажигание, скорее всего, съест все выгоды. Было бы неплохо ввести параметр, который прекращает искрение при более низких уровнях рекурсии.

Редактировать: следующее фактически не применяется после редактирования вопроса

Но самое худшее - последнее: ваш алгоритм, как вы заявляете, очень некорректен. Ваш верхний уровень seq заставляет только первую конс-ячейку списка, что позволяет GHC использовать ленивый эффект. На самом деле он никогда не будет создавать список результатов, просто просматривайте их все в поисках минимального элемента (это даже не обязательно, но GHC создает ячейку только после того, как минимальный известен).

Так что не удивляйтесь, когда производительность действительно резко падает, когда вы начинаете вводить параллелизм при допущениях, что вам нужен весь список в какой-то момент в программе ...

Редактировать 2: еще несколько ответов на правки

Самая большая проблема с вашей программой, вероятно, в том, что она использует списки. Если вы хотите сделать больше, чем просто игрушечный пример, рассмотрите хотя бы использование (без упаковки) массивов. Если вы хотите серьезно заняться цифрами, подумайте о специализированной библиотеке, такой как repa .

На «Дальнейшее обсуждение»:

• Цвета обозначают различные состояния GC, я не могу вспомнить, какие именно. Попробуйте посмотреть в журнале событий соответствующее событие.

• Способ "обхода" сбора мусора заключается в том, чтобы не производить столько мусора, например. используя лучшие структуры данных.

• Что ж, если вы ищете вдохновение для надежного распараллеливания, возможно, стоит взглянуть на monad-par , который является относительно новым, но (я чувствую) менее "удивительным" в параллельном поведении.

С monad-par ваш пример может выглядеть примерно так:

  do xr <- spawn $ mergeSort' x
     yr <- spawn $ mergeSort' y
     merge <$> get xr <*> get yr

Так что здесь get фактически вынуждает вас указать точки соединения - и библиотека автоматически делает необходимые deepseq за сценой.

Answer 2

Мне повезло с тем, что вы сообщили в EDIT 3 о двухъядерной системе с этими вариантами. Я использовал меньшую длину списка, потому что я на меньшем компьютере, скомпилирован с ghc -O2 -rtsopts -threaded MergePar.hs и работал с ./MergePar +RTS -H256M -N. Это может предложить более структурированный способ сравнения производительности. Обратите внимание, что опция RTS -qa иногда помогает простым вариантам par.

import Control.Applicative
import Control.Parallel
import Control.Parallel.Strategies
import Criterion.Main
import GHC.Conc (numCapabilities)

data Tree a = Leaf a | Node (Tree a) (Tree a) deriving Show

listToTree [] = error "listToTree -- empty list"
listToTree [x] = Leaf x
listToTree xs = Node (listToTree (take half xs)) (listToTree (drop half xs))
  where half = length xs `div` 2

-- Merge two ordered lists
merge :: Ord a => [a] -> [a] -> [a]
merge [] y = y
merge x [] = x
merge (x:xs) (y:ys) | x < y = x : merge xs (y:ys)
                    | otherwise = y : merge (x:xs) ys

-- Simple merge sort
mergeSort' :: Ord a => Tree a -> [a]
mergeSort' (Leaf v) = [v]
mergeSort' (Node x y) = merge (mergeSort' x) (mergeSort' y)

mergeSort :: Ord a => [a] -> [a]
mergeSort = mergeSort' . listToTree

-- Merge sort with 'par' annotations on every recursive call
mergeSortP' :: Ord a => Tree a -> [a]
mergeSortP' (Leaf v) = [v]
mergeSortP' (Node x y) = let xr = mergeSortP' x
                             yr = mergeSortP' y
                         in xr `par` yr `pseq` merge xr yr

mergeSortP :: Ord a => [a] -> [a]
mergeSortP = mergeSortP' . listToTree

-- Merge sort with 'rpar' annotations on every recursive call
mergeSortR' :: Ord a => Tree a -> [a]
mergeSortR' (Leaf v) = [v]
mergeSortR' (Node x y) = 
  runEval $ merge <$> rpar (mergeSortR' x) <*> rpar (mergeSortR' y)

mergeSortR :: Ord a => [a] -> [a]
mergeSortR = mergeSortR' . listToTree

-- Parallel merge sort that stops looking for parallelism at a certain
-- depth
smartMerge' :: Ord a => Int -> Tree a -> [a]
smartMerge' _ (Leaf v) = [v]
smartMerge' n t@(Node x y)
  | n <= 1 = mergeSort' t
  | otherwise = let xr = smartMerge' (n-1) x
                    yr = smartMerge' (n-2) y
                in xr `par` yr `pseq` merge xr yr

smartMerge :: Ord a => [a] -> [a]
smartMerge = smartMerge' numCapabilities . listToTree

main = defaultMain $ [ bench "original" $ nf mergeSort lst
                     , bench "par" $ nf mergeSortP lst
                     , bench "rpar" $ nf mergeSortR lst
                     , bench "smart" $ nf smartMerge lst ]
  where lst = [100000,99999..0] :: [Int]