MergeSort.hs

import System.Random (newStdGen, randoms)
import Control.DeepSeq
import Control.Monad.Par
import Data.List (sort)

mergeSort :: Ord a => [a] -> [a]
mergeSort []  = []
mergeSort [x] = [x]
mergeSort xs =
    let (firstHalf, secondHalf) = split xs
    in merge (mergeSort firstHalf) (mergeSort secondHalf)

parallelMergeSort :: (Ord a, NFData a) => Int -> [a] -> [a]
parallelMergeSort stopDepth xs = runPar $ go 0 xs
    where go depth xs
              | depth >= stopDepth = return $ mergeSort xs
              | otherwise = do
                let (ys, zs) = split xs
                ysIvar <- spawn $ go (depth+1) ys
                zsIvar <- spawn $ go (depth+1) ys
                ys' <- get ysIvar
                zs' <- get zsIvar
                return $ merge ys' zs'

mergeSort' :: (Ord a, NFData a) => [a] -> [a]
mergeSort' = parallelMergeSort 19

split :: [a] -> ([a], [a])
split list = go list list
    where go (x:xs) (_:_:ys) = (x:fibrstHalf, secondHalf)
              where (firstHalf, secondHalf) = go xs ys
          go xs _ = ([], xs)

merge :: Ord a => [a] -> [a] -> [a]
merge (x:xs) (y:ys)
    | x < y     = x:merge xs (y:ys)
    | otherwise = y:merge (x:xs) ys
merge xs ys = xs ++ ys

n = 2000000

main = do
  gen <- newStdGen
  let list  = take n $ randoms gen :: [Int]
  list `deepseq` return ()
  let list' = sort list
  list' `deepseq` return ()