steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

benchmark: refactoring to not use dynamic variables + unit tests

db4
Björn Lindqvist 2015-12-17 17:09:00 +01:00
parent 119f188423
commit a738c356a0
2 changed files with 37 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
extra/benchmark/benchmark-tests.factor Normal file
View File

@ -0,0 +1,17 @@
USING: benchmark kernel sequences tools.test ;
IN: benchmark.tests
: dummy-benchmark ( -- )
;
MAIN: dummy-benchmark
{ "benchmark.tests" } [
{ "benchmark.tests" } [ run-timing-benchmark ] run-benchmarks
drop first first
] unit-test
{ 0 1 } [
{ "benchmark.tests" } [ drop "hello" throw ] run-benchmarks
[ length ] bi@
] unit-test

63
extra/benchmark/benchmark.factor
View File

@ -1,60 +1,40 @@
! 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 ;
USING: arrays assocs continuations debugger formatting fry help.markup
io io.styles kernel math memory prettyprint sequences
tools.profiler.sampling tools.time vocabs.hierarchy vocabs.loader ;
IN: benchmark
<PRIVATE
SYMBOL: results
SYMBOL: errors
PRIVATE>
: run-timing-benchmark ( vocab -- time )
[ 5 ] dip '[ gc [ _ run ] benchmark ] replicate infimum ;
5 swap '[ gc [ _ run ] benchmark ] replicate infimum ;
: run-profile-benchmark ( vocab -- profile )
compact-gc '[ _ run ] profile most-recent-profile-data ;
: find-benchmark-vocabs ( -- seq )
"benchmark" disk-child-vocab-names
[ find-vocab-root ] filter ;
"benchmark" disk-child-vocab-names [ find-vocab-root ] filter ;
<PRIVATE
: print-record-header ( vocab -- )
"=== " write print flush ;
: write-header ( str -- )
"=== %s\n" printf ;
: 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
: run-benchmark ( vocab quot: ( vocab -- res ) -- result ok? )
over write-header '[ _ @ t ] [ f ] recover ; inline
PRIVATE>
: run-timing-benchmarks ( -- results errors )
[ run-timing-benchmark ] run-benchmarks ;
: run-benchmarks ( benchmarks quot: ( vocab -- res ) -- results errors )
'[ dup _ run-benchmark 3array ] map
[ third ] partition [ [ 2 head ] map ] bi@ ; inline
: run-profile-benchmarks ( -- results errors )
[ run-profile-benchmark ] run-benchmarks ;
find-benchmark-vocabs [ run-profile-benchmark ] run-benchmarks ;
: timings. ( assocs -- )
: run-timing-benchmarks ( -- results errors )
find-benchmark-vocabs [ run-timing-benchmark ] run-benchmarks ;
: timings. ( assoc -- )
standard-table-style [
[
[ "Benchmark" write ] with-cell
@ -69,15 +49,12 @@ PRIVATE>
] assoc-each
] tabular-output nl ;
: benchmark-errors. ( errors -- )
: benchmark-errors. ( assoc -- )
[
[ "=== " write vocab-name print ]
[ error. ]
bi*
[ write-header ] [ error. ] bi*
] assoc-each ;
: timing-benchmarks ( -- )
run-timing-benchmarks
[ timings. ] [ benchmark-errors. ] bi* ;
run-timing-benchmarks [ timings. ] [ benchmark-errors. ] bi* ;
MAIN: timing-benchmarks