1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161 | {-# OPTIONS -Wall -XScopedTypeVariables -XBangPatterns #-}
-- Compiling ghc --make -O2 Benchmark
--
-- Running ./Benchmark +RTS -K32388608 -RTS >/dev/null
module Main where
import qualified ArrayMergesort as Array
import qualified System.Random as Rand
import qualified Data.List as List
import qualified Control.Monad as Monad
import qualified Data.Char as Ch
import qualified System.CPUTime as Time
import qualified System.IO as SysIO
import qualified System.Mem as Mem
main :: IO ()
main =
do -- let (intBench, stringBench) = fastBench
let (intBench, stringBench) = fullBench
intResults <- benchmarkAll intsAdInfinitum "Int" intBench
strResults <- benchmarkAll intsAdInfinitum "String" stringBench
putErrorStrLn $ showTable "Int sort results" intResults
putErrorStrLn $ showTable "String sort results" strResults
return ()
fastBench' :: ([(Int, Int)], [(Int, Int)])
fastBench' = (intBench, strBench) where
intBench = [ (1, 30000), (100, 2000), (10, 20000) ]
strBench = [ (10000, 10), (100, 1000), (10, 10000) ]
fastBench :: ([(Int, Int)], [(Int, Int)])
fastBench = (lessIterations intBench, lessIterations strBench) where
lessIterations xs = map (\(x, y) -> (x `div` 10 + 1, y)) xs
(intBench, strBench) = fullBench
fullBench :: ([(Int, Int)], [(Int, Int)])
fullBench = (intBench, strBench) where
intBench = [ (25000, 10)
, (50000, 10)
, (100000, 10)
, (25000, 20)
, (10000, 40)
, (10000, 50)
, (10000, 75)
, (5000, 100)
, (5000, 200)
, (2000, 400)
, (2000, 600)
, (2000, 800)
, (1000, 1000)
, (20, 10000)
, (5, 100000)
, (2, 1000000)
]
strBench = [ (10000, 10)
, (20000, 10)
, (40000, 10)
, (10000, 20)
, (5000, 50)
, (5000, 100)
, (2000, 200)
, (1000, 400)
, (750, 600)
, (500, 800)
, (500, 1000)
, (10, 10000)
, (5, 100000)
]
showTable :: (Show a) => String -> [[a]] -> String
showTable caption xs =
let tag name value = " <" ++ name ++ ">" ++ value ++ "</" ++ name ++ "> "
row ys = tag "tr" (concatMap (tag "td" . show) ys)
allRows = unlines $ map row xs
headerTitles = [ "Iterations", "Number of elements", "Data.List.sort (ms)"
, "Array sort (ms)", "Speedup (%)"]
header = tag "tr" (concatMap (tag "th") headerTitles)
in tag "p" $ tag "center"
("<table border=\"1\">" ++
(tag "caption" caption ++ "\n"
++ header ++ "\n"
++ allRows)
++ "</table>")
benchmarkAll :: (Show a, Ord a) =>
(Rand.StdGen -> [a]) -> String -> [(Int, Int)]
-> IO [[Int]]
benchmarkAll f sortType xs =
do let initialSeed = 326187
gen = Rand.mkStdGen initialSeed
seeds = intsAdInfinitum gen
benchmark ((iterations, numElements), seed)
= do putErrorStrLn ""
putErrorStrLn ("Sorting " ++ show numElements ++ " " ++ sortType ++ "s " ++
show iterations ++ " times")
benchmarkSortFunctions iterations numElements seed f
mapM benchmark (zip xs seeds)
benchmarkSortFunctions :: (Ord a, Show a) =>
Int -> Int -> Int -> (Rand.StdGen -> [a])
-> IO [Int]
benchmarkSortFunctions iterations numElements seed f =
do let gen = Rand.mkStdGen seed
unconcat n xs = take n xs : (unconcat n $ drop n xs)
randomValues = take iterations $ unconcat numElements $ f gen
sortWith name g =
do -- We are forcing for each algorithm. This way, the same
-- values will be fresh in the cache for each algorithm.
forceEvaluation randomValues
t <- timed $ mapM_ (forceEvaluation . g) randomValues
putErrorStrLn (name ++ " sort took: " ++ show t ++ " miliseconds")
return t
arrayElapsed <- {-# SCC "arraysort" #-} sortWith "Array" Array.mergeSort
ghcSortElapsed <- {-# SCC "ghcsort" #-} sortWith "GHC's" List.sort
let speedUp = (100 * (ghcSortElapsed - arrayElapsed)) `div` ghcSortElapsed
return [iterations, numElements, ghcSortElapsed, arrayElapsed, speedUp]
putErrorStrLn :: String -> IO ()
putErrorStrLn = SysIO.hPutStrLn SysIO.stderr
forceEvaluation :: (Show a) => a -> IO ()
forceEvaluation x =
do print x
SysIO.hFlush SysIO.stdout
-- Result in miliseconds
timed :: IO a -> IO Int
timed io =
do Mem.performGC
before <- Time.getCPUTime
io
Mem.performGC
after <- Time.getCPUTime
return $ fromInteger ((after - before) `div` (10 ::Integer) ^ (9 :: Integer))
intsAdInfinitum :: Rand.StdGen -> [Int]
intsAdInfinitum gen = Rand.randomRs (min', max') gen where
min', max' :: Int
min' = 1
max' = 10 * 1000 * 1000
stringsAdInfinitum :: Rand.StdGen -> [String]
stringsAdInfinitum gen = helper lengths chars
where
minLength = 1
maxLength = 10
lengths = Rand.randomRs (minLength, maxLength) gen
chars = Rand.randomRs ('A', 'z') gen
helper :: [Int] -> [Char] -> [String]
helper [] _ = error "There should always be more ints."
helper (l:ls) cs = let (xs, rest) = List.splitAt l cs
in xs : (helper ls rest)
|