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 continuations debugger fry help.markup io
   4 io.styles kernel math memory namespaces prettyprint sequences
   5 tools.profiler.sampling tools.time vocabs vocabs.hierarchy
   6 vocabs.loader ;
   7 IN: benchmark
   8
   9 <PRIVATE
  10
  11 SYMBOL: results
  12 SYMBOL: errors
  13
  14 PRIVATE>
  15
  16 : run-timing-benchmark ( vocab -- time )
  17     [ 5 ] dip '[ gc [ _ run ] benchmark ] replicate infimum ;
  18
  19 : run-profile-benchmark ( vocab -- profile )
  20     compact-gc '[ _ run ] profile most-recent-profile-data ;
  21
  22 : find-benchmark-vocabs ( -- seq )
  23     "benchmark" child-vocab-names
  24     [ find-vocab-root ] filter ;
  25
  26 <PRIVATE
  27
  28 : print-record-header ( vocab -- )
  29     "=== " write print flush ;
  30
  31 : run-benchmark ( vocab quot -- )
  32     [ drop print-record-header ] [
  33         '[
  34             _ [ [ require ] _ [ ] tri results ]
  35             [ swap errors ]
  36             recover get set-at
  37         ] call
  38     ] 2bi ; inline
  39
  40 : run-benchmarks ( quot -- results errors )
  41     '[
  42         results errors
  43         [ [ V{ } clone swap set ] bi@ ]
  44         [ 2drop find-benchmark-vocabs [ _ run-benchmark ] each ]
  45         [ [ get ] bi@ ]
  46         2tri
  47     ] with-scope ; inline
  48
  49 PRIVATE>
  50
  51 : run-timing-benchmarks ( -- results errors )
  52     [ run-timing-benchmark ] run-benchmarks ;
  53
  54 : run-profile-benchmarks ( -- results errors )
  55     [ run-profile-benchmark ] run-benchmarks ;
  56
  57 : timings. ( assocs -- )
  58     standard-table-style [
  59         [
  60             [ "Benchmark" write ] with-cell
  61             [ "Time (seconds)" write ] with-cell
  62         ] with-row
  63         [
  64             [
  65                 [ [ 1array $vocab-link ] with-cell ]
  66                 [ 1,000,000,000 /f pprint-cell ]
  67                 bi*
  68             ] with-row
  69         ] assoc-each
  70     ] tabular-output nl ;
  71
  72 : benchmark-errors. ( errors -- )
  73     [
  74         [ "=== " write vocab-name print ]
  75         [ error. ]
  76         bi*
  77     ] assoc-each ;
  78
  79 : timing-benchmarks ( -- )
  80     run-timing-benchmarks
  81     [ timings. ] [ benchmark-errors. ] bi* ;
  82
  83 MAIN: timing-benchmarks