[Haskell-cafe] (flawed?) benchmark : sort

[Krzysztof Skrzętnicki]

Hi

I was playing with various versions of sorting algorithms. I know it's very
easy to create flawed benchmark and I don't claim those are good ones.
However, it really seems strange to me, that sort - library function - is
actually the worse measured function. I can hardly belive it, and I'd rather
say I have made a mistake preparing it.

The overall winner seems to be qsort_iv - which is nothing less but old sort
replaced by mergesort now.

Any clues?

Regards
Christopher Skrzętnicki

--- cut here ---
[Tener at laptener haskell]$ ghc -O2 --make qsort.hs && ./qsort +RTS -sstderr
-RTS > /dev/null
[1 of 1] Compiling Main             ( qsort.hs, qsort.o )
Linking qsort ...
./qsort +RTS -sstderr
(1.0,"iv")
(1.1896770400256864,"v")
(1.3091609772011856,"treeSort")
(1.592515715933153,"vii")
(1.5953543402198838,"vi")
(1.5961286512637272,"iii")
(1.8175480563244177,"i")
(1.8771604568641642,"ii")
(2.453160634439497,"mergeSort")
(2.6627090768870216,"sort")
26,094,674,624 bytes allocated in the heap
12,716,656,224 bytes copied during GC (scavenged)
2,021,104,592 bytes copied during GC (not scavenged)
107,225,088 bytes maximum residency (140 sample(s))

      49773 collections in generation 0 ( 21.76s)
        140 collections in generation 1 ( 23.61s)

        305 Mb total memory in use

  INIT  time    0.00s  (  0.00s elapsed)
  MUT   time   20.39s  ( 20.74s elapsed)
  GC    time   45.37s  ( 46.22s elapsed)
  EXIT  time    0.00s  (  0.00s elapsed)
  Total time   65.76s  ( 66.96s elapsed)

  %GC time      69.0%  (69.0% elapsed)

  Alloc rate    1,279,723,644 bytes per MUT second

  Productivity  31.0% of total user, 30.5% of total elapsed


--- cut here ---

{-# OPTIONS_GHC -O2 #-}
module Main where

import System.CPUTime
import System.IO
import System.Environment
import System.Random
import Data.List( partition, sort )

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


qsort_i []  = []
qsort_i (x:xs) = qsort_i (filter (< x) xs) ++ [x] ++ qsort_i (filter (>= x)
xs)

qsort_ii [] = []
qsort_ii (x:xs) = let (ls,gt) = partition (< x) xs in qsort_ii ls ++ [x] ++
qsort_ii gt

qsort_iii xs = qsort_iii' [] xs
qsort_iii' acc [] = acc
qsort_iii' acc (x:xs) =
    let (ls,gt) = partition (< x) xs in
    let acc' = (x:(qsort_iii' acc gt)) in qsort_iii' acc' ls

qsort_v [] = []
qsort_v (x:xs) = let (xlt, xgt ) = foldl (\ (lt,gt) el -> case compare x el
of
                                                            GT -> (el:lt,
gt)
                                                            _  -> (lt,
el:gt) ) ([],[]) xs
                 in qsort_v xlt ++ [x] ++ qsort_v xgt

-- zmodyfikowany i
qsort_vi [] = []
qsort_vi (x:xs) = qsort_vi (filter (\y-> compare x y == GT) xs) ++ [x] ++
qsort_vi (filter (\y-> compare x y /= GT) xs)


-- zmodyfikowany iii
qsort_vii xs = qsort_vii' [] xs
qsort_vii' acc [] = acc
qsort_vii' acc (x:xs) =
    let (ls,gt) = partition (\y-> compare x y == GT) xs in
    let acc' = (x:(qsort_vii' acc gt)) in qsort_vii' acc' ls



-- qsort is stable and does not concatenate.
qsort_iv xs = qsort_iv' (compare) xs []

qsort_iv' _   []     r = r
qsort_iv' _   [x]    r = x:r
qsort_iv' cmp (x:xs) r = qpart cmp x xs [] [] r

-- qpart partitions and sorts the sublists
qpart cmp x [] rlt rge r =
    -- rlt and rge are in reverse order and must be sorted with an
    -- anti-stable sorting
    rqsort_iv' cmp rlt (x:rqsort_iv' cmp rge r)
qpart cmp x (y:ys) rlt rge r =
    case cmp x y of
    GT -> qpart cmp x ys (y:rlt) rge r
        _  -> qpart cmp x ys rlt (y:rge) r

-- rqsort is as qsort but anti-stable, i.e. reverses equal elements
rqsort_iv' _   []     r = r
rqsort_iv' _   [x]    r = x:r
rqsort_iv' cmp (x:xs) r = rqpart cmp x xs [] [] r

