extra/benchmark/benchmark.factor

   1 ! Copyright (C) 2007, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays assocs command-line continuations debugger
   4 formatting help.markup io io.styles kernel math memory
   5 namespaces sequences tools.profiler.sampling tools.test
   6 tools.time vocabs.hierarchy vocabs.loader ;
   7 IN: benchmark
   8
   9 SYMBOL: benchmarks-disabled?
  10
  11 : run-timing-benchmark ( vocab -- time )
  12     5 swap '[ gc [ _ run ] benchmark ] replicate infimum ;
  13
  14 : run-profile-benchmark ( vocab -- profile )
  15     compact-gc '[ _ run ] profile most-recent-profile-data ;
  16
  17 : all-benchmark-vocabs ( -- seq )
  18     "benchmark" disk-child-vocab-names [ find-vocab-root ] filter ;
  19
  20 : find-benchmark-vocabs ( -- seq )
  21     benchmarks-disabled? get [
  22         "benchmarks-disabled? is true, not benchmarking anything!" print
  23         { }
  24     ] [
  25         command-line get [ all-benchmark-vocabs ] when-empty
  26     ] if ;
  27
  28 <PRIVATE
  29
  30 : write-header ( str -- )
  31     "=== %s\n" printf ;
  32
  33 : run-benchmark ( vocab quot: ( vocab -- res ) -- result ok? )
  34     over write-header '[ _ @ t ] [
  35         f f f <test-failure> f
  36     ] recover ; inline
  37
  38 PRIVATE>
  39
  40 : run-benchmarks ( benchmarks quot: ( vocab -- res ) -- results errors )
  41     '[ dup _ run-benchmark 3array ] map
  42     [ third ] partition [ [ 2 head ] map ] bi@ ; inline
  43
  44 : run-profile-benchmarks ( -- results errors )
  45     find-benchmark-vocabs [ run-profile-benchmark ] run-benchmarks ;
  46
  47 : run-timing-benchmarks ( -- results errors )
  48     find-benchmark-vocabs [ run-timing-benchmark ] run-benchmarks ;
  49
  50 : timings. ( assoc -- )
  51     standard-table-style [
  52         [
  53             [ "Benchmark" write ] with-cell
  54             [ "Time (seconds)" write ] with-cell
  55         ] with-row
  56         [
  57             [
  58                 [ [ 1array $vocab-link ] with-cell ]
  59                 [ 1,000,000,000 /f [ "%.3f" printf ] with-cell ]
  60                 bi*
  61             ] with-row
  62         ] assoc-each
  63     ] tabular-output nl ;
  64
  65 : benchmark-errors. ( assoc -- )
  66     [
  67         [ write-header ] [ error. ] bi*
  68     ] assoc-each ;
  69
  70 : timing-benchmarks ( -- )
  71     run-timing-benchmarks [ timings. ] [ benchmark-errors. ] bi* ;
  72
  73 MAIN: timing-benchmarks