No speedup with naive merge sort parallelization in Haskell

Question

Note: This post was completely rewritten 2011-06-10; thanks to Peter for helping me out. Also, please don\'t be offended if I don\'t accept one answer, since this quest

Answer 1

I had similar luck to what you report in EDIT 3 on a dual core system with these variants. I used a smaller list length because I'm on a smaller computer, compiled with ghc -O2 -rtsopts -threaded MergePar.hs, and ran with ./MergePar +RTS -H256M -N. This might offer a more structured way to compare performance. Note that the RTS option -qa sometimes helps the simple par variants.

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]