forked from factor/factor
-
Notifications
You must be signed in to change notification settings - Fork 3
/
benchmark.factor
83 lines (66 loc) · 2.02 KB
/
benchmark.factor
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
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs continuations debugger fry help.markup io
io.styles kernel math memory namespaces prettyprint sequences
tools.profiler.sampling tools.time vocabs vocabs.hierarchy
vocabs.loader ;
IN: benchmark
<PRIVATE
SYMBOL: results
SYMBOL: errors
PRIVATE>
: run-timing-benchmark ( vocab -- time )
[ 5 ] dip '[ gc [ _ run ] benchmark ] replicate infimum ;
: run-profile-benchmark ( vocab -- profile )
compact-gc '[ _ run ] profile most-recent-profile-data ;
: find-benchmark-vocabs ( -- seq )
"benchmark" child-vocab-names
[ find-vocab-root ] filter ;
<PRIVATE
: print-record-header ( vocab -- )
"=== " write print flush ;
: run-benchmark ( vocab quot -- )
[ drop print-record-header ] [
'[
_ [ [ require ] _ [ ] tri results ]
[ swap errors ]
recover get set-at
] call
] 2bi ; inline
: run-benchmarks ( quot -- results errors )
'[
results errors
[ [ V{ } clone swap set ] bi@ ]
[ 2drop find-benchmark-vocabs [ _ run-benchmark ] each ]
[ [ get ] bi@ ]
2tri
] with-scope ; inline
PRIVATE>
: run-timing-benchmarks ( -- results errors )
[ run-timing-benchmark ] run-benchmarks ;
: run-profile-benchmarks ( -- results errors )
[ run-profile-benchmark ] run-benchmarks ;
: timings. ( assocs -- )
standard-table-style [
[
[ "Benchmark" write ] with-cell
[ "Time (seconds)" write ] with-cell
] with-row
[
[
[ [ 1array $vocab-link ] with-cell ]
[ 1,000,000,000 /f pprint-cell ]
bi*
] with-row
] assoc-each
] tabular-output nl ;
: benchmark-errors. ( errors -- )
[
[ "=== " write vocab-name print ]
[ error. ]
bi*
] assoc-each ;
: timing-benchmarks ( -- )
run-timing-benchmarks
[ timings. ] [ benchmark-errors. ] bi* ;
MAIN: timing-benchmarks