factor: trim using lists

[factor.git] / extra / benchmark / benchmark.factor

diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor
old mode 100755 (executable)
new mode 100644 (file)
index ca48e62..7ea83e1
--- a/extra/benchmark/benchmark.factor
+++ b/extra/benchmark/benchmark.factor
@@ -1,35 +1,53 @@
 ! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel vocabs vocabs.loader tools.time tools.vocabs
-arrays assocs io.styles io help.markup prettyprint sequences
-continuations debugger math namespaces ;
+USING: arrays assocs command-line continuations debugger
+formatting help.markup io io.styles kernel math memory
+namespaces sequences tools.profiler.sampling tools.test
+tools.time vocabs.hierarchy vocabs.loader ;
 IN: benchmark
 
+SYMBOL: benchmarks-disabled?
+
+: run-timing-benchmark ( vocab -- time )
+    5 swap '[ gc [ _ run ] benchmark ] replicate infimum ;
+
+: run-profile-benchmark ( vocab -- profile )
+    compact-gc '[ _ run ] profile most-recent-profile-data ;
+
+: all-benchmark-vocabs ( -- seq )
+    "benchmark" disk-child-vocab-names [ find-vocab-root ] filter ;
+
+: find-benchmark-vocabs ( -- seq )
+    benchmarks-disabled? get [
+        "benchmarks-disabled? is true, not benchmarking anything!" print
+        { }
+    ] [
+        command-line get [ all-benchmark-vocabs ] when-empty
+    ] if ;
+
 <PRIVATE
 
-SYMBOL: timings
-SYMBOL: errors
+: write-header ( str -- )
+    "=== %s\n" printf ;
+
+: run-benchmark ( vocab quot: ( vocab -- res ) -- result ok? )
+    over write-header '[ _ @ t ] [
+        f f f <test-failure> f
+    ] recover ; inline
 
 PRIVATE>
 
-: run-benchmark ( vocab -- )
-    [ "=== " write vocab-name print flush ] [
-        [ [ require ] [ [ run ] benchmark ] [ ] tri timings ]
-        [ swap errors ]
-        recover get set-at
-    ] bi ;
+: run-benchmarks ( benchmarks quot: ( vocab -- res ) -- results errors )
+    '[ dup _ run-benchmark 3array ] map
+    [ third ] partition [ [ 2 head ] map ] bi@ ; inline
 
-: run-benchmarks ( -- timings errors )
-    [
-        V{ } clone timings set
-        V{ } clone errors set
-        "benchmark" all-child-vocabs-seq
-        [ run-benchmark ] each
-        timings get
-        errors get
-    ] with-scope ;
-
-: timings. ( assocs -- )
+: run-profile-benchmarks ( -- results errors )
+    find-benchmark-vocabs [ run-profile-benchmark ] run-benchmarks ;
+
+: run-timing-benchmarks ( -- results errors )
+    find-benchmark-vocabs [ run-timing-benchmark ] run-benchmarks ;
+
+: timings. ( assoc -- )
     standard-table-style [
         [
             [ "Benchmark" write ] with-cell
@@ -38,21 +56,18 @@ PRIVATE>
         [
             [
                 [ [ 1array $vocab-link ] with-cell ]
-                [ 1000000 /f pprint-cell ]
+                [ 1,000,000,000 /f [ "%.3f" printf ] with-cell ]
                 bi*
             ] with-row
         ] assoc-each
     ] tabular-output nl ;
 
-: benchmark-errors. ( errors -- )
+: benchmark-errors. ( assoc -- )
     [
-        [ "=== " write vocab-name print ]
-        [ error. ]
-        bi*
+        [ write-header ] [ error. ] bi*
     ] assoc-each ;
 
-: benchmarks ( -- )
-    run-benchmarks [ timings. ] [ benchmark-errors. ] bi* ;
-
-MAIN: benchmarks
+: timing-benchmarks ( -- )
+    run-timing-benchmarks [ timings. ] [ benchmark-errors. ] bi* ;
 
+MAIN: timing-benchmarks