rqpart cmp x [] rle rgt r =
    qsort_iv' cmp rle (x:qsort_iv' cmp rgt r)
rqpart cmp x (y:ys) rle rgt r =
    case cmp y x of
    GT -> rqpart cmp x ys rle (y:rgt) r
        _  -> rqpart cmp x ys (y:rle) rgt r


-- code by Orcus

-- Zadanie 9 - merge sort
mergeSort :: Ord a => [a] -> [a]
mergeSort []    = []
mergeSort [x]   = [x]
mergeSort xs    = let(l, r) = splitAt (length xs `quot` 2) xs
                  in mergeSortP (mergeSort l) (mergeSort r)

-- funkcja pomocnicza scalajÄ…ca dwie listy uporzÄ…dkowane w jednÄ…
mergeSortP :: Ord a => [a] -> [a] -> [a]
mergeSortP xs []            = xs
mergeSortP [] ys            = ys
mergeSortP (x:xs) (y:ys)
    | x <= y = x:(mergeSortP xs (y:ys))
    | otherwise = y:(mergeSortP (x:xs) ys)

-- Zadanie 10 - tree sort
treeSort :: Ord a => [a] -> [a]
-- pointless po raz drugi
treeSort = (treeSortInorder . treeSortToTree)

treeSortToTree :: Ord a => [a] -> Tree a
treeSortToTree []       = Leaf
treeSortToTree (x:xs)   = let (xlt, xgt) = foldl (\ (lt,gt) el -> case
compare x el of
                                                            GT -> (el:lt,
gt)
                                                            _  -> (lt,
el:gt) ) ([],[]) xs
                          in Node (treeSortToTree xlt) x (treeSortToTree
xgt)

treeSortInorder :: Ord a => Tree a -> [a]
treeSortInorder Leaf            = []
treeSortInorder (Node l x r)    = (treeSortInorder l) ++ [x] ++
(treeSortInorder r)

-- end code by Orcus



--
big_number = 1000000 :: Int


main = do
  gen <- getStdGen
  let xs' = randomRs (1::Int, big_number) gen
  xs <- return (take big_number xs')
  t1 <- getCPUTime
  print (qsort_i xs) -- i
  t2 <- getCPUTime
  print (qsort_ii xs) -- ii
  t3 <- getCPUTime
  print (qsort_iii xs) -- iii
  t4 <- getCPUTime
  print (qsort_iv xs) -- iv
  t5 <- getCPUTime
  print (qsort_v xs) -- v
  t6 <- getCPUTime
  print (qsort_vi xs) -- vi
  t7 <- getCPUTime
  print (qsort_vii xs) -- vii
  t8 <- getCPUTime
  print (sort xs) -- sort
  t9 <- getCPUTime
  print (mergeSort xs) -- mergeSort
  t10 <- getCPUTime
  print (treeSort xs) -- treeSort
  t11 <- getCPUTime
  let getTimes xs = zipWith (-) (tail xs) xs
  let timers = [t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11]
  let times = getTimes timers
  let table = zip times ["i","ii","iii","iv", "v", "vi", "vii",
"sort","mergeSort","treeSort"]
  let sorted = sort table
  let scaled = map (\(x,n) -> (((fromIntegral x / (fromIntegral $ fst (head
sorted)))::Double),n)) sorted
  let toShow = concatMap (\x-> show x ++ "\n") scaled
  hPutStr stderr toShow

main_small = do
  gen <- getStdGen
  let xs' = randomRs (1::Int, 100000) gen
  xs <- return (take big_number xs')
  t1 <- getCPUTime
  print (qsort_iv xs) -- iv
  t2 <- getCPUTime
  print (sort xs) -- sort
  t3 <- getCPUTime
  print (mergeSort xs) -- mergeSort
  t4 <- getCPUTime
  print (treeSort xs) -- treeSort
  t5 <- getCPUTime
  let getTimes xs = zipWith (-) (tail xs) xs
  let timers = [t1,t2,t3,t4,t5]
  let times = getTimes timers
  let table = zip times ["iv", "sort","mergeSort","treeSort"]
  let sorted = sort table
  let scaled = map (\(x,n) -> (((fromIntegral x / (fromIntegral $ fst (head
sorted)))::Double),n)) sorted
  let toShow = concatMap (\x-> show x ++ "\n") scaled
  hPutStr stderr toShow
  hPrint stderr times

--- cut here ---
-------------- next part --------------
An HTML attachment was scrubbed...
URL: http://www.haskell.org/pipermail/haskell-cafe/attachments/20080304/3d912e5d/attachment.htm