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
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
------------------------------------------------------------------------------
--- A DSL for benchmark descriptions embedded into Curry
---
--- @author Michael Hanus
--- @version February 2019
------------------------------------------------------------------------------

module Test.Benchmark
  ( Benchmark, benchmark, prepareBenchmarkCleanup,
    withPrepare, withCleanup,
    iterateBench, (*>),
    mapBench, pairBench, diffBench, (.-.),
    runOn, runUntilOn, runUntilNothingOn, execBench,
    benchTimeNF, benchCommandOutput,
    CmdResult, cmdResultAverage,
    exitStatus, elapsedTime, cpuTime, systemTime,
    maxResidentMemory,
    benchCommand, benchCommandWithLimit,
    elapsedTime4Command, cpuTime4Command,
    getHostName, getOS, getSystemID, getSystemRelease,
    getSystemDescription, getCoreNumber, getCPUModel
  )
 where

import Char
import IO
import IOExts
import Float
import List
import Maybe ( sequenceMaybe )
import ReadShowTerm
import System

import Debug.Profile

------------------------------------------------------------------------------
--- Representation of benchmarks.
--- A benchmark consists of some preparation, e.g., to generate
--- benchmark data, some final cleanup, and the benchmark itself.
--- If a benchmark is executed several times, the preparation and
--- cleanup work is done only once.
data Benchmark a = BM (IO ()) (IO ()) (IO a)

--- A benchmark is basically an I/O action to compute the benchmark results.
benchmark :: IO a -> Benchmark a
benchmark bench = BM done done bench

--- Benchmarks have a monadic structure.
instance Monad Benchmark where
  bench1 >>= abench2 = BM done done $
    execBench bench1 >>= \x -> execBench (abench2 x)

  return x = benchmark (return x)

--- Maps benchmark results according to a given mapping (first argument).
mapBench :: (a -> b) -> Benchmark a -> Benchmark b
mapBench f (BM pre post action) = BM pre post $ action >>= return . f

instance Functor Benchmark where
  fmap f (BM pre post action) = BM pre post $ action >>= return . f

--- Combines two benchmarks to a single benchmark where the results
--- are paired.
pairBench :: Benchmark a -> Benchmark b -> Benchmark (a,b)
pairBench bench1 bench2 = BM done done $
  execBench bench1 >>= \x -> execBench bench2 >>= \y -> return (x,y)


--- Adds some initial preparation action to a benchmark, e.g., to generate
--- benchmark data.
--- If the benchmark already contains some preparation, this new
--- preparation is executed first.
withPrepare :: Benchmark a -> IO () -> Benchmark a
withPrepare (BM pre post bench) newpre = BM (newpre >> pre) post bench

--- Adds some final cleanup action to a benchmark.
--- If the benchmark already contains some cleanup action, this new
--- cleanup is executed last.
withCleanup :: Benchmark a -> IO () -> Benchmark a
withCleanup (BM pre post bench) newpost = BM pre (post >> newpost) bench

--- A benchmark with some preparation and some final cleanup.
--- In this case, the preparation and cleanup work tightly belongs
--- to the benchmark, i.e., it is repeated with every iteration of
--- the benchmark.
prepareBenchmarkCleanup :: IO () -> IO a -> IO () -> Benchmark a
prepareBenchmarkCleanup pre bench post =
  BM done done (execBench (BM pre post bench))

------------------------------------------------------------------------------
-- Repeatable benchmarks

--- The class of benchmark results which supports multiple runs by
--- computing the average of a non-empty(!) list of multiple results.
class MultiRunnable a where
  average :: [a] -> a

instance MultiRunnable Int where
  average xs = foldr (+) 0 xs `div` (length xs)

instance MultiRunnable Float where
  average xs = foldr (+) 0.0 xs / fromInt (length xs)

instance MultiRunnable a => MultiRunnable (Maybe a) where
  average = maybe Nothing (Just . average) . sequenceMaybe

--- Iterates a benchmark multiple times and computes the average result.
--- The preparation and cleanup actions of the benchmark are
--- only executed once, i.e., they are not iterated.
--- The number of executions (first argument) must be postive.
(*>) :: MultiRunnable a => Int -> Benchmark a -> Benchmark a
num *> (BM pre post action) = BM pre post $
  mapIO (\_ -> action) [1 .. num] >>= \rs -> return (average rs)

--- Iterates a benchmark multiple times and computes the average according
--- to a given average function (first argument).
--- The preparation and cleanup actions of the benchmark are
--- only executed once, i.e., they are not iterated.
iterateBench :: ([a] -> b) -> Int -> Benchmark a -> Benchmark b
iterateBench averagef n (BM pre post action) = BM pre post $
  mapIO (\_ -> action) [1..n] >>= \rs -> return (averagef rs)

------------------------------------------------------------------------------

--- Computes the difference between two benchmarks according to a given
--- difference operation (first argument).
--- This could be useful to evaluate some kernel of a computation where
--- the ressources to prepare the benchmark data are measured by
--- a separate benchmark and subtracted with this operation.
diffBench :: (a -> a -> a) -> Benchmark a -> Benchmark a -> Benchmark a
diffBench minus bench1 bench2 =
  mapBench (uncurry minus) (pairBench bench1 bench2)

--- Computes the numeric difference between two Float-valued benchmarks.
--- This could be useful to evaluate some kernel of a computation where
--- the resources to prepare the benchmark data are measured by
--- a separate benchmark and subtracted with this operation.
(.-.) :: Benchmark Float -> Benchmark Float -> Benchmark Float
bench1 .-. bench2 = diffBench (-.) bench1 bench2

--- Runs a parameterized benchmark on a list of input data.
--- The result is a benchmark returning a list of pairs consisting
--- of the input data and the benchmark result for this input data.
---
--- @param bench - the benchmark parameterized by the input data
--- @param benchdata - the list of input data for the benchmarks
--- @return Benchmark with the list of input data and benchmark results pairs
runOn :: (a -> Benchmark b) -> [a] -> Benchmark [(a,b)]
runOn bench xs = BM done done $
  mapIO (\x -> execBench (bench x) >>= \y -> return (x,y)) xs

--- Runs a `Maybe` benchmark on an (infinite) input list of values
--- until a benchmark delivers `Nothing`.
---
--- @param bench - the `Maybe` benchmark parameterized by the input data
--- @param benchdata - the list of input data for the benchmarks
--- @return Benchmark with the list of input data and benchmark results pairs
runUntilOn :: (a -> Benchmark b) -> (b -> Bool) -> [a] -> Benchmark [(a,b)]
runUntilOn _ _ [] = return []
runUntilOn bench stop (x:xs) = do
  bmresult <- bench x
  if stop bmresult
    then return []
    else do results <- runUntilOn bench stop xs
            return ((x,bmresult):results)

--- Run a `Maybe` benchmark on an (infinite) input list of values
--- until a benchmark delivers `Nothing`.
---
--- @param bench - the `Maybe` benchmark parameterized by the input data
--- @param benchdata - the list of input data for the benchmarks
--- @return Benchmark with the list of input data and benchmark results pairs
runUntilNothingOn :: Eq b => (a -> Benchmark (Maybe b)) -> [a]
                          -> Benchmark [(a,b)]
runUntilNothingOn bench benchdata =
  mapBench (map (\ (x,Just y) -> (x,y)))
           (runUntilOn bench (==Nothing) benchdata)

--- Executes a benchmark and returns the benchmark results.
execBench :: Benchmark a -> IO a
execBench (BM pre post action) = do
  pre
  result <- action
  post
  return result

-----------------------------------------------------------------
-- Now we define some constructors to create concrete benchmarks.
-----------------------------------------------------------------
-- A quite simple constructor for internal tests of the Curry system.

--- Benchmark the time (in seconds)
--- to compute the normal form of an expression.
--- The expression is created by an I/O action (first parameter).
--- This avoids the sharing of the normalization process between multiple
--- runs of the benchmark and provides more flexibility, e.g.,
--- to read benchmark input data from global variables.
benchTimeNF :: IO a -> Benchmark Float
benchTimeNF getexp = benchmark $ do
  garbageCollect
  garbageCollectorOff
  pi1 <- getProcessInfos
  exp <- getexp
  seq (id $!! exp) done
  pi2 <- getProcessInfos
  garbageCollectorOn
  let rtime = maybe 0 id (lookup RunTime pi2)
              - maybe 0 id (lookup RunTime pi1)
  return (i2f rtime /. 1000.0)

-----------------------------------------------------------------
-- Benchmarks returning the output of system commands.

--- This operation constructs a benchmark that simply returns
--- the output of a shell command. To be more precise,
--- the constructed benchmark contains as a result the exit status and
--- the standard and error output string produced by the execution
--- of the given shell command (provided as the argument).
benchCommandOutput :: String -> Benchmark (Int,String,String)
benchCommandOutput cmd = benchmark $ evalCmd cmd [] ""

-----------------------------------------------------------------
-- Benchmarks for timing system commands.

--- The result type for benchmarks timing the executing a shell command.
--- Currently, a result contains the command, exit status, elapsed time,
--- cpu time, system time (in seconds), and the maximum resident size
--- (in Kilobytes).
data CmdResult = CD String Int Float Float Float Int

--- The average of a non-empty list of command benchmark results.
--- The exit status average is zero of all are zero.
instance MultiRunnable CmdResult where
  average cds =
    CD (if null cds then "" else (cmdString (head cds)))
       (if all (==0) (map exitStatus cds) then 0 else 1)
       (average (map elapsedTime cds))
       (average (map cpuTime     cds))
       (average (map systemTime  cds))
       (average (map maxResidentMemory cds))

--- The average of a list of command benchmark results.
--- The exit status average is zero of all are zero.
cmdResultAverage :: [CmdResult] -> CmdResult
cmdResultAverage = average

--- The command string of the command benchmark result.
cmdString :: CmdResult -> String
cmdString (CD cs _ _ _ _ _) = cs

--- The exit status of the command benchmark result.
exitStatus :: CmdResult -> Int
exitStatus (CD _ s _ _ _ _) = s

--- The elapsed time (in seconds) of the command benchmark result.
--- If the exit status is non-zero, an error is raised.
elapsedTime :: CmdResult -> Float
elapsedTime (CD cs s e _ _ _) =
  if s==0 then e
          else error ("Benchmark command '"++cs++"' has exit status "++show s)

--- The cpu time (in seconds) of the command benchmark result.
--- If the exit status is non-zero, an error is raised.
cpuTime :: CmdResult -> Float
cpuTime (CD cs s _ c _ _) =
  if s==0 then c
          else error ("Benchmark command '"++cs++"' has exit status "++show s)

--- The system time (in seconds) of the command benchmark result.
--- If the exit status is non-zero, an error is raised.
systemTime :: CmdResult -> Float
systemTime (CD cs s _ _ st _) =
  if s==0 then st
          else error ("Benchmark command '"++cs++"' has exit status "++show s)

--- The maximum resident size (in Kilobytes) of the command benchmark result.
--- If the exit status is non-zero, an error is raised.
maxResidentMemory :: CmdResult -> Int
maxResidentMemory (CD cs s _ _ _ m) =
  if s==0 then m
          else error ("Benchmark command '"++cs++"' has exit status "++show s)

--- Benchmark the execution of a shell command.
--- Returns benchmark results containing the exit status, elapsed time,
--- cpu time, system time, and the maximum resident size (in Kilobytes).
benchCommand :: String -> Benchmark CmdResult
benchCommand cmd = benchmark $ do
  pid <- getPID
  let timefile = ".time"++show pid
      timecmd = "/usr/bin/time -q --format=\"BENCHMARKTIME=(%e,%U,%S,%M)\" -o "
                  ++timefile++" "++cmd
  --putStrLn $ "TIMECMD: "++timecmd
  status <- system timecmd
  bmout <- readCompleteFile timefile
  let (etime,ctime,stime,maxmem) = readQTerm (extractTimeInOutput bmout)
  system $ "rm -f "++timefile
  --putStrLn $ "RESULT: " ++ show (CD cmd status etime ctime stime maxmem)
  return (CD cmd status etime ctime stime maxmem)
 where
  -- extract benchmark time from timing output:
  extractTimeInOutput =
    tail . snd . break (=='=') . head . filter ("BENCHMARKTIME" `isPrefixOf`)
         . lines

--- Benchmark the elapsed time (in seconds) to execute a shell command.
elapsedTime4Command :: String -> Benchmark Float
elapsedTime4Command = mapBench elapsedTime . benchCommand

--- Benchmark the cpu time (in seconds) to execute a shell command.
cpuTime4Command :: String -> Benchmark Float
cpuTime4Command = mapBench cpuTime . benchCommand

--- Benchmark the execution of a shell command where
--- a maximum time limit for the execution (in seconds) is given.
--- Returns `Nothing`, if the time limit is reached or the command terminated
--- with a non-zero exit code, or `Just` the benchmark results.
benchCommandWithLimit :: String -> Float -> Benchmark (Maybe CmdResult)
benchCommandWithLimit cmd tlimit =
  mapBench (\cd -> if exitStatus cd == 0 then Just cd else Nothing)
           (benchCommand $ "/usr/bin/timeout "++show tlimit++"s "++cmd)


-----------------------------------------------------------------
-- Get system specific infos.
-- The current implementations work for Linux.
-- Other operating system might require other implementations of these
-- operations.

--- Retrieve the host name.
getHostName :: IO String
getHostName = runCmd "hostname"

--- Retrieve the operating system name (e.g., "Linux").
getOS :: IO String
getOS = runCmd "uname -o"

--- Retrieve the operating system description (e.g., "Ubuntu 12.04.3 LTS").
getSystemDescription :: IO String
getSystemDescription = runCmd "lsb_release -s -d"

--- Retrieve the operating system id (e.g., "Ubuntu").
getSystemID :: IO String
getSystemID = runCmd "lsb_release -s -i"

--- Retrieve the operating system release (e.g., "12.04").
getSystemRelease :: IO String
getSystemRelease = runCmd "lsb_release -s -r"

--- Retrieve the number of cores.
--- Implemented by counting the processor entries in /proc/cpuinfo
getCoreNumber :: IO String
getCoreNumber =
  readFile "/proc/cpuinfo" >>=
    return . show . length . filter (\ s -> take 9 s == "processor") . lines

--- Retrieve the model of the CPU (e.g., "Intel(R) Core(TM) i5 CPU...").
--- Implemented by look up the model name in /proc/cpuinfo.
--- The copyright and trademark abbreviations are omitted.
getCPUModel :: IO String
getCPUModel = do
  cpuinfo <- readFile "/proc/cpuinfo"
  let modelnames = filter (\ s -> take 2 (words s) == ["model","name"])
                          (lines cpuinfo)
  return (if null modelnames
          then "???"
          else let (_,mname) = break (==':') (head modelnames)
                in if null mname then "???"
                                 else strip (delCRTM (tail mname)))
 where
  delCRTM s = case s of
    []                 -> []
    '(':'R':')':xs     -> delCRTM xs
    '(':'T':'M':')':xs -> delCRTM xs
    x:xs               -> x : delCRTM xs

-----------------------------------------------------------------
-- Auxiliaries:

--- Run the command and returns stdout output
runCmd :: String -> IO String
runCmd cmd = connectToCommand cmd >>= hGetContents >>= return . strip

--- Remove leading and trailing whitespace
strip :: String -> String
strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace

-----------------------------------------------------------------