diff options
Diffstat (limited to 'benchmark-suite')
26 files changed, 2782 insertions, 0 deletions
diff --git a/benchmark-suite/ChangeLog-2008 b/benchmark-suite/ChangeLog-2008 new file mode 100644 index 000000000..fcfedc2de --- /dev/null +++ b/benchmark-suite/ChangeLog-2008 @@ -0,0 +1,89 @@ +2008-04-17 Ludovic Courtès <ludo@gnu.org> + + * Makefile.am (SCM_BENCHMARKS): Add `benchmarks/read.bm'. + * benchmarks/read.bm: New file. + +2008-01-22 Neil Jerram <neil@ossau.uklinux.net> + + * COPYING: Removed. + +2006-11-17 Neil Jerram <neil@ossau.uklinux.net> + + * README: Note need for subscription to bug-guile@gnu.org. + +2006-05-02 Marius Vollmer <mvo@zagadka.de> + + * Makefile.am (SCM_BENCHMARKS_DIRS, dist-hook): Removed, they are + no longer needed and lead to unclean tarballs. + +2004-01-23 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de> + + * lib.scm: Extracted '/i' to toplevel. Print the guile version + number before the benchmarks are run. Print the framework-time + per iteration as an inexact number. + +2004-01-06 Marius Vollmer <marius.vollmer@uni-dortmund.de> + + * lib.scm (print-result, print-user-result): Handle exact + fractions. + +2003-05-27 Dirk Herrmann <D.Herrmann@tu-bs.de> + + * lib.scm: Fix some typos in the documentation. + +2002-09-14 Rob Browning <rlb@defaultvalue.org> + + * .cvsignore: new file. + +2002-07-26 Marius Vollmer <marius.vollmer@uni-dortmund.de> + + * Makefile.am (SCM_BENCHMARKS): List the real benchmarks, not foo + and bar. + (SCM_BENCHMARKS_DIRS): Uncommented, with an empty value. + (dist-hook): Use quotes so that an empty SCM_BENCHMARKS_DIRS works. + +2002-07-21 Dirk Herrmann <D.Herrmann@tu-bs.de> + + * lib.scm (print-result, print-user-result): Changed the + reporter's outputs to use symbols rather than strings to document + the individual values. Thanks to Neil Jerram for the suggestion. + +2002-07-21 Dirk Herrmann <D.Herrmann@tu-bs.de> + + * benchmarks/0-reference.bm: Added as a reference benchmark to be + used to calibrate iteration counts. + + * lib.scm: Added documentation. Added some initialization + messages. + + (benchmark-time-base, benchmark-total-time, benchmark-user-time, + benchmark-system-time, benchmark-frame-time, benchmark-core-time, + benchmark-user-time\interpreter, benchmark-core-time\interpreter): + Exported. + + (benchmark-time-base, time-base): Renamed time-base to + benchmark-time-base and introduced new time-base as a short-cut. + + (total-time, benchmark-total-time, user-time, benchmark-user-time, + system-time, benchmark-system-time, frame-time, + benchmark-frame-time, benchmark-time, benchmark-core-time, + user-time\interpreter, benchmark-user-time\interpreter, + benchmark-time\interpreter, benchmark-core-time\interpreter, + print-result, print-user-result): Renamed <foo>-time to + benchmark-<foo>-time. Exceptions: benchmark-time and + benchmark-time\interpreter were renamed to benchmark-core-time and + benchmark-core-time\interpreter, respectively. + +2002-07-20 Dirk Herrmann <D.Herrmann@tu-bs.de> + + * COPYING, README, Makefile.am, lib.scm, guile-benchmark: Copied + from the test-suite directory, renamed and adapted for use with + benchmarks. + + * benchmarks/logand.bm, benchmarks/continuations.bm, + benchmarks/if.bm: Added as initial fairly stupid examples for + benchmarks. + +2002-07-20 Dirk Herrmann <D.Herrmann@tu-bs.de> + + * Log begins. diff --git a/benchmark-suite/Makefile.am b/benchmark-suite/Makefile.am new file mode 100644 index 000000000..47bd0365d --- /dev/null +++ b/benchmark-suite/Makefile.am @@ -0,0 +1,24 @@ +SCM_BENCHMARKS = benchmarks/0-reference.bm \ + benchmarks/arithmetic.bm \ + benchmarks/bytevector-io.bm \ + benchmarks/bytevectors.bm \ + benchmarks/chars.bm \ + benchmarks/continuations.bm \ + benchmarks/hash.bm \ + benchmarks/if.bm \ + benchmarks/logand.bm \ + benchmarks/ports.bm \ + benchmarks/r6rs-arithmetic.bm \ + benchmarks/read.bm \ + benchmarks/srfi-1.bm \ + benchmarks/srfi-13.bm \ + benchmarks/structs.bm \ + benchmarks/subr.bm \ + benchmarks/vectors.bm \ + benchmarks/vlists.bm \ + benchmarks/write.bm \ + benchmarks/strings.bm + +EXTRA_DIST = guile-benchmark benchmark-suite/lib.scm \ + $(SCM_BENCHMARKS) \ + ChangeLog-2008 diff --git a/benchmark-suite/README b/benchmark-suite/README new file mode 100644 index 000000000..186a74351 --- /dev/null +++ b/benchmark-suite/README @@ -0,0 +1,18 @@ +This directory contains some benchmarks for Guile, and some generic +benchmarking support code. + +To run these benchmarks, you will need a version of Guile more recent +than 15 Feb 1999 --- the benchmarks use the (ice-9 and-let*) and +(ice-9 getopt-long) modules, which were added to Guile around then. + +For information about how to run the benchmark suite, read the usage +instructions in the comments at the top of the guile-benchmark script. + +You can reference the file `lib.scm' from your own code as the module +(benchmark-suite lib); it also has comments at the top and before each +function explaining what's going on. + +Please write more Guile benchmarks, and send them to bug-guile@gnu.org. +We'll merge them into the distribution. All benchmark suites must be +licensed for our use under the GPL, but I don't think we're going to +collect assignment papers for them. diff --git a/benchmark-suite/benchmark-suite/lib.scm b/benchmark-suite/benchmark-suite/lib.scm new file mode 100644 index 000000000..ae57cc02a --- /dev/null +++ b/benchmark-suite/benchmark-suite/lib.scm @@ -0,0 +1,493 @@ +;;;; benchmark-suite/lib.scm --- generic support for benchmarking +;;;; Copyright (C) 2002, 2006, 2011, 2012 Free Software Foundation, Inc. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3, or (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this software; see the file COPYING.LESSER. +;;;; If not, write to the Free Software Foundation, Inc., 51 Franklin +;;;; Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (benchmark-suite lib) + #:use-module (srfi srfi-9) + #:export (;; Controlling the execution. + iteration-factor + scale-iterations + + ;; Running benchmarks. + run-benchmark + benchmark + + ;; Naming groups of benchmarks in a regular fashion. + with-benchmark-prefix with-benchmark-prefix* + current-benchmark-prefix format-benchmark-name + + ;; <benchmark-result> accessors + benchmark-result:name + benchmark-result:iterations + benchmark-result:real-time + benchmark-result:run-time + benchmark-result:gc-time + benchmark-result:core-time + + ;; Reporting results in various ways. + report current-reporter + register-reporter unregister-reporter reporter-registered? + make-log-reporter + full-reporter + user-reporter)) + + +;;;; If you're using Emacs's Scheme mode: +;;;; (put 'with-benchmark-prefix 'scheme-indent-function 1) +;;;; (put 'benchmark 'scheme-indent-function 1) + + +;;;; CORE FUNCTIONS +;;;; +;;;; The function (run-benchmark name iterations thunk) is the heart of the +;;;; benchmarking environment. The first parameter NAME is a unique name for +;;;; the benchmark to be executed (for an explanation of this parameter see +;;;; below under ;;;; NAMES. The second parameter ITERATIONS is a positive +;;;; integer value that indicates how often the thunk shall be executed (for +;;;; an explanation of how iteration counts should be used, see below under +;;;; ;;;; ITERATION COUNTS). For example: +;;;; +;;;; (run-benchmark "small integer addition" 100000 (lambda () (+ 1 1))) +;;;; +;;;; This will run the function (lambda () (+ 1 1)) a 100000 times (the +;;;; iteration count can, however be scaled. See below for details). Some +;;;; different time data for running the thunk for the given number of +;;;; iterations is measured and reported. +;;;; +;;;; Convenience macro +;;;; +;;;; * (benchmark name iterations body) is a short form for +;;;; (run-benchmark name iterations (lambda () body)) + + +;;;; NAMES +;;;; +;;;; Every benchmark in the benchmark suite has a unique name to be able to +;;;; compare the results of individual benchmarks across several runs of the +;;;; benchmark suite. +;;;; +;;;; A benchmark name is a list of printable objects. For example: +;;;; ("ports.scm" "file" "read and write back list of strings") +;;;; ("ports.scm" "pipe" "read") +;;;; +;;;; Benchmark names may contain arbitrary objects, but they always have +;;;; the following properties: +;;;; - Benchmark names can be compared with EQUAL?. +;;;; - Benchmark names can be reliably stored and retrieved with the standard +;;;; WRITE and READ procedures; doing so preserves their identity. +;;;; +;;;; For example: +;;;; +;;;; (benchmark "simple addition" 100000 (+ 2 2)) +;;;; +;;;; In that case, the benchmark name is the list ("simple addition"). +;;;; +;;;; The WITH-BENCHMARK-PREFIX syntax and WITH-BENCHMARK-PREFIX* procedure +;;;; establish a prefix for the names of all benchmarks whose results are +;;;; reported within their dynamic scope. For example: +;;;; +;;;; (begin +;;;; (with-benchmark-prefix "basic arithmetic" +;;;; (benchmark "addition" 100000 (+ 2 2)) +;;;; (benchmark "subtraction" 100000 (- 4 2))) +;;;; (benchmark "multiplication" 100000 (* 2 2)))) +;;;; +;;;; In that example, the three benchmark names are: +;;;; ("basic arithmetic" "addition"), +;;;; ("basic arithmetic" "subtraction"), and +;;;; ("multiplication"). +;;;; +;;;; WITH-BENCHMARK-PREFIX can be nested. Each WITH-BENCHMARK-PREFIX +;;;; appends a new element to the current prefix: +;;;; +;;;; (with-benchmark-prefix "arithmetic" +;;;; (with-benchmark-prefix "addition" +;;;; (benchmark "integer" 100000 (+ 2 2)) +;;;; (benchmark "complex" 100000 (+ 2+3i 4+5i))) +;;;; (with-benchmark-prefix "subtraction" +;;;; (benchmark "integer" 100000 (- 2 2)) +;;;; (benchmark "complex" 100000 (- 2+3i 1+2i)))) +;;;; +;;;; The four benchmark names here are: +;;;; ("arithmetic" "addition" "integer") +;;;; ("arithmetic" "addition" "complex") +;;;; ("arithmetic" "subtraction" "integer") +;;;; ("arithmetic" "subtraction" "complex") +;;;; +;;;; To print a name for a human reader, we DISPLAY its elements, +;;;; separated by ": ". So, the last set of benchmark names would be +;;;; reported as: +;;;; +;;;; arithmetic: addition: integer +;;;; arithmetic: addition: complex +;;;; arithmetic: subtraction: integer +;;;; arithmetic: subtraction: complex +;;;; +;;;; The Guile benchmarks use with-benchmark-prefix to include the name of +;;;; the source file containing the benchmark in the benchmark name, to +;;;; provide each file with its own namespace. + + +;;;; ITERATION COUNTS +;;;; +;;;; Every benchmark has to be given an iteration count that indicates how +;;;; often it should be executed. The reason is, that in most cases a single +;;;; execution of the benchmark code would not deliver usable timing results: +;;;; The resolution of the system time is not arbitrarily fine. Thus, some +;;;; benchmarks would be executed too quickly to be measured at all. A rule +;;;; of thumb is, that the longer a benchmark runs, the more exact is the +;;;; information about the execution time. +;;;; +;;;; However, execution time depends on several influences: First, the +;;;; machine you are running the benchmark on. Second, the compiler you use. +;;;; Third, which compiler options you use. Fourth, which version of guile +;;;; you are using. Fifth, which guile options you are using (for example if +;;;; you are using the debugging evaluator or not). There are even more +;;;; influences. +;;;; +;;;; For this reason, the same number of iterations for a single benchmark may +;;;; lead to completely different execution times in different +;;;; constellations. For someone working on a slow machine, the default +;;;; execution counts may lead to an inacceptable execution time of the +;;;; benchmark suite. For someone on a very fast machine, however, it may be +;;;; desireable to increase the number of iterations in order to increase the +;;;; accuracy of the time data. +;;;; +;;;; For this reason, the benchmark suite allows to scale the number of +;;;; executions by a global factor, stored in the exported variable +;;;; iteration-factor. The default for iteration-factor is 1. A number of 2 +;;;; means, that all benchmarks are executed twice as often, which will also +;;;; roughly double the execution time for the benchmark suite. Similarly, if +;;;; iteration-factor holds a value of 0.5, only about half the execution time +;;;; will be required. +;;;; +;;;; It is probably a good idea to choose the iteration count for each +;;;; benchmark such that all benchmarks will take about the same time, for +;;;; example one second. To achieve this, the benchmark suite holds an empty +;;;; benchmark in the file 0-reference.bm named "reference benchmark for +;;;; iteration counts". It's iteration count is calibrated to make the +;;;; benchmark run about one second on Dirk's laptop :-) If you are adding +;;;; benchmarks to the suite, it would be nice if you could calibrate the +;;;; number of iterations such that each of your added benchmarks takes about +;;;; as long to run as the reference benchmark. But: Don't be too accurate +;;;; to figure out the correct iteration count. + + +;;;; REPORTERS +;;;; +;;;; A reporter is a function which we apply to each benchmark outcome. +;;;; Reporters can log results, print interesting results to the standard +;;;; output, collect statistics, etc. +;;;; +;;;; A reporter function takes the following arguments: NAME ITERATIONS +;;;; BEFORE AFTER GC-TIME. The argument NAME holds the name of the benchmark, +;;;; ITERATIONS holds the actual number of iterations that were performed. +;;;; BEFORE holds the result of the function (times) at the very beginning of +;;;; the excution of the benchmark, AFTER holds the result of the function +;;;; (times) after the execution of the benchmark. GC-TIME, finally, holds +;;;; the difference of calls to (gc-run-time) before and after the execution +;;;; of the benchmark. +;;;; +;;;; This library provides some standard reporters for logging results +;;;; to a file, reporting interesting results to the user, (FIXME: and +;;;; collecting totals). +;;;; +;;;; You can use the REGISTER-REPORTER function and friends to add whatever +;;;; reporting functions you like. See under ;;;; TIMING DATA to see how the +;;;; library helps you to extract relevant timing information from the values +;;;; ITERATIONS, BEFORE, AFTER and GC-TIME. If you don't register any +;;;; reporters, the library uses USER-REPORTER, which writes the most +;;;; interesting results to the standard output. + + +;;;; TIME CALCULATION +;;;; +;;;; The library uses the guile functions `get-internal-run-time', +;;;; `get-internal-real-time', and `gc-run-time' to determine the +;;;; execution time for a single benchmark. Based on these functions, +;;;; Guile makes a <benchmark-result>, a record containing the elapsed +;;;; run time, real time, gc time, and possibly other metrics. These +;;;; times include the time needed to executed the benchmark code +;;;; itself, but also the surrounding code that implements the loop to +;;;; run the benchmark code for the given number of times. This is +;;;; undesirable, since one would prefer to only get the timing data for +;;;; the benchmarking code. +;;;; +;;;; To cope with this, the benchmarking framework uses a trick: During +;;;; initialization of the library, the time for executing an empty +;;;; benchmark is measured and stored. This is an estimate for the time +;;;; needed by the benchmarking framework itself. For later benchmarks, +;;;; this time can then be subtracted from the measured execution times. +;;;; Note that for very short benchmarks, this may result in a negative +;;;; number. +;;;; +;;;; The benchmarking framework provides the following accessors for +;;;; <benchmark-result> values. Note that all time values are in +;;;; internal time units; divide by internal-time-units-per-second to +;;;; get seconds. +;;;; +;;;; benchmark-result:name : Return the name of the benchmark. +;;;; +;;;; benchmark-result:iterations : Return the number of iterations that +;;;; this benchmark ran for. +;;;; +;;;; benchmark-result:real-time : Return the clock time elapsed while +;;;; this benchmark executed. +;;;; +;;;; benchmark-result:run-time : Return the CPU time elapsed while this +;;;; benchmark executed, both in user and kernel space. +;;;; +;;;; benchmark-result:gc-time : Return the approximate amount of time +;;;; spent in garbage collection while this benchmark executed, both +;;;; in user and kernel space. +;;;; +;;;; benchmark-result:core-time : Like benchmark-result:run-time, but +;;;; also estimates the time spent by the framework for the number +;;;; of iterations, and subtracts off that time from the result. +;;;; + +;;;; This module is used when benchmarking different Guiles, and so it +;;;; should run on all the Guiles of interest. Currently this set +;;;; includes Guile 1.8, so be careful with introducing features that +;;;; only Guile 2.0 supports. + + +;;;; MISCELLANEOUS +;;;; + +(define-record-type <benchmark-result> + (make-benchmark-result name iterations real-time run-time gc-time) + benchmark-result? + (name benchmark-result:name) + (iterations benchmark-result:iterations) + (real-time benchmark-result:real-time) + (run-time benchmark-result:run-time) + (gc-time benchmark-result:gc-time)) + +;;; Perform a division and convert the result to inexact. +(define (->seconds time) + (/ time 1.0 internal-time-units-per-second)) + +;;; Scale the number of iterations according to the given scaling factor. +(define iteration-factor 1) +(define (scale-iterations iterations) + (let* ((i (inexact->exact (round (* iterations iteration-factor))))) + (if (< i 1) 1 i))) + +;;; Parameters. +(cond-expand + (srfi-39 #t) + (else (use-modules (srfi srfi-39)))) + +;;;; CORE FUNCTIONS +;;;; + +;;; The central routine for executing benchmarks. +;;; The idea is taken from Greg, the GNUstep regression test environment. +(define benchmark-running? (make-parameter #f)) +(define (run-benchmark name iterations thunk) + (if (benchmark-running?) + (error "Nested calls to run-benchmark are not permitted.")) + (if (not (and (integer? iterations) (exact? iterations))) + (error "Expected exact integral number of iterations")) + (parameterize ((benchmark-running? #t)) + ;; Warm up the benchmark first. This will resolve any toplevel-ref + ;; forms. + (thunk) + (gc) + (let* ((before-gc-time (gc-run-time)) + (before-real-time (get-internal-real-time)) + (before-run-time (get-internal-run-time))) + (do ((i iterations (1- i))) + ((zero? i)) + (thunk)) + (let ((after-run-time (get-internal-run-time)) + (after-real-time (get-internal-real-time)) + (after-gc-time (gc-run-time))) + (report (make-benchmark-result (full-name name) iterations + (- after-real-time before-real-time) + (- after-run-time before-run-time) + (- after-gc-time before-gc-time))))))) + +;;; A short form for benchmarks. +(cond-expand + (guile-2 + (define-syntax-rule (benchmark name iterations body body* ...) + (run-benchmark name iterations (lambda () body body* ...)))) + (else + (defmacro benchmark (name iterations body . rest) + `(run-benchmark ,name ,iterations (lambda () ,body ,@rest))))) + + +;;;; BENCHMARK NAMES +;;;; + +;;;; Turn a benchmark name into a nice human-readable string. +(define (format-benchmark-name name) + (string-join name ": ")) + +;;;; For a given benchmark-name, deliver the full name including all prefixes. +(define (full-name name) + (append (current-benchmark-prefix) (list name))) + +;;; A parameter containing the current benchmark prefix, as a list. +(define current-benchmark-prefix + (make-parameter '())) + +;;; Postpend PREFIX to the current name prefix while evaluting THUNK. +;;; The name prefix is only changed within the dynamic scope of the +;;; call to with-benchmark-prefix*. Return the value returned by THUNK. +(define (with-benchmark-prefix* prefix thunk) + (parameterize ((current-benchmark-prefix (full-name prefix))) + (thunk))) + +;;; (with-benchmark-prefix PREFIX BODY ...) +;;; Postpend PREFIX to the current name prefix while evaluating BODY ... +;;; The name prefix is only changed within the dynamic scope of the +;;; with-benchmark-prefix expression. Return the value returned by the last +;;; BODY expression. +(cond-expand + (guile-2 + (define-syntax-rule (with-benchmark-prefix prefix body body* ...) + (with-benchmark-prefix* prefix (lambda () body body* ...)))) + (else + (defmacro with-benchmark-prefix (prefix . body) + `(with-benchmark-prefix* ,prefix (lambda () ,@body))))) + + +;;;; Benchmark results +;;;; + +(define *calibration-result* + "<will be set during initialization>") + +(define (benchmark-overhead iterations accessor) + (* (/ iterations 1.0 (benchmark-result:iterations *calibration-result*)) + (accessor *calibration-result*))) + +(define (benchmark-result:core-time result) + (- (benchmark-result:run-time result) + (benchmark-overhead (benchmark-result:iterations result) + benchmark-result:run-time))) + + +;;;; REPORTERS +;;;; + +;;; The global set of reporters. +(define report-hook (make-hook 1)) + +(define (default-reporter result) + (if (hook-empty? report-hook) + (user-reporter result) + (run-hook report-hook result))) + +(define current-reporter + (make-parameter default-reporter)) + +(define (register-reporter reporter) + (add-hook! report-hook reporter)) + +(define (unregister-reporter reporter) + (remove-hook! report-hook reporter)) + +;;; Return true iff REPORTER is in the current set of reporter functions. +(define (reporter-registered? reporter) + (if (memq reporter (hook->list report-hook)) #t #f)) + +;;; Send RESULT to all currently registered reporter functions. +(define (report result) + ((current-reporter) result)) + + +;;;; Some useful standard reporters: +;;;; Log reporters write all benchmark results to a given log file. +;;;; Full reporters write all benchmark results to the standard output. +;;;; User reporters write some interesting results to the standard output. + +;;; Display a single benchmark result to the given port +(define (print-result port result) + (let ((name (format-benchmark-name (benchmark-result:name result))) + (iterations (benchmark-result:iterations result)) + (real-time (benchmark-result:real-time result)) + (run-time (benchmark-result:run-time result)) + (gc-time (benchmark-result:gc-time result)) + (core-time (benchmark-result:core-time result))) + (write (list name iterations + 'total (->seconds real-time) + 'user (->seconds run-time) + 'system 0 + 'frame (->seconds (- run-time core-time)) + 'benchmark (->seconds core-time) + 'user/interp (->seconds (- run-time gc-time)) + 'bench/interp (->seconds (- core-time gc-time)) + 'gc (->seconds gc-time)) + port) + (newline port))) + +;;; Return a reporter procedure which prints all results to the file +;;; FILE, in human-readable form. FILE may be a filename, or a port. +(define (make-log-reporter file) + (let ((port (if (output-port? file) file + (open-output-file file)))) + (lambda (result) + (print-result port result) + (force-output port)))) + +;;; A reporter that reports all results to the user. +(define (full-reporter result) + (print-result (current-output-port) result)) + +;;; Display interesting results of a single benchmark to the given port +(define (print-user-result port result) + (let ((name (format-benchmark-name (benchmark-result:name result))) + (iterations (benchmark-result:iterations result)) + (real-time (benchmark-result:real-time result)) + (run-time (benchmark-result:run-time result)) + (gc-time (benchmark-result:gc-time result)) + (core-time (benchmark-result:core-time result))) + (write (list name iterations + 'real (->seconds real-time) + 'real/iteration (->seconds (/ real-time iterations)) + 'run/iteration (->seconds (/ run-time iterations)) + 'core/iteration (->seconds (/ core-time iterations)) + 'gc (->seconds gc-time)) + port) + (newline port))) + +;;; A reporter that reports interesting results to the user. +(define (user-reporter result) + (print-user-result (current-output-port) result)) + + +;;;; Initialize the benchmarking system: +;;;; + +(define (calibrate-benchmark-framework) + (display ";; running guile version ") + (display (version)) + (newline) + (display ";; calibrating the benchmarking framework...") + (newline) + (parameterize ((current-reporter + (lambda (result) + (set! *calibration-result* result) + (display ";; calibration: ") + (print-user-result (current-output-port) result)))) + (benchmark "empty initialization benchmark" 10000000 #t))) + +(calibrate-benchmark-framework) diff --git a/benchmark-suite/benchmarks/0-reference.bm b/benchmark-suite/benchmarks/0-reference.bm new file mode 100644 index 000000000..3d02ee7b1 --- /dev/null +++ b/benchmark-suite/benchmarks/0-reference.bm @@ -0,0 +1,6 @@ + +(define-module (benchmarks 0-reference) + :use-module (benchmark-suite lib)) + +(benchmark "reference benchmark for iteration counts" 330000 + #t) diff --git a/benchmark-suite/benchmarks/arithmetic.bm b/benchmark-suite/benchmarks/arithmetic.bm new file mode 100644 index 000000000..e0a9bf3c1 --- /dev/null +++ b/benchmark-suite/benchmarks/arithmetic.bm @@ -0,0 +1,67 @@ +;;; -*- mode: scheme; coding: utf-8; -*- +;;; Integer arithmetic. +;;; +;;; Copyright 2010, 2012 Free Software Foundation, Inc. +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 3, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this software; see the file COPYING.LESSER. If +;;; not, write to the Free Software Foundation, Inc., 51 Franklin +;;; Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (benchmarks arithmetic) + #:use-module (benchmark-suite lib)) + +(define-syntax repeat + (lambda (s) + ;; Construct an expression of the form `(OP (OP (OP SEED)))', with a + ;; depth of COUNT. + (syntax-case s (<>) + ((_ (op x <>) seed count) ;; binary OP + (number? (syntax->datum #'count)) + (let loop ((count (syntax->datum #'count)) + (result #'seed)) + (if (= 0 count) + result + (loop (1- count) + (with-syntax ((result result)) + #'(op x result)))))) + ((_ (op <>) seed count) ;; unary OP + (number? (syntax->datum #'count)) + (let loop ((count (syntax->datum #'count)) + (result #'seed)) + (if (= 0 count) + result + (loop (1- count) + (with-syntax ((result result)) + #'(op result))))))))) + + +(with-benchmark-prefix "fixnum" + + (benchmark "1+" #e1e7 + (repeat (1+ <>) 2 100)) + + (benchmark "1-" #e1e7 + (repeat (1- <>) 2 100)) + + (benchmark "+" #e1e7 + (repeat (+ 2 <>) 7 100)) + + (benchmark "-" #e1e7 + (repeat (- 2 <>) 7 100)) + + (benchmark "*" #e1e7 + (repeat (* 1 <>) 1 100)) + + (benchmark "/" #e1e7 + (repeat (/ 2 <>) 1 100))) diff --git a/benchmark-suite/benchmarks/bytevector-io.bm b/benchmark-suite/benchmarks/bytevector-io.bm new file mode 100644 index 000000000..7ae7c0e02 --- /dev/null +++ b/benchmark-suite/benchmarks/bytevector-io.bm @@ -0,0 +1,52 @@ +;;; bytevector-io.bm --- Exercise bytevector I/O primitives. -*- Scheme -*- +;;; +;;; Copyright (C) 2008, 2017 Free Software Foundation, Inc. +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 3, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this software; see the file COPYING.LESSER. If +;;; not, write to the Free Software Foundation, Inc., 51 Franklin +;;; Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (benchmarks bytevector-io) + :use-module (benchmark-suite lib) + :use-module (rnrs io ports) + :use-module (rnrs bytevectors)) + +(define file-name + (tmpnam)) + +(define %buffer-size + 7777) + +(define buf + (make-u8vector %buffer-size)) + + +(with-benchmark-prefix "bytevector i/o" + + (benchmark "put-bytevector" 4000 + (let ((output (open-output-file file-name))) + (put-bytevector output buf) + (close output))) + + (benchmark "get-bytevector-n!" 20000 + (let ((input (open-input-file file-name))) + (setvbuf input 'none) + (get-bytevector-n! input buf 0 (bytevector-length buf)) + (close input))) + + (benchmark "get-bytevector-n" 20000 + (let ((input (open-input-file file-name))) + (setvbuf input 'none) + (get-bytevector-n input (bytevector-length buf)) + (close input)))) diff --git a/benchmark-suite/benchmarks/bytevectors.bm b/benchmark-suite/benchmarks/bytevectors.bm new file mode 100644 index 000000000..b30bb38cd --- /dev/null +++ b/benchmark-suite/benchmarks/bytevectors.bm @@ -0,0 +1,99 @@ +;;; -*- mode: scheme; coding: iso-8859-1; -*- +;;; R6RS Byte Vectors. +;;; +;;; Copyright 2009, 2010 Free Software Foundation, Inc. +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 3, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this software; see the file COPYING.LESSER. If +;;; not, write to the Free Software Foundation, Inc., 51 Franklin +;;; Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (benchmarks bytevector) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-4) + #:use-module (benchmark-suite lib)) + +(define bv (make-bytevector 16384)) + +(define %native-endianness + (native-endianness)) + +(define %foreign-endianness + (if (eq? (native-endianness) (endianness little)) + (endianness big) + (endianness little))) + +(define u8v (make-u8vector 16384)) +(define u16v (make-u16vector 8192)) +(define u32v (make-u32vector 4196)) +(define u64v (make-u64vector 2048)) + + +(with-benchmark-prefix "ref/set!" + + (benchmark "bytevector-u8-ref" 1000000 + (bytevector-u8-ref bv 0)) + + (benchmark "bytevector-u16-ref (foreign)" 1000000 + (bytevector-u16-ref bv 0 %foreign-endianness)) + + (benchmark "bytevector-u16-ref (native)" 1000000 + (bytevector-u16-ref bv 0 %native-endianness)) + + (benchmark "bytevector-u16-native-ref" 1000000 + (bytevector-u16-native-ref bv 0)) + + (benchmark "bytevector-u32-ref (foreign)" 1000000 + (bytevector-u32-ref bv 0 %foreign-endianness)) + + (benchmark "bytevector-u32-ref (native)" 1000000 + (bytevector-u32-ref bv 0 %native-endianness)) + + (benchmark "bytevector-u32-native-ref" 1000000 + (bytevector-u32-native-ref bv 0)) + + (benchmark "bytevector-u64-ref (foreign)" 1000000 + (bytevector-u64-ref bv 0 %foreign-endianness)) + + (benchmark "bytevector-u64-ref (native)" 1000000 + (bytevector-u64-ref bv 0 %native-endianness)) + + (benchmark "bytevector-u64-native-ref" 1000000 + (bytevector-u16-native-ref bv 0))) + + +(with-benchmark-prefix "lists" + + (benchmark "bytevector->u8-list" 2000 + (bytevector->u8-list bv)) + + (benchmark "bytevector->uint-list 16-bit" 2000 + (bytevector->uint-list bv (native-endianness) 2)) + + (benchmark "bytevector->uint-list 64-bit" 2000 + (bytevector->uint-list bv (native-endianness) 8))) + + +(with-benchmark-prefix "SRFI-4" ;; for comparison + + (benchmark "u8vector-ref" 1000000 + (u8vector-ref u8v 0)) + + (benchmark "u16vector-ref" 1000000 + (u16vector-ref u16v 0)) + + (benchmark "u32vector-ref" 1000000 + (u32vector-ref u32v 0)) + + (benchmark "u64vector-ref" 1000000 + (u64vector-ref u64v 0))) diff --git a/benchmark-suite/benchmarks/chars.bm b/benchmark-suite/benchmarks/chars.bm new file mode 100644 index 000000000..6ae0e60bd --- /dev/null +++ b/benchmark-suite/benchmarks/chars.bm @@ -0,0 +1,57 @@ +;;; coding: latin1 -*- mode: scheme; coding: latin-1; -*- +;;; chars.bm +;;; +;;; Copyright (C) 2009 Free Software Foundation, Inc. +;;; +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 3, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this software; see the file COPYING.LESSER. If +;;; not, write to the Free Software Foundation, Inc., 51 Franklin +;;; Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (benchmarks chars) + :use-module (benchmark-suite lib)) + + +(with-benchmark-prefix "chars" + + (benchmark "char" 1000000 + #\a) + + (benchmark "octal" 1000000 + #\123) + + (benchmark "char? eq" 1000000 + (char? #\a)) + + (benchmark "char=?" 1000000 + (char=? #\a #\a)) + + (benchmark "char<?" 1000000 + (char=? #\a #\a)) + + (benchmark "char-ci=?" 1000000 + (char=? #\a #\a)) + + (benchmark "char-ci<? " 1000000 + (char=? #\a #\a)) + + (benchmark "char->integer" 1000000 + (char->integer #\a)) + + (benchmark "char-alphabetic?" 1000000 + (char-upcase #\a)) + + (benchmark "char-numeric?" 1000000 + (char-upcase #\a))) + diff --git a/benchmark-suite/benchmarks/continuations.bm b/benchmark-suite/benchmarks/continuations.bm new file mode 100644 index 000000000..3ca498da5 --- /dev/null +++ b/benchmark-suite/benchmarks/continuations.bm @@ -0,0 +1,9 @@ + +(define-module (benchmarks continuations) + :use-module (benchmark-suite lib)) + +(define (callee continuation) + (continuation #t)) + +(benchmark "call/cc" 12000 + (call-with-current-continuation callee)) diff --git a/benchmark-suite/benchmarks/hash.bm b/benchmark-suite/benchmarks/hash.bm new file mode 100644 index 000000000..9c2be57a1 --- /dev/null +++ b/benchmark-suite/benchmarks/hash.bm @@ -0,0 +1,53 @@ +;;; hash.bm --- Hash functions. -*- Scheme -*- +;;; +;;; Copyright (C) 2015 Free Software Foundation, Inc. +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 3, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this software; see the file COPYING.LESSER. If +;;; not, write to the Free Software Foundation, Inc., 51 Franklin +;;; Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (benchmarks write) + #:use-module (benchmark-suite lib)) + +(define %narrow-string + (make-string 30 #\a)) + +(define %wide-string + (make-string 30 #\λ)) + +(define %long-string + (make-string 300 #\x)) + +(define-syntax repeat + (lambda (s) + (syntax-case s () + ((_ 1 exp) + #'exp) + ((_ count exp) + (with-syntax ((count (- (syntax->datum #'count) 1))) + #'(begin + exp + (repeat count exp))))))) + + +(with-benchmark-prefix "string-hash" + + (benchmark "narrow string" 100000 + (repeat 100 (string-hash %narrow-string))) + + (benchmark "wide string" 100000 + (repeat 100 (string-hash %wide-string))) + + (benchmark "long string" 100000 + (repeat 100 (string-hash %long-string)))) diff --git a/benchmark-suite/benchmarks/if.bm b/benchmark-suite/benchmarks/if.bm new file mode 100644 index 000000000..70aa8debf --- /dev/null +++ b/benchmark-suite/benchmarks/if.bm @@ -0,0 +1,55 @@ + +(define-module (benchmarks if) + :use-module (benchmark-suite lib)) + +(with-benchmark-prefix "if-<expr>-then-else" + + (benchmark "executing then" 330000 + (if (quote #t) #t #f)) + + (benchmark "executing else" 330000 + (if (quote #f) #t #f))) + +(with-benchmark-prefix "if-<expr>-then" + + (benchmark "executing then" 330000 + (if (quote #t) #t)) + + (benchmark "executing else" 330000 + (if (quote #f) #t))) + +(with-benchmark-prefix "if-<iloc>-then-else" + + (let ((x #t)) + (benchmark "executing then" 330000 + (if x #t #f))) + + (let ((x #f)) + (benchmark "executing else" 330000 + (if x #t #f)))) + +(with-benchmark-prefix "if-<iloc>-then" + + (let ((x #t)) + (benchmark "executing then" 330000 + (if x #t))) + + (let ((x #f)) + (benchmark "executing else" 330000 + (if x #t)))) + +(with-benchmark-prefix "if-<bool>-then-else" + + (benchmark "executing then" 330000 + (if #t #t #f)) + + (benchmark "executing else" 330000 + (if #f #t #f))) + +(with-benchmark-prefix "if-<bool>-then" + + (benchmark "executing then" 330000 + (if #t #t)) + + (benchmark "executing else" 330000 + (if #f #t))) diff --git a/benchmark-suite/benchmarks/logand.bm b/benchmark-suite/benchmarks/logand.bm new file mode 100644 index 000000000..c94ad3167 --- /dev/null +++ b/benchmark-suite/benchmarks/logand.bm @@ -0,0 +1,10 @@ + +(define-module (benchmarks logand) + :use-module (benchmark-suite lib)) + +(define bignum (1- (expt 2 128))) + +(let* ((i 0)) + (benchmark "bignum" 130000 + (logand i bignum) + (set! i (+ i 1)))) diff --git a/benchmark-suite/benchmarks/ports.bm b/benchmark-suite/benchmarks/ports.bm new file mode 100644 index 000000000..417725531 --- /dev/null +++ b/benchmark-suite/benchmarks/ports.bm @@ -0,0 +1,95 @@ +;;; ports.bm --- Port I/O. -*- mode: scheme; coding: utf-8; -*- +;;; +;;; Copyright (C) 2010-2014 Free Software Foundation, Inc. +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 3, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this software; see the file COPYING.LESSER. If +;;; not, write to the Free Software Foundation, Inc., 51 Franklin +;;; Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (benchmarks ports) + #:use-module (ice-9 rdelim) + #:use-module (benchmark-suite lib)) + +(define-syntax sequence + (lambda (s) + ;; Create a sequence `(begin EXPR ...)' with COUNT occurrences of EXPR. + (syntax-case s () + ((_ expr count) + (number? (syntax->datum #'count)) + (cons #'begin + (make-list (syntax->datum #'count) #'expr)))))) + +(define (large-string s) + (string-concatenate (make-list (* iteration-factor 10000) s))) + +(define %latin1-port + (let ((p (open-input-string (large-string "hello, world")))) + (set-port-encoding! p "ISO-8859-1") + p)) + +(define %utf8/ascii-port + (open-input-string (large-string "hello, world"))) + +(define %utf8/wide-port + (open-input-string (large-string "안녕하세요"))) + + +(with-benchmark-prefix "peek-char" + + (benchmark "latin-1 port" 700 + (sequence (peek-char %latin1-port) 1000)) + + (benchmark "utf-8 port, ascii character" 700 + (sequence (peek-char %utf8/ascii-port) 1000)) + + (benchmark "utf-8 port, Korean character" 700 + (sequence (peek-char %utf8/wide-port) 1000))) + +(with-benchmark-prefix "char-ready?" + + (benchmark "latin-1 port" 10000 + (sequence (char-ready? %latin1-port) 1000)) + + (benchmark "utf-8 port, ascii character" 10000 + (sequence (char-ready? %utf8/ascii-port) 1000)) + + (benchmark "utf-8 port, Korean character" 10000 + (sequence (char-ready? %utf8/wide-port) 1000))) + +;; Keep the `read-char' benchmarks last as they consume input from the +;; ports. + +(with-benchmark-prefix "read-char" + + (benchmark "latin-1 port" 10000 + (sequence (read-char %latin1-port) 1000)) + + (benchmark "utf-8 port, ascii character" 10000 + (sequence (read-char %utf8/ascii-port) 1000)) + + (benchmark "utf-8 port, Korean character" 10000 + (sequence (read-char %utf8/wide-port) 1000))) + + +(with-benchmark-prefix "rdelim" + + (let ((str (string-concatenate (make-list 1000 "one line\n")))) + (benchmark "read-line" 1000 + (let ((port (open-input-string str))) + (sequence (read-line port) 1000)))) + + (let ((str (large-string "Hello, world.\n"))) + (benchmark "read-string" 200 + (let ((port (open-input-string str))) + (read-string port))))) diff --git a/benchmark-suite/benchmarks/r6rs-arithmetic.bm b/benchmark-suite/benchmarks/r6rs-arithmetic.bm new file mode 100644 index 000000000..309f0666b --- /dev/null +++ b/benchmark-suite/benchmarks/r6rs-arithmetic.bm @@ -0,0 +1,35 @@ +;;; -*- mode: scheme; coding: utf-8; -*- +;;; R6RS-specific arithmetic benchmarks +;;; +;;; Copyright (C) 2011, 2012 Free Software Foundation, Inc. +;;; +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (benchmarks r6rs-arithmetic) + #:use-module (benchmark-suite lib) + #:use-module (rnrs arithmetic fixnums)) + + +(with-benchmark-prefix "fixnum" + + (benchmark "fixnum? [yes]" #e1e7 + (fixnum? 10000)) + + (let ((n (+ most-positive-fixnum 100))) + (benchmark "fixnum? [no]" #e1e7 + (fixnum? n))) + + (benchmark "fxxor [2]" #e1e7 + (fxxor 3 8))) diff --git a/benchmark-suite/benchmarks/read.bm b/benchmark-suite/benchmarks/read.bm new file mode 100644 index 000000000..a4ff9936f --- /dev/null +++ b/benchmark-suite/benchmarks/read.bm @@ -0,0 +1,73 @@ +;;; read.bm --- Exercise the reader. -*- Scheme -*- +;;; +;;; Copyright (C) 2008, 2010, 2012 Free Software Foundation, Inc. +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 3, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this software; see the file COPYING.LESSER. If +;;; not, write to the Free Software Foundation, Inc., 51 Franklin +;;; Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (benchmarks read) + :use-module (benchmark-suite lib)) + + +(define %files-to-load + ;; Various large Scheme files. + (map %search-load-path + '("ice-9/boot-9.scm" "ice-9/common-list.scm" + "ice-9/format.scm" "ice-9/optargs.scm" + "ice-9/session.scm" "ice-9/getopt-long.scm" + "ice-9/psyntax-pp.scm"))) + +(define (load-file-with-reader file-name reader buffering) + (with-input-from-file file-name + (lambda () + (apply setvbuf (current-input-port) buffering) + (let loop ((sexp (reader))) + (if (eof-object? sexp) + #t + (loop (reader))))))) + +(define (exercise-read buffering) + (for-each (lambda (file) + (load-file-with-reader file read buffering)) + %files-to-load)) + +(define small "\"hello, world!\"") +(define large (string-append "\"" (make-string 1234 #\A) "\"")) + +(fluid-set! %default-port-encoding "UTF-8") ; for string ports + + +(with-benchmark-prefix "read" + + (benchmark "'none" 5 ;; this one is very slow + (exercise-read (list 'none))) + + (benchmark "'line" 10 + (exercise-read (list 'line))) + + (benchmark "'block 4096" 10 + (exercise-read (list 'block 4096))) + + (benchmark "'block 8192" 10 + (exercise-read (list 'block 8192))) + + (benchmark "'block 16384" 10 + (exercise-read (list 'block 16384))) + + (benchmark "small strings" 100000 + (call-with-input-string small read)) + + (benchmark "large strings" 100000 + (call-with-input-string large read))) diff --git a/benchmark-suite/benchmarks/srfi-1.bm b/benchmark-suite/benchmarks/srfi-1.bm new file mode 100644 index 000000000..67f79ca24 --- /dev/null +++ b/benchmark-suite/benchmarks/srfi-1.bm @@ -0,0 +1,64 @@ +;;; -*- mode: scheme; coding: utf-8; -*- +;;; SRFI-1. +;;; +;;; Copyright 2010, 2011 Free Software Foundation, Inc. +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 3, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this software; see the file COPYING.LESSER. If +;;; not, write to the Free Software Foundation, Inc., 51 Franklin +;;; Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (benchmarks srfi-1) + #:use-module (srfi srfi-1) + #:use-module (benchmark-suite lib)) + +(define %big-list + (iota 1000000)) + +(define %small-list + (iota 10)) + + +(with-benchmark-prefix "fold" + + (benchmark "big" 30 + (fold (lambda (x y) y) #f %big-list)) + + (benchmark "small" 2000000 + (fold (lambda (x y) y) #f %small-list))) + + +(with-benchmark-prefix "drop-while" + + (benchmark "big" 30 + (drop-while (lambda (n) #t) %big-list)) + + (benchmark "small" 2000000 + (drop-while (lambda (n) #t) %small-list))) + +(with-benchmark-prefix "map" + + (benchmark "big" 30 + (map (lambda (x) x) %big-list)) + + (benchmark "small" 2000000 + (map (lambda (x) x) %small-list))) + +(with-benchmark-prefix "for-each" + + (benchmark "big" 30 + (for-each (lambda (x) #f) %big-list)) + + (benchmark "small" 2000000 + (for-each (lambda (x) #f) %small-list))) + diff --git a/benchmark-suite/benchmarks/srfi-13.bm b/benchmark-suite/benchmarks/srfi-13.bm new file mode 100644 index 000000000..a9ee27615 --- /dev/null +++ b/benchmark-suite/benchmarks/srfi-13.bm @@ -0,0 +1,310 @@ +;;; coding: latin1 -*- mode: scheme; coding: latin-1; -*- +;;; srfi-13.bm +;;; +;;; Copyright (C) 2009 Free Software Foundation, Inc. +;;; +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 3, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this software; see the file COPYING.LESSER. If +;;; not, write to the Free Software Foundation, Inc., 51 Franklin +;;; Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (benchmarks strings) + :use-module (benchmark-suite lib)) + +(seed->random-state 1) + +(define short-string "Hi") +(define medium-string +"ARMA virumque cano, Troiae qui primus ab oris +Italiam, fato profugus, Laviniaque venit") +(define long-string + (string-tabulate + (lambda (n) (integer->char (+ 32 (random 90)))) + 1000)) + +(define short-chlist (string->list short-string)) +(define medium-chlist (string->list medium-string)) +(define long-chlist (string->list long-string)) + +(define str1 (string-copy short-string)) +(define str2 (string-copy medium-string)) +(define str3 (string-copy long-string)) + + +(with-benchmark-prefix "strings" + + (with-benchmark-prefix "predicates" + + (benchmark "string?" 1190000 + (string? short-string) + (string? medium-string) + (string? long-string)) + + (benchmark "null?" 969000 + (string-null? short-string) + (string-null? medium-string) + (string-null? long-string)) + + (benchmark "any" 94000 + (string-any #\a short-string) + (string-any #\a medium-string) + (string-any #\a long-string)) + + (benchmark "every" 94000 + (string-every #\a short-string) + (string-every #\a medium-string) + (string-every #\a long-string))) + + (with-benchmark-prefix "constructors" + + (benchmark "string" 5000 + (apply string short-chlist) + (apply string medium-chlist) + (apply string long-chlist)) + + (benchmark "list->" 4500 + (list->string short-chlist) + (list->string medium-chlist) + (list->string long-chlist)) + + (benchmark "reverse-list->" 5000 + (reverse-list->string short-chlist) + (reverse-list->string medium-chlist) + (reverse-list->string long-chlist)) + + (benchmark "make" 22000 + (make-string 250 #\x)) + + (benchmark "tabulate" 17000 + (string-tabulate integer->char 250)) + + (benchmark "join" 5500 + (string-join (list short-string medium-string long-string) "|" 'suffix))) + + (with-benchmark-prefix "list/string" + (benchmark "->list" 7300 + (string->list short-string) + (string->list medium-string) + (string->list long-string)) + + (benchmark "split" 60000 + (string-split short-string #\a) + (string-split medium-string #\a) + (string-split long-string #\a))) + + (with-benchmark-prefix "selection" + + (benchmark "ref" 660 + (let loop ((k 0)) + (if (< k (string-length short-string)) + (begin + (string-ref short-string k) + (loop (+ k 1))))) + (let loop ((k 0)) + (if (< k (string-length medium-string)) + (begin + (string-ref medium-string k) + (loop (+ k 1))))) + (let loop ((k 0)) + (if (< k (string-length long-string)) + (begin + (string-ref long-string k) + (loop (+ k 1)))))) + + (benchmark "copy" 20000 + (string-copy short-string) + (string-copy medium-string) + (string-copy long-string) + (substring/copy short-string 0 1) + (substring/copy medium-string 10 20) + (substring/copy long-string 100 200)) + + (benchmark "pad" 34000 + (string-pad short-string 100) + (string-pad medium-string 100) + (string-pad long-string 100)) + + (benchmark "trim trim-right trim-both" 60000 + (string-trim short-string char-alphabetic?) + (string-trim medium-string char-alphabetic?) + (string-trim long-string char-alphabetic?) + (string-trim-right short-string char-alphabetic?) + (string-trim-right medium-string char-alphabetic?) + (string-trim-right long-string char-alphabetic?) + (string-trim-both short-string char-alphabetic?) + (string-trim-both medium-string char-alphabetic?) + (string-trim-both long-string char-alphabetic?))) + + (with-benchmark-prefix "modification" + + (set! str1 (string-copy short-string)) + (set! str2 (string-copy medium-string)) + (set! str3 (string-copy long-string)) + + (benchmark "set!" 3000 + (let loop ((k 1)) + (if (< k (string-length short-string)) + (begin + (string-set! str1 k #\x) + (loop (+ k 1))))) + (let loop ((k 20)) + (if (< k (string-length medium-string)) + (begin + (string-set! str2 k #\x) + (loop (+ k 1))))) + (let loop ((k 900)) + (if (< k (string-length long-string)) + (begin + (string-set! str3 k #\x) + (loop (+ k 1)))))) + + (set! str1 (string-copy short-string)) + (set! str2 (string-copy medium-string)) + (set! str3 (string-copy long-string)) + + (benchmark "sub-move!" 230000 + (substring-move! short-string 0 2 str2 10) + (substring-move! medium-string 10 20 str3 20)) + + (set! str1 (string-copy short-string)) + (set! str2 (string-copy medium-string)) + (set! str3 (string-copy long-string)) + + (benchmark "fill!" 230000 + (string-fill! str1 #\y 0 1) + (string-fill! str2 #\y 10 20) + (string-fill! str3 #\y 20 30)) + + (with-benchmark-prefix "comparison" + + (benchmark "compare compare-ci" 140000 + (string-compare short-string medium-string string<? string=? string>?) + (string-compare long-string medium-string string<? string=? string>?) + (string-compare-ci short-string medium-string string<? string=? string>?) + (string-compare-ci long-string medium-string string<? string=? string>?)) + + (benchmark "hash hash-ci" 1000 + (string-hash short-string) + (string-hash medium-string) + (string-hash long-string) + (string-hash-ci short-string) + (string-hash-ci medium-string) + (string-hash-ci long-string)))) + + (with-benchmark-prefix "searching" 20000 + + (benchmark "prefix-length suffix-length" 270 + (string-prefix-length short-string + (string-append short-string medium-string)) + (string-prefix-length long-string + (string-append long-string medium-string)) + (string-suffix-length short-string + (string-append medium-string short-string)) + (string-suffix-length long-string + (string-append medium-string long-string)) + (string-prefix-length-ci short-string + (string-append short-string medium-string)) + (string-prefix-length-ci long-string + (string-append long-string medium-string)) + (string-suffix-length-ci short-string + (string-append medium-string short-string)) + (string-suffix-length-ci long-string + (string-append medium-string long-string))) + + (benchmark "prefix? suffix?" 270 + (string-prefix? short-string + (string-append short-string medium-string)) + (string-prefix? long-string + (string-append long-string medium-string)) + (string-suffix? short-string + (string-append medium-string short-string)) + (string-suffix? long-string + (string-append medium-string long-string)) + (string-prefix-ci? short-string + (string-append short-string medium-string)) + (string-prefix-ci? long-string + (string-append long-string medium-string)) + (string-suffix-ci? short-string + (string-append medium-string short-string)) + (string-suffix-ci? long-string + (string-append medium-string long-string))) + + (benchmark "index index-right rindex" 100000 + (string-index short-string #\T) + (string-index medium-string #\T) + (string-index long-string #\T) + (string-index-right short-string #\T) + (string-index-right medium-string #\T) + (string-index-right long-string #\T) + (string-rindex short-string #\T) + (string-rindex medium-string #\T) + (string-rindex long-string #\T)) + + (benchmark "skip skip-right?" 100000 + (string-skip short-string char-alphabetic?) + (string-skip medium-string char-alphabetic?) + (string-skip long-string char-alphabetic?) + (string-skip-right short-string char-alphabetic?) + (string-skip-right medium-string char-alphabetic?) + (string-skip-right long-string char-alphabetic?)) + + (benchmark "count" 10000 + (string-count short-string char-alphabetic?) + (string-count medium-string char-alphabetic?) + (string-count long-string char-alphabetic?)) + + (benchmark "contains contains-ci" 34000 + (string-contains short-string short-string) + (string-contains medium-string (substring medium-string 10 15)) + (string-contains long-string (substring long-string 100 130)) + (string-contains-ci short-string short-string) + (string-contains-ci medium-string (substring medium-string 10 15)) + (string-contains-ci long-string (substring long-string 100 130))) + + (set! str1 (string-copy short-string)) + (set! str2 (string-copy medium-string)) + (set! str3 (string-copy long-string)) + + (benchmark "upcase downcase upcase! downcase!" 600 + (string-upcase short-string) + (string-upcase medium-string) + (string-upcase long-string) + (string-downcase short-string) + (string-downcase medium-string) + (string-downcase long-string) + (string-upcase! str1 0 1) + (string-upcase! str2 10 20) + (string-upcase! str3 100 130) + (string-downcase! str1 0 1) + (string-downcase! str2 10 20) + (string-downcase! str3 100 130))) + + (with-benchmark-prefix "readers" + + (benchmark "read token, method 1" 1200 + (let ((buf (make-string 512))) + (let loop ((i 0)) + (if (< i 512) + (begin + (string-set! buf i #\x) + (loop (+ i 1))) + buf)))) + + (benchmark "read token, method 2" 1200 + (let ((lst '())) + (let loop ((i 0)) + (set! lst (append! lst (list #\x))) + (if (< i 512) + (loop (+ i 1)) + (list->string lst))))))) diff --git a/benchmark-suite/benchmarks/strings.bm b/benchmark-suite/benchmarks/strings.bm new file mode 100644 index 000000000..1fcdbd5a7 --- /dev/null +++ b/benchmark-suite/benchmarks/strings.bm @@ -0,0 +1,537 @@ +;;; -*- Mode: scheme; coding: utf-8; -*- +;;; strings.bm +;;; +;;; Copyright (C) 2011 Free Software Foundation, Inc. +;;; +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 3, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this software; see the file COPYING.LESSER. If +;;; not, write to the Free Software Foundation, Inc., 51 Franklin +;;; Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (benchmarks strings) + #:use-module (benchmark-suite lib) + #:use-module (ice-9 i18n)) + +(use-modules (ice-9 i18n)) + +(seed->random-state 1) + +;; Start from a known locale state +(setlocale LC_ALL "C") + +(define char-set:cased (char-set-union char-set:lower-case + char-set:upper-case + char-set:title-case)) +(define *latin1* + (char-set->list (char-set-xor + (char-set-intersection (ucs-range->char-set 0 255) + char-set:cased) + (->char-set #\µ)))) ; Can't do a case-insensitive comparison of a string + ; with mu in fr_FR.iso88591 since it case-folds into a + ; non-Latin-1 character. + +(define *cased* + (char-set->list char-set:cased)) + +(define (random-string c-list n) + (let ((len (length c-list))) + (apply string + (map + (lambda (x) + (list-ref c-list (random len))) + (iota n))))) + +(define (diff-at-start str) + (string-append "!" (substring str 1))) +(define (diff-in-middle str) + (let ((x (floor (/ (string-length str) 2)))) + (string-append (substring str 0 x) + "!" + (substring str (1+ x))))) +(define (diff-at-end str) + (string-append (substring str 0 (1- (string-length str))) + "!")) + +(define short-latin1-string (random-string *latin1* 10)) +(define medium-latin1-string (random-string *latin1* 100)) +(define long-latin1-string (random-string *latin1* 1000)) + +(define short-latin1-string-diff-at-start (diff-at-start short-latin1-string)) +(define medium-latin1-string-diff-at-start (diff-at-start medium-latin1-string)) +(define long-latin1-string-diff-at-start (diff-at-start long-latin1-string)) + +(define short-latin1-string-diff-in-middle (diff-in-middle short-latin1-string)) +(define medium-latin1-string-diff-in-middle (diff-in-middle medium-latin1-string)) +(define long-latin1-string-diff-in-middle (diff-in-middle long-latin1-string)) + +(define short-latin1-string-diff-at-end (diff-at-end short-latin1-string)) +(define medium-latin1-string-diff-at-end (diff-at-end medium-latin1-string)) +(define long-latin1-string-diff-at-end (diff-at-end long-latin1-string)) + +(define short-cased-string (random-string *cased* 10)) +(define medium-cased-string (random-string *cased* 100)) +(define long-cased-string (random-string *cased* 1000)) + +(define short-cased-string-diff-at-start (diff-at-start short-cased-string)) +(define medium-cased-string-diff-at-start (diff-at-start medium-cased-string)) +(define long-cased-string-diff-at-start (diff-at-start long-cased-string)) + +(define short-cased-string-diff-in-middle (diff-in-middle short-cased-string)) +(define medium-cased-string-diff-in-middle (diff-in-middle medium-cased-string)) +(define long-cased-string-diff-in-middle (diff-in-middle long-cased-string)) + +(define short-cased-string-diff-at-end (diff-at-end short-cased-string)) +(define medium-cased-string-diff-at-end (diff-at-end medium-cased-string)) +(define long-cased-string-diff-at-end (diff-at-end long-cased-string)) + +(define %french-locale-name "fr_FR.ISO-8859-1") + +(define %french-utf8-locale-name "fr_FR.UTF-8") + +(define %french-locale + (false-if-exception + (make-locale (list LC_CTYPE LC_COLLATE LC_NUMERIC LC_TIME) + %french-locale-name))) + +(define %french-utf8-locale + (false-if-exception + (make-locale (list LC_CTYPE LC_COLLATE LC_NUMERIC LC_TIME) + %french-utf8-locale-name))) + +(define (under-locale-or-unresolved locale thunk) + ;; On non-GNU systems, an exception may be raised only when the locale is + ;; actually used rather than at `make-locale'-time. Thus, we must guard + ;; against both. + (if locale + (if (string-contains %host-type "-gnu") + (thunk) + (catch 'system-error thunk + (lambda (key . args) + (throw 'unresolved)))) + (throw 'unresolved))) + +(define (under-french-locale-or-unresolved thunk) + (under-locale-or-unresolved %french-locale thunk)) + +(define (under-french-utf8-locale-or-unresolved thunk) + (under-locale-or-unresolved %french-utf8-locale thunk)) + +(define (string-op str1 str2) + (string<? str1 str2) + (string>? str1 str2)) + +(define (string-ci-op str1 str2) + (string-ci<? str1 str2) + (string-ci>? str1 str2)) + +(define (string-fr-op str1 str2) + (under-french-locale-or-unresolved + (lambda () + (string-locale<? str1 str2 %french-locale) + (string-locale>? str1 str2 %french-locale)))) + +(define (string-fr-utf8-op str1 str2) + (under-french-utf8-locale-or-unresolved + (lambda () + (string-locale<? str1 str2 %french-utf8-locale) + (string-locale>? str1 str2 %french-utf8-locale)))) + +(define (string-fr-ci-op str1 str2) + (under-french-locale-or-unresolved + (lambda () + (string-locale-ci<? str1 str2 %french-locale) + (string-locale-ci>? str1 str2 %french-locale)))) + +(define (string-fr-utf8-ci-op str1 str2) + (under-french-utf8-locale-or-unresolved + (lambda () + (string-locale-ci<? str1 str2 %french-utf8-locale) + (string-locale-ci>? str1 str2 %french-utf8-locale)))) + + +(with-benchmark-prefix "string ops" + + (with-benchmark-prefix "short Latin1" + + (benchmark "compare initially differing strings" 100000 + (string-op short-latin1-string short-latin1-string-diff-at-start)) + + (benchmark "compare medially differing strings" 100000 + (string-op short-latin1-string short-latin1-string-diff-in-middle)) + + (benchmark "compare terminally differing strings" 100000 + (string-op short-latin1-string short-latin1-string-diff-at-end)) + + (benchmark "compare identical strings" 100000 + (string-op short-latin1-string short-latin1-string)) + + (benchmark "case compare initially differing strings" 100000 + (string-ci-op short-latin1-string short-latin1-string-diff-at-start)) + + (benchmark "case compare medially differing strings" 100000 + (string-ci-op short-latin1-string short-latin1-string-diff-in-middle)) + + (benchmark "case compare terminally differing strings" 100000 + (string-ci-op short-latin1-string short-latin1-string-diff-at-end)) + + (benchmark "case compare identical strings" 100000 + (string-ci-op short-latin1-string short-latin1-string)) + + (benchmark "French Latin-1 locale compare initially differing strings" 100000 + (string-fr-op short-latin1-string short-latin1-string-diff-at-start)) + + (benchmark "French Latin-1 locale compare medially differing strings" 100000 + (string-fr-op short-latin1-string short-latin1-string-diff-in-middle)) + + (benchmark "French Latin-1 locale compare terminally differing strings" 100000 + (string-fr-op short-latin1-string short-latin1-string-diff-at-end)) + + (benchmark "French Latin-1 locale compare identical strings" 100000 + (string-fr-op short-latin1-string short-latin1-string)) + + (benchmark "French Latin-1 locale case compare initially differing strings" 100000 + (string-fr-ci-op short-latin1-string short-latin1-string-diff-at-start)) + + (benchmark "French Latin-1 locale case compare medially differing strings" 100000 + (string-fr-ci-op short-latin1-string short-latin1-string-diff-in-middle)) + + (benchmark "French Latin-1 locale case compare terminally differing strings" 100000 + (string-fr-ci-op short-latin1-string short-latin1-string-diff-at-end)) + + (benchmark "French Latin-1 locale case compare identical strings" 100000 + (string-fr-ci-op short-latin1-string short-latin1-string)) + + (benchmark "French UTF-8 locale compare initially differing strings" 100000 + (string-fr-utf8-op short-latin1-string short-latin1-string-diff-at-start)) + + (benchmark "French UTF-8 locale compare medially differing strings" 100000 + (string-fr-utf8-op short-latin1-string short-latin1-string-diff-in-middle)) + + (benchmark "French UTF-8 locale compare terminally differing strings" 100000 + (string-fr-utf8-op short-latin1-string short-latin1-string-diff-at-end)) + + (benchmark "French UTF-8 locale compare identical strings" 100000 + (string-fr-utf8-op short-latin1-string short-latin1-string)) + + (benchmark "French UTF-8 locale case compare initially differing strings" 100000 + (string-fr-utf8-ci-op short-latin1-string short-latin1-string-diff-at-start)) + + (benchmark "French UTF-8 locale case compare medially differing strings" 100000 + (string-fr-utf8-ci-op short-latin1-string short-latin1-string-diff-in-middle)) + + (benchmark "French UTF-8 locale case compare terminally differing strings" 100000 + (string-fr-utf8-ci-op short-latin1-string short-latin1-string-diff-at-end)) + + (benchmark "French UTF-8 locale case compare identical strings" 100000 + (string-fr-utf8-ci-op short-latin1-string short-latin1-string))) + + (with-benchmark-prefix "medium Latin1" + + (benchmark "compare initially differing strings" 10000 + (string-op medium-latin1-string medium-latin1-string-diff-at-start)) + + (benchmark "compare medially differing strings" 10000 + (string-op medium-latin1-string medium-latin1-string-diff-in-middle)) + + (benchmark "compare terminally differing strings" 10000 + (string-op medium-latin1-string medium-latin1-string-diff-at-end)) + + (benchmark "compare identical strings" 10000 + (string-op medium-latin1-string medium-latin1-string)) + + (benchmark "case compare initially differing strings" 10000 + (string-ci-op medium-latin1-string medium-latin1-string-diff-at-start)) + + (benchmark "case compare medially differing strings" 10000 + (string-ci-op medium-latin1-string medium-latin1-string-diff-in-middle)) + + (benchmark "case compare terminally differing strings" 10000 + (string-ci-op medium-latin1-string medium-latin1-string-diff-at-end)) + + (benchmark "case compare identical strings" 10000 + (string-ci-op medium-latin1-string medium-latin1-string)) + + (benchmark "French Latin-1 locale compare initially differing strings" 10000 + (string-fr-op medium-latin1-string medium-latin1-string-diff-at-start)) + + (benchmark "French Latin-1 locale compare medially differing strings" 10000 + (string-fr-op medium-latin1-string medium-latin1-string-diff-in-middle)) + + (benchmark "French Latin-1 locale compare terminally differing strings" 10000 + (string-fr-op medium-latin1-string medium-latin1-string-diff-at-end)) + + (benchmark "French Latin-1 locale compare identical strings" 10000 + (string-fr-op medium-latin1-string medium-latin1-string)) + + (benchmark "French Latin-1 locale case compare initially differing strings" 10000 + (string-fr-ci-op medium-latin1-string medium-latin1-string-diff-at-start)) + + (benchmark "French Latin-1 locale case compare medially differing strings" 10000 + (string-fr-ci-op medium-latin1-string medium-latin1-string-diff-in-middle)) + + (benchmark "French Latin-1 locale case compare terminally differing strings" 10000 + (string-fr-ci-op medium-latin1-string medium-latin1-string-diff-at-end)) + + (benchmark "French Latin-1 locale case compare identical strings" 10000 + (string-fr-ci-op medium-latin1-string medium-latin1-string)) + + (benchmark "French UTF-8 locale compare initially differing strings" 10000 + (string-fr-utf8-op medium-latin1-string medium-latin1-string-diff-at-start)) + + (benchmark "French UTF-8 locale compare medially differing strings" 10000 + (string-fr-utf8-op medium-latin1-string medium-latin1-string-diff-in-middle)) + + (benchmark "French UTF-8 locale compare terminally differing strings" 10000 + (string-fr-utf8-op medium-latin1-string medium-latin1-string-diff-at-end)) + + (benchmark "French UTF-8 locale compare identical strings" 10000 + (string-fr-utf8-op medium-latin1-string medium-latin1-string)) + + (benchmark "French UTF-8 locale case compare initially differing strings" 10000 + (string-fr-utf8-ci-op medium-latin1-string medium-latin1-string-diff-at-start)) + + (benchmark "French UTF-8 locale case compare medially differing strings" 10000 + (string-fr-utf8-ci-op medium-latin1-string medium-latin1-string-diff-in-middle)) + + (benchmark "French UTF-8 locale case compare terminally differing strings" 10000 + (string-fr-utf8-ci-op medium-latin1-string medium-latin1-string-diff-at-end)) + + (benchmark "French UTF-8 locale case compare identical strings" 10000 + (string-fr-utf8-ci-op medium-latin1-string medium-latin1-string))) + + (with-benchmark-prefix "long Latin1" + + (benchmark "compare initially differing strings" 1000 + (string-op long-latin1-string long-latin1-string-diff-at-start)) + + (benchmark "compare medially differing strings" 1000 + (string-op long-latin1-string long-latin1-string-diff-in-middle)) + + (benchmark "compare terminally differing strings" 1000 + (string-op long-latin1-string long-latin1-string-diff-at-end)) + + (benchmark "compare identical strings" 1000 + (string-op long-latin1-string long-latin1-string)) + + (benchmark "case compare initially differing strings" 1000 + (string-ci-op long-latin1-string long-latin1-string-diff-at-start)) + + (benchmark "case compare medially differing strings" 1000 + (string-ci-op long-latin1-string long-latin1-string-diff-in-middle)) + + (benchmark "case compare terminally differing strings" 1000 + (string-ci-op long-latin1-string long-latin1-string-diff-at-end)) + + (benchmark "case compare identical strings" 1000 + (string-ci-op long-latin1-string long-latin1-string)) + + (benchmark "French Latin-1 locale compare initially differing strings" 1000 + (string-fr-op long-latin1-string long-latin1-string-diff-at-start)) + + (benchmark "French Latin-1 locale compare medially differing strings" 1000 + (string-fr-op long-latin1-string long-latin1-string-diff-in-middle)) + + (benchmark "French Latin-1 locale compare terminally differing strings" 1000 + (string-fr-op long-latin1-string long-latin1-string-diff-at-end)) + + (benchmark "French Latin-1 locale compare identical strings" 1000 + (string-fr-op long-latin1-string long-latin1-string)) + + (benchmark "French Latin-1 locale case compare initially differing strings" 1000 + (string-fr-ci-op long-latin1-string long-latin1-string-diff-at-start)) + + (benchmark "French Latin-1 locale case compare medially differing strings" 1000 + (string-fr-ci-op long-latin1-string long-latin1-string-diff-in-middle)) + + (benchmark "French Latin-1 locale case compare terminally differing strings" 1000 + (string-fr-ci-op long-latin1-string long-latin1-string-diff-at-end)) + + (benchmark "French Latin-1 locale case compare identical strings" 1000 + (string-fr-ci-op long-latin1-string long-latin1-string)) + + (benchmark "French UTF-8 locale compare initially differing strings" 1000 + (string-fr-utf8-op long-latin1-string long-latin1-string-diff-at-start)) + + (benchmark "French UTF-8 locale compare medially differing strings" 1000 + (string-fr-utf8-op long-latin1-string long-latin1-string-diff-in-middle)) + + (benchmark "French UTF-8 locale compare terminally differing strings" 1000 + (string-fr-utf8-op long-latin1-string long-latin1-string-diff-at-end)) + + (benchmark "French UTF-8 locale compare identical strings" 1000 + (string-fr-utf8-op long-latin1-string long-latin1-string)) + + (benchmark "French UTF-8 locale case compare initially differing strings" 1000 + (string-fr-utf8-ci-op long-latin1-string long-latin1-string-diff-at-start)) + + (benchmark "French UTF-8 locale case compare medially differing strings" 1000 + (string-fr-utf8-ci-op long-latin1-string long-latin1-string-diff-in-middle)) + + (benchmark "French UTF-8 locale case compare terminally differing strings" 1000 + (string-fr-utf8-ci-op long-latin1-string long-latin1-string-diff-at-end)) + + (benchmark "French UTF-8 locale case compare identical strings" 1000 + (string-fr-utf8-ci-op long-latin1-string long-latin1-string))) + + (with-benchmark-prefix "short Unicode" + + (benchmark "compare initially differing strings" 100000 + (string-op short-cased-string short-cased-string-diff-at-start)) + + (benchmark "compare medially differing strings" 100000 + (string-op short-cased-string short-cased-string-diff-in-middle)) + + (benchmark "compare terminally differing strings" 100000 + (string-op short-cased-string short-cased-string-diff-at-end)) + + (benchmark "compare identical strings" 100000 + (string-op short-cased-string short-cased-string)) + + (benchmark "case compare initially differing strings" 100000 + (string-ci-op short-cased-string short-cased-string-diff-at-start)) + + (benchmark "case compare medially differing strings" 100000 + (string-ci-op short-cased-string short-cased-string-diff-in-middle)) + + (benchmark "case compare terminally differing strings" 100000 + (string-ci-op short-cased-string short-cased-string-diff-at-end)) + + (benchmark "case compare identical strings" 100000 + (string-ci-op short-cased-string short-cased-string)) + + (benchmark "French UTF-8 locale compare initially differing strings" 100000 + (string-fr-utf8-op short-cased-string short-cased-string-diff-at-start)) + + (benchmark "French UTF-8 locale compare medially differing strings" 100000 + (string-fr-utf8-op short-cased-string short-cased-string-diff-in-middle)) + + (benchmark "French UTF-8 locale compare terminally differing strings" 100000 + (string-fr-utf8-op short-cased-string short-cased-string-diff-at-end)) + + (benchmark "French UTF-8 locale compare identical strings" 100000 + (string-fr-utf8-op short-cased-string short-cased-string)) + + (benchmark "French UTF-8 locale case compare initially differing strings" 100000 + (string-fr-utf8-ci-op short-cased-string short-cased-string-diff-at-start)) + + (benchmark "French UTF-8 locale case compare medially differing strings" 100000 + (string-fr-utf8-ci-op short-cased-string short-cased-string-diff-in-middle)) + + (benchmark "French UTF-8 locale case compare terminally differing strings" 100000 + (string-fr-utf8-ci-op short-cased-string short-cased-string-diff-at-end)) + + (benchmark "French UTF-8 locale case compare identical strings" 100000 + (string-fr-utf8-ci-op short-cased-string short-cased-string))) + + (with-benchmark-prefix "medium Unicode" + + (benchmark "compare initially differing strings" 10000 + (string-op medium-cased-string medium-cased-string-diff-at-start)) + + (benchmark "compare medially differing strings" 10000 + (string-op medium-cased-string medium-cased-string-diff-in-middle)) + + (benchmark "compare terminally differing strings" 10000 + (string-op medium-cased-string medium-cased-string-diff-at-end)) + + (benchmark "compare identical strings" 10000 + (string-op medium-cased-string medium-cased-string)) + + (benchmark "case compare initially differing strings" 10000 + (string-ci-op medium-cased-string medium-cased-string-diff-at-start)) + + (benchmark "case compare medially differing strings" 10000 + (string-ci-op medium-cased-string medium-cased-string-diff-in-middle)) + + (benchmark "case compare terminally differing strings" 10000 + (string-ci-op medium-cased-string medium-cased-string-diff-at-end)) + + (benchmark "case compare identical strings" 10000 + (string-ci-op medium-cased-string medium-cased-string)) + + (benchmark "French UTF-8 locale compare initially differing strings" 10000 + (string-fr-utf8-op medium-cased-string medium-cased-string-diff-at-start)) + + (benchmark "French UTF-8 locale compare medially differing strings" 10000 + (string-fr-utf8-op medium-cased-string medium-cased-string-diff-in-middle)) + + (benchmark "French UTF-8 locale compare terminally differing strings" 10000 + (string-fr-utf8-op medium-cased-string medium-cased-string-diff-at-end)) + + (benchmark "French UTF-8 locale compare identical strings" 10000 + (string-fr-utf8-op medium-cased-string medium-cased-string)) + + (benchmark "French UTF-8 locale case compare initially differing strings" 10000 + (string-fr-utf8-ci-op medium-cased-string medium-cased-string-diff-at-start)) + + (benchmark "French UTF-8 locale case compare medially differing strings" 10000 + (string-fr-utf8-ci-op medium-cased-string medium-cased-string-diff-in-middle)) + + (benchmark "French UTF-8 locale case compare terminally differing strings" 10000 + (string-fr-utf8-ci-op medium-cased-string medium-cased-string-diff-at-end)) + + (benchmark "French UTF-8 locale case compare identical strings" 10000 + (string-fr-utf8-ci-op medium-cased-string medium-cased-string))) + + (with-benchmark-prefix "long Unicode" + + (benchmark "compare initially differing strings" 1000 + (string-op long-cased-string long-cased-string-diff-at-start)) + + (benchmark "compare medially differing strings" 1000 + (string-op long-cased-string long-cased-string-diff-in-middle)) + + (benchmark "compare terminally differing strings" 1000 + (string-op long-cased-string long-cased-string-diff-at-end)) + + (benchmark "compare identical strings" 1000 + (string-op long-cased-string long-cased-string)) + + (benchmark "case compare initially differing strings" 1000 + (string-ci-op long-cased-string long-cased-string-diff-at-start)) + + (benchmark "case compare medially differing strings" 1000 + (string-ci-op long-cased-string long-cased-string-diff-in-middle)) + + (benchmark "case compare terminally differing strings" 1000 + (string-ci-op long-cased-string long-cased-string-diff-at-end)) + + (benchmark "case compare identical strings" 1000 + (string-ci-op long-cased-string long-cased-string)) + + (benchmark "French UTF-8 locale compare initially differing strings" 1000 + (string-fr-utf8-op long-cased-string long-cased-string-diff-at-start)) + + (benchmark "French UTF-8 locale compare medially differing strings" 1000 + (string-fr-utf8-op long-cased-string long-cased-string-diff-in-middle)) + + (benchmark "French UTF-8 locale compare terminally differing strings" 1000 + (string-fr-utf8-op long-cased-string long-cased-string-diff-at-end)) + + (benchmark "French UTF-8 locale compare identical strings" 1000 + (string-fr-utf8-op long-cased-string long-cased-string)) + + (benchmark "French UTF-8 locale case compare initially differing strings" 1000 + (string-fr-utf8-ci-op long-cased-string long-cased-string-diff-at-start)) + + (benchmark "French UTF-8 locale case compare medially differing strings" 1000 + (string-fr-utf8-ci-op long-cased-string long-cased-string-diff-in-middle)) + + (benchmark "French UTF-8 locale case compare terminally differing strings" 1000 + (string-fr-utf8-ci-op long-cased-string long-cased-string-diff-at-end)) + + (benchmark "French UTF-8 locale case compare identical strings" 1000 + (string-fr-utf8-ci-op long-cased-string long-cased-string)))) + + diff --git a/benchmark-suite/benchmarks/structs.bm b/benchmark-suite/benchmarks/structs.bm new file mode 100644 index 000000000..465afbd24 --- /dev/null +++ b/benchmark-suite/benchmarks/structs.bm @@ -0,0 +1,51 @@ +;;; -*- mode: scheme; coding: iso-8859-1; -*- +;;; Structs. +;;; +;;; Copyright 2009, 2017 Free Software Foundation, Inc. +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 3, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this software; see the file COPYING.LESSER. If +;;; not, write to the Free Software Foundation, Inc., 51 Franklin +;;; Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (benchmarks structs) + :use-module (benchmark-suite lib)) + +;; Note: Use `--iteration-factor' to change this. +(define iterations 2000000) + +(define vtable2 + (make-vtable "pwpw")) + +(define vtable7 + (make-vtable (string-concatenate (make-list 7 "pw")))) + + +(with-benchmark-prefix "constructors" + + (benchmark "make-struct2" iterations + (make-struct/no-tail vtable2 1 2)) + + (benchmark "make-struct7" iterations + (make-struct/no-tail vtable7 1 2 3 4 5 6 7))) + + +(with-benchmark-prefix "pairs" ;; for comparison + (benchmark "cons" iterations + (cons 1 2)) + + (benchmark "list" iterations + (list 1 2 3 4 5 6 7)) + + (benchmark "make-list" iterations + (make-list 7))) diff --git a/benchmark-suite/benchmarks/subr.bm b/benchmark-suite/benchmarks/subr.bm new file mode 100644 index 000000000..ea0045650 --- /dev/null +++ b/benchmark-suite/benchmarks/subr.bm @@ -0,0 +1,66 @@ +;;; subr.bm --- Measure the subr invocation cost. -*- Scheme -*- +;;; +;;; Copyright (C) 2009 Free Software Foundation, Inc. +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 3, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this software; see the file COPYING.LESSER. If +;;; not, write to the Free Software Foundation, Inc., 51 Franklin +;;; Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (benchmarks subrs) + :use-module (benchmark-suite lib)) + + +(define hook1 (make-hook 1)) +(define hook3 (make-hook 3)) + +(with-benchmark-prefix "subr invocation" + + (benchmark "simple subr" 700000 + ;; 1 required argument, 0 optional arguments, no rest. + (1+ 0)) + + (benchmark "generic subr" 700000 + ;; 2 required arguments, 4 optional arguments, no rest. + + ;; In Guile 1.8 and earlier, such subrs are implemented as "compiled + ;; closures" (cclos). There, when a cclo/gsubr is called, the evaluator + ;; goes through `SCM_APPLY ()' and conses the arguments, which is more + ;; costly than the invocation of a "simple subr". + (string= "foo" "bar")) + + (benchmark "generic subr with rest arg" 700000 + ;; 1 required argument, 0 optional arguments, 1 rest. + (run-hook hook1 1)) + + (benchmark "generic subr with rest arg and 3+ parameters" 700000 + ;; 1 required argument, 0 optional arguments, 1 rest. + + ;; The evaluator considers calls with 3 and more parameters as a general + ;; form and always stores the arguments into a list. + (run-hook hook3 1 2 3))) + + +(with-benchmark-prefix "subr application" + + (benchmark "simple subr" 700000 + (apply 1+ '(0))) + + (benchmark "generic subr" 700000 + (apply string= "foo" '("bar"))) + + (benchmark "generic subr with rest arg" 700000 + (apply run-hook hook1 '(1))) + + (benchmark "generic subr with rest arg and 3+ parameters" 700000 + (run-hook hook3 1 2 '(3)))) diff --git a/benchmark-suite/benchmarks/vectors.bm b/benchmark-suite/benchmarks/vectors.bm new file mode 100644 index 000000000..4e47e008c --- /dev/null +++ b/benchmark-suite/benchmarks/vectors.bm @@ -0,0 +1,51 @@ +;;; -*- mode: scheme; coding: iso-8859-1; -*- +;;; Vectors. +;;; +;;; Copyright 2009 Free Software Foundation, Inc. +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 3, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this software; see the file COPYING.LESSER. If +;;; not, write to the Free Software Foundation, Inc., 51 Franklin +;;; Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (benchmarks vectors) + :use-module (benchmark-suite lib)) + +;; Note: Use `--iteration-factor' to change this. +(define iterations 1000000) + + +(with-benchmark-prefix "constructors" + + (benchmark "vector (opcode)" iterations + (vector 1 2 3 4 5 6 7)) + + (benchmark "vector (procedure)" iterations + (let ((v vector)) + (v 1 2 3 4 5 6 7))) + + (benchmark "make-vector" iterations + (make-vector 7))) + + +(with-benchmark-prefix "pairs" ;; for comparison + + (benchmark "list (opcode)" iterations + (list 1 2 3 4 5 6 7)) + + (benchmark "list (procedure)" iterations + (let ((l list)) + (l 1 2 3 4 5 6 7))) + + (benchmark "make-list" iterations + (make-list 7))) diff --git a/benchmark-suite/benchmarks/vlists.bm b/benchmark-suite/benchmarks/vlists.bm new file mode 100644 index 000000000..329c78623 --- /dev/null +++ b/benchmark-suite/benchmarks/vlists.bm @@ -0,0 +1,103 @@ +;;; -*- mode: scheme; coding: iso-8859-1; -*- +;;; VLists. +;;; +;;; Copyright 2009 Free Software Foundation, Inc. +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 3, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this software; see the file COPYING.LESSER. If +;;; not, write to the Free Software Foundation, Inc., 51 Franklin +;;; Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (benchmarks vlists) + :use-module (srfi srfi-1) + :use-module (ice-9 vlist) + :use-module (benchmark-suite lib)) + +;; Note: Use `--iteration-factor' to change this. +(define iterations 2000000) + +;; The size of large lists. +(define %list-size 700000) + +(define %big-list (make-list %list-size)) +(define %big-vlist (list->vlist %big-list)) + +(define-syntax comparative-benchmark + (syntax-rules () + ((_ benchmark-name iterations + ((api ((name value) ...))) + body ...) + (benchmark (format #f "~A (~A)" benchmark-name 'api) + iterations + (let ((name value) ...) + body ...))) + ((_ benchmark-name iterations + ((api bindings) apis ...) + body ...) + (begin + (comparative-benchmark benchmark-name iterations + ((api bindings)) + body ...) + (comparative-benchmark benchmark-name iterations + (apis ...) + body ...))))) + + +(with-benchmark-prefix "constructors" + + (comparative-benchmark "cons" 2 + ((srfi-1 ((cons cons) (null '()))) + (vlist ((cons vlist-cons) (null vlist-null)))) + (let loop ((i %list-size) + (r null)) + (and (> i 0) + (loop (1- i) (cons #t r))))) + + + (comparative-benchmark "acons" 2 + ((srfi-1 ((acons alist-cons) (null '()))) + (vlist ((acons vhash-cons) (null vlist-null)))) + (let loop ((i %list-size) + (r null)) + (if (zero? i) + r + (loop (1- i) (acons i i r)))))) + + +(define %big-alist + (let loop ((i %list-size) (res '())) + (if (zero? i) + res + (loop (1- i) (alist-cons i i res))))) +(define %big-vhash + (let loop ((i %list-size) (res vlist-null)) + (if (zero? i) + res + (loop (1- i) (vhash-cons i i res))))) + + +(with-benchmark-prefix "iteration" + + (comparative-benchmark "fold" 2 + ((srfi-1 ((fold fold) (lst %big-list))) + (vlist ((fold vlist-fold) (lst %big-vlist)))) + (fold (lambda (x y) y) #t lst)) + + (comparative-benchmark "assoc" 70 + ((srfi-1 ((assoc assoc) (alst %big-alist))) + (vhash ((assoc vhash-assoc) (alst %big-vhash)))) + (let loop ((i (quotient %list-size 3))) + (and (> i 0) + (begin + (assoc i alst) + (loop (- i 5000))))))) diff --git a/benchmark-suite/benchmarks/write.bm b/benchmark-suite/benchmarks/write.bm new file mode 100644 index 000000000..46f5c8d1c --- /dev/null +++ b/benchmark-suite/benchmarks/write.bm @@ -0,0 +1,52 @@ +;;; write.bm --- Exercise the printer. -*- Scheme -*- +;;; +;;; Copyright (C) 2010 Free Software Foundation, Inc. +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 3, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this software; see the file COPYING.LESSER. If +;;; not, write to the Free Software Foundation, Inc., 51 Franklin +;;; Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (benchmarks write) + #:use-module (benchmark-suite lib)) + +(define %len 50000) + +(define %string-with-escapes + (list->string (map integer->char (iota %len)))) + +(define %string-without-escapes + (make-string %len #\a)) + +;; Use Unicode-capable ports. +(fluid-set! %default-port-encoding "UTF-8") + +(define %null + (%make-void-port OPEN_WRITE)) + + +(with-benchmark-prefix "write" + + (benchmark "string with escapes" 50 + (write %string-with-escapes %null)) + + (benchmark "string without escapes" 50 + (write %string-without-escapes %null))) + +(with-benchmark-prefix "display" + + (benchmark "string with escapes" 1000 + (display %string-with-escapes %null)) + + (benchmark "string without escapes" 1000 + (display %string-without-escapes %null))) diff --git a/benchmark-suite/guile-benchmark b/benchmark-suite/guile-benchmark new file mode 100755 index 000000000..da2b2a1ad --- /dev/null +++ b/benchmark-suite/guile-benchmark @@ -0,0 +1,220 @@ +#!../libguile/guile \ +-e main -s +!# + +;;;; guile-benchmark --- run the Guile benchmark suite +;;;; Adapted from code by Jim Blandy <jimb@red-bean.com> --- May 1999 +;;;; +;;;; Copyright (C) 2002, 2006, 2010 Free Software Foundation, Inc. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3, or (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this software; see the file COPYING.LESSER. +;;;; If not, write to the Free Software Foundation, Inc., 51 Franklin +;;;; Street, Fifth Floor, Boston, MA 02110-1301 USA + + +;;;; Usage: [guile -e main -s] guile-benchmark [OPTIONS] [BENCHMARK ...] +;;;; +;;;; Run benchmarks from the Guile benchmark suite. Report timing +;;;; results to the standard output, along with a summary of all +;;;; the results. Record each reported benchmark outcome in the log +;;;; file, `benchmarks.log'. +;;;; +;;;; Normally, guile-benchmark scans the benchmark directory, and +;;;; executes all files whose names end in `.bm'. (It assumes they contain +;;;; Scheme code.) However, you can have it execute specific benchmarks by +;;;; listing their filenames on the command line. +;;;; +;;;; The option `--benchmark-suite' can be given to specify the benchmark +;;;; directory. If no such option is given, the benchmark directory is +;;;; taken from the environment variable BENCHMARK_SUITE_DIR (if defined), +;;;; otherwise a default directory that is hardcoded in this file is +;;;; used (see "Installation" below). +;;;; +;;;; If present, the `--iteration-factor FACTOR' option tells +;;;; `guile-benchmark' to multiply the number of iterations given with +;;;; each single benchmark by the value of FACTOR. This allows to +;;;; reduce or increase the total time for benchmarking. +;;;; +;;;; If present, the `--log-file LOG' option tells `guile-benchmark' to put +;;;; the log output in a file named LOG. +;;;; +;;;; If present, the `--debug' option will enable a debugging mode. +;;;; +;;;; +;;;; Installation: +;;;; +;;;; If you change the #! line at the top of this script to point at +;;;; the Guile interpreter you want to run, you can call this script +;;;; as an executable instead of having to pass it as a parameter to +;;;; guile via "guile -e main -s guile-benchmark". Further, you can edit +;;;; the definition of default-benchmark-suite to point to the parent +;;;; directory of the `benchmarks' tree, which makes it unnecessary to set +;;;; the environment variable `BENCHMARK_SUITE_DIR'. +;;;; +;;;; +;;;; Shortcomings: +;;;; +;;;; At the moment, due to a simple-minded implementation, benchmark files +;;;; must live in the benchmark directory, and you must specify their names +;;;; relative to the top of the benchmark directory. If you want to send +;;;; me a patch that fixes this, but still leaves sane benchmark names in +;;;; the log file, that would be great. At the moment, all the benchmarks +;;;; I care about are in the benchmark directory, though. +;;;; +;;;; It would be nice if you could specify the Guile interpreter you +;;;; want to benchmark on the command line. As it stands, if you want to +;;;; change which Guile interpreter you're benchmarking, you need to edit +;;;; the #! line at the top of this file, which is stupid. + + +;;; User configurable settings: +(define default-benchmark-suite + (string-append (getenv "HOME") "/bogus-path/benchmark-suite")) + + +(use-modules (benchmark-suite lib) + (ice-9 getopt-long) + (ice-9 and-let-star) + (ice-9 rdelim)) + + +;;; Variables that will receive their actual values later. +(define benchmark-suite default-benchmark-suite) + +(define tmp-dir #f) + + +;;; General utilities, that probably should be in a library somewhere. + +;;; Enable debugging +(define (enable-debug-mode) + (write-line %load-path) + (set! %load-verbosely #t) + (debug-enable 'backtrace 'debug)) + +;;; Traverse the directory tree at ROOT, applying F to the name of +;;; each file in the tree, including ROOT itself. For a subdirectory +;;; SUB, if (F SUB) is true, we recurse into SUB. Do not follow +;;; symlinks. +(define (for-each-file f root) + + ;; A "hard directory" is a path that denotes a directory and is not a + ;; symlink. + (define (file-is-hard-directory? filename) + (eq? (stat:type (lstat filename)) 'directory)) + + (let visit ((root root)) + (let ((should-recur (f root))) + (if (and should-recur (file-is-hard-directory? root)) + (let ((dir (opendir root))) + (let loop () + (let ((entry (readdir dir))) + (cond + ((eof-object? entry) #f) + ((or (string=? entry ".") + (string=? entry "..") + (string=? entry "CVS") + (string=? entry "RCS")) + (loop)) + (else + (visit (string-append root "/" entry)) + (loop)))))))))) + + +;;; The benchmark driver. + + +;;; Localizing benchmark files and temporary data files. + +(define (data-file-name filename) + (in-vicinity tmp-dir filename)) + +(define (benchmark-file-name benchmark) + (in-vicinity benchmark-suite benchmark)) + +;;; Return a list of all the benchmark files in the benchmark tree. +(define (enumerate-benchmarks benchmark-dir) + (let ((root-len (+ 1 (string-length benchmark-dir))) + (benchmarks '())) + (for-each-file (lambda (file) + (if (string-suffix? ".bm" file) + (let ((short-name + (substring file root-len))) + (set! benchmarks (cons short-name benchmarks)))) + #t) + benchmark-dir) + + ;; for-each-file presents the files in whatever order it finds + ;; them in the directory. We sort them here, so they'll always + ;; appear in the same order. This makes it easier to compare benchmark + ;; log files mechanically. + (sort benchmarks string<?))) + +(define (main args) + (let ((options (getopt-long args + `((benchmark-suite + (single-char #\t) + (value #t)) + (iteration-factor + (single-char #\t) + (value #t)) + (log-file + (single-char #\l) + (value #t)) + (debug + (single-char #\d)))))) + (define (opt tag default) + (let ((pair (assq tag options))) + (if pair (cdr pair) default))) + + (if (opt 'debug #f) + (enable-debug-mode)) + + (set! benchmark-suite + (or (opt 'benchmark-suite #f) + (getenv "BENCHMARK_SUITE_DIR") + default-benchmark-suite)) + + (set! iteration-factor + (string->number (opt 'iteration-factor "1"))) + + ;; directory where temporary files are created. + (set! tmp-dir (getcwd)) + + (let* ((benchmarks + (let ((foo (opt '() '()))) + (if (null? foo) + (enumerate-benchmarks benchmark-suite) + foo))) + (log-file + (opt 'log-file "benchmarks.log"))) + + ;; Open the log file. + (let ((log-port (open-output-file log-file))) + + ;; Register some reporters. + (register-reporter (make-log-reporter log-port)) + (register-reporter user-reporter) + + ;; Run the benchmarks. + (for-each (lambda (benchmark) + (with-benchmark-prefix benchmark + (load (benchmark-file-name benchmark)))) + benchmarks) + (close-port log-port))))) + + +;;; Local Variables: +;;; mode: scheme +;;; End: diff --git a/benchmark-suite/results/neil-arudy b/benchmark-suite/results/neil-arudy new file mode 100644 index 000000000..7b61d399c --- /dev/null +++ b/benchmark-suite/results/neil-arudy @@ -0,0 +1,93 @@ +Benchmarking /home/neil/SW/Guile/git/meta/guile ... +with GUILE_LOAD_PATH=/home/neil/SW/Guile/git/benchmark-suite +;; running guile version 1.9.3 +;; calibrating the benchmarking framework... +;; framework time per iteration: 5.7220458984375e-7 +("0-reference.bm: reference benchmark for iteration counts" 330000 user 0.2 benchmark 0.0111724853515625 bench/interp 0.0111724853515625 gc 0.0) +("bytevectors.bm: ref/set!: bytevector-u8-ref" 1000000 user 0.73 benchmark 0.15779541015625 bench/interp 0.15779541015625 gc 0.0) +("bytevectors.bm: ref/set!: bytevector-u16-ref (foreign)" 1000000 user 0.82 benchmark 0.24779541015625 bench/interp 0.24779541015625 gc 0.0) +("bytevectors.bm: ref/set!: bytevector-u16-ref (native)" 1000000 user 0.78 benchmark 0.20779541015625 bench/interp 0.20779541015625 gc 0.0) +("bytevectors.bm: ref/set!: bytevector-u16-native-ref" 1000000 user 0.72 benchmark 0.14779541015625 bench/interp 0.14779541015625 gc 0.0) +("bytevectors.bm: ref/set!: bytevector-u32-ref (foreign)" 1000000 user 1.61 benchmark 1.03779541015625 bench/interp 1.03779541015625 gc 0.0) +("bytevectors.bm: ref/set!: bytevector-u32-ref (native)" 1000000 user 0.8 benchmark 0.22779541015625 bench/interp 0.22779541015625 gc 0.0) +("bytevectors.bm: ref/set!: bytevector-u32-native-ref" 1000000 user 0.74 benchmark 0.16779541015625 bench/interp 0.16779541015625 gc 0.0) +("bytevectors.bm: ref/set!: bytevector-u64-ref (foreign)" 1000000 user 1.86 benchmark 1.28779541015625 bench/interp 1.28779541015625 gc 0.0) +("bytevectors.bm: ref/set!: bytevector-u64-ref (native)" 1000000 user 0.81 benchmark 0.23779541015625 bench/interp 0.23779541015625 gc 0.0) +("bytevectors.bm: ref/set!: bytevector-u64-native-ref" 1000000 user 0.73 benchmark 0.15779541015625 bench/interp 0.15779541015625 gc 0.0) +("bytevectors.bm: lists: bytevector->u8-list" 2000 user 9.87 benchmark 9.86885559082031 bench/interp 9.86885559082031 gc 0.0) +("bytevectors.bm: lists: bytevector->uint-list 16-bit" 2000 user 4.48 benchmark 4.47885559082031 bench/interp 4.47885559082031 gc 0.0) +("bytevectors.bm: lists: bytevector->uint-list 64-bit" 2000 user 3.75 benchmark 3.74885559082031 bench/interp 3.74885559082031 gc 0.0) +("bytevectors.bm: SRFI-4: u8vector-ref" 1000000 user 1.88 benchmark 1.30779541015625 bench/interp 1.30779541015625 gc 0.0) +("bytevectors.bm: SRFI-4: u16vector-ref" 1000000 user 1.9 benchmark 1.32779541015625 bench/interp 1.32779541015625 gc 0.0) +("bytevectors.bm: SRFI-4: u32vector-ref" 1000000 user 1.88 benchmark 1.30779541015625 bench/interp 1.30779541015625 gc 0.0) +("bytevectors.bm: SRFI-4: u64vector-ref" 1000000 user 1.98 benchmark 1.40779541015625 bench/interp 1.40779541015625 gc 0.0) +("chars.bm: chars: char" 1000000 user 0.63 benchmark 0.05779541015625 bench/interp 0.05779541015625 gc 0.0) +("chars.bm: chars: octal" 1000000 user 0.64 benchmark 0.06779541015625 bench/interp 0.06779541015625 gc 0.0) +("chars.bm: chars: char? eq" 1000000 user 1.19 benchmark 0.61779541015625 bench/interp 0.61779541015625 gc 0.0) +("chars.bm: chars: char=?" 1000000 user 1.45 benchmark 0.87779541015625 bench/interp 0.87779541015625 gc 0.0) +("chars.bm: chars: char<?" 1000000 user 1.45 benchmark 0.87779541015625 bench/interp 0.87779541015625 gc 0.0) +("chars.bm: chars: char-ci=?" 1000000 user 1.45 benchmark 0.87779541015625 bench/interp 0.87779541015625 gc 0.0) +("chars.bm: chars: char-ci<? " 1000000 user 1.45 benchmark 0.87779541015625 bench/interp 0.87779541015625 gc 0.0) +("chars.bm: chars: char->integer" 1000000 user 1.2 benchmark 0.62779541015625 bench/interp 0.62779541015625 gc 0.0) +("chars.bm: chars: char-alphabetic?" 1000000 user 1.36 benchmark 0.78779541015625 bench/interp 0.78779541015625 gc 0.0) +("chars.bm: chars: char-numeric?" 1000000 user 1.36 benchmark 0.78779541015625 bench/interp 0.78779541015625 gc 0.0) +("continuations.bm: call/cc" 300 user 0.03 benchmark 0.0298283386230469 bench/interp 0.0298283386230469 gc 0.0) +("if.bm: if-<expr>-then-else: executing then" 330000 user 0.23 benchmark 0.0411724853515625 bench/interp 0.0411724853515625 gc 0.0) +("if.bm: if-<expr>-then-else: executing else" 330000 user 0.23 benchmark 0.0411724853515625 bench/interp 0.0411724853515625 gc 0.0) +("if.bm: if-<expr>-then: executing then" 330000 user 0.23 benchmark 0.0411724853515625 bench/interp 0.0411724853515625 gc 0.0) +("if.bm: if-<expr>-then: executing else" 330000 user 0.24 benchmark 0.0511724853515625 bench/interp 0.0511724853515625 gc 0.0) +("if.bm: if-<iloc>-then-else: executing then" 330000 user 0.25 benchmark 0.0611724853515625 bench/interp 0.0611724853515625 gc 0.0) +("if.bm: if-<iloc>-then-else: executing else" 330000 user 0.24 benchmark 0.0511724853515625 bench/interp 0.0511724853515625 gc 0.0) +("if.bm: if-<iloc>-then: executing then" 330000 user 0.24 benchmark 0.0511724853515625 bench/interp 0.0511724853515625 gc 0.0) +("if.bm: if-<iloc>-then: executing else" 330000 user 0.24 benchmark 0.0511724853515625 bench/interp 0.0511724853515625 gc 0.0) +("if.bm: if-<bool>-then-else: executing then" 330000 user 0.23 benchmark 0.0411724853515625 bench/interp 0.0411724853515625 gc 0.0) +("if.bm: if-<bool>-then-else: executing else" 330000 user 0.23 benchmark 0.0411724853515625 bench/interp 0.0411724853515625 gc 0.0) +("if.bm: if-<bool>-then: executing then" 330000 user 0.24 benchmark 0.0511724853515625 bench/interp 0.0511724853515625 gc 0.0) +("if.bm: if-<bool>-then: executing else" 330000 user 0.23 benchmark 0.0411724853515625 bench/interp 0.0411724853515625 gc 0.0) +("logand.bm: bignum" 130000 user 0.48 benchmark 0.405613403320312 bench/interp 0.405613403320312 gc 0.0) +("read.bm: read: _IONBF" 5 user 12.71 benchmark 12.7099971389771 bench/interp 12.7099971389771 gc 0.0) +("read.bm: read: _IOLBF" 10 user 20.32 benchmark 20.3199942779541 bench/interp 20.3199942779541 gc 0.0) +("read.bm: read: _IOFBF 4096" 10 user 20.34 benchmark 20.3399942779541 bench/interp 20.3399942779541 gc 0.0) +("read.bm: read: _IOFBF 8192" 10 user 20.36 benchmark 20.3599942779541 bench/interp 20.3599942779541 gc 0.0) +("read.bm: read: _IOFBF 16384" 10 user 20.34 benchmark 20.3399942779541 bench/interp 20.3399942779541 gc 0.0) +("srfi-13.bm: strings: predicates: string?" 1190000 user 2.98 benchmark 2.29907653808594 bench/interp 2.29907653808594 gc 0.0) +("srfi-13.bm: strings: predicates: null?" 969000 user 2.56 benchmark 2.00553375244141 bench/interp 2.00553375244141 gc 0.0) +("srfi-13.bm: strings: predicates: any" 94000 user 1.89 benchmark 1.83621276855469 bench/interp 1.83621276855469 gc 0.0) +("srfi-13.bm: strings: predicates: every" 94000 user 1.53 benchmark 1.47621276855469 bench/interp 1.47621276855469 gc 0.0) +("srfi-13.bm: strings: constructors: string" 5000 user 2.02 benchmark 2.01713897705078 bench/interp 2.01713897705078 gc 0.0) +("srfi-13.bm: strings: constructors: list->" 4500 user 0.3 benchmark 0.297425079345703 bench/interp 0.297425079345703 gc 0.0) +("srfi-13.bm: strings: constructors: reverse-list->" 5000 user 0.58 benchmark 0.577138977050781 bench/interp 0.577138977050781 gc 0.0) +("srfi-13.bm: strings: constructors: make" 22000 user 0.52 benchmark 0.507411499023438 bench/interp 0.507411499023438 gc 0.0) +("srfi-13.bm: strings: constructors: tabulate" 17000 user 0.57 benchmark 0.560272521972656 bench/interp 0.560272521972656 gc 0.0) +("srfi-13.bm: strings: constructors: join" 5500 user 0.46 benchmark 0.456852874755859 bench/interp 0.456852874755859 gc 0.0) +("srfi-13.bm: strings: list/string: ->list" 7300 user 2.36 benchmark 2.35582290649414 bench/interp 2.35582290649414 gc 0.0) +("srfi-13.bm: strings: list/string: split" 60000 user 1.87 benchmark 1.83566772460938 bench/interp 1.83566772460938 gc 0.0) +("srfi-13.bm: strings: selection: ref" 660 user 1.5 benchmark 1.4996223449707 bench/interp 1.4996223449707 gc 0.0) +("srfi-13.bm: strings: selection: copy" 1100 user 0.04 benchmark 0.0393705749511719 bench/interp 0.0393705749511719 gc 0.0) +("srfi-13.bm: strings: selection: pad" 6800 user 0.17 benchmark 0.166109008789063 bench/interp 0.166109008789063 gc 0.0) +("srfi-13.bm: strings: selection: trim trim-right trim-both" 60000 user 2.67 benchmark 2.63566772460937 bench/interp 2.63566772460937 gc 0.0) +("srfi-13.bm: strings: modification: set!" 3000 user 1.42 benchmark 1.41828338623047 bench/interp 1.41828338623047 gc 0.0) +("srfi-13.bm: strings: modification: sub-move!" 230000 user 1.88 benchmark 1.74839294433594 bench/interp 1.74839294433594 gc 0.0) +("srfi-13.bm: strings: modification: fill!" 230000 user 2.31 benchmark 2.17839294433594 bench/interp 2.17839294433594 gc 0.0) +("srfi-13.bm: strings: modification: comparison: compare compare-ci" 140000 user 1.93 benchmark 1.84989135742187 bench/interp 1.84989135742187 gc 0.0) +("srfi-13.bm: strings: modification: comparison: hash hash-ci" 1000 user 0.27 benchmark 0.269427795410156 bench/interp 0.269427795410156 gc 0.0) +("srfi-13.bm: strings: searching: prefix-length suffix-length" 270 user 0.2 benchmark 0.199845504760742 bench/interp 0.199845504760742 gc 0.0) +("srfi-13.bm: strings: searching: prefix? suffix?" 270 user 0.2 benchmark 0.199845504760742 bench/interp 0.199845504760742 gc 0.0) +("srfi-13.bm: strings: searching: index index-right rindex" 100000 user 3.48 benchmark 3.42277954101562 bench/interp 3.42277954101562 gc 0.0) +("srfi-13.bm: strings: searching: skip skip-right?" 100000 user 2.14 benchmark 2.08277954101563 bench/interp 2.08277954101563 gc 0.0) +("srfi-13.bm: strings: searching: count" 10000 user 9.35 benchmark 9.34427795410156 bench/interp 9.34427795410156 gc 0.0) +("srfi-13.bm: strings: searching: contains contains-ci" 34000 user 2.29 benchmark 2.27054504394531 bench/interp 2.27054504394531 gc 0.0) +("srfi-13.bm: strings: searching: upcase downcase upcase! downcase!" 600 user 0.2 benchmark 0.199656677246094 bench/interp 0.199656677246094 gc 0.0) +("srfi-13.bm: strings: readers: read token, method 1" 1200 user 1.26 benchmark 1.25931335449219 bench/interp 1.25931335449219 gc 0.0) +("srfi-13.bm: strings: readers: read token, method 2" 1200 user 2.03 benchmark 2.02931335449219 bench/interp 2.02931335449219 gc 0.0) +("subr.bm: subr invocation: simple subr" 700000 user 0.47 benchmark 0.069456787109375 bench/interp 0.069456787109375 gc 0.0) +("subr.bm: subr invocation: generic subr" 700000 user 1.75 benchmark 1.34945678710938 bench/interp 1.34945678710938 gc 0.0) +("subr.bm: subr invocation: generic subr with rest arg" 700000 user 1.39 benchmark 0.989456787109375 bench/interp 0.989456787109375 gc 0.0) +("subr.bm: subr invocation: generic subr with rest arg and 3+ parameters" 700000 user 1.86 benchmark 1.45945678710938 bench/interp 1.45945678710938 gc 0.0) +("subr.bm: subr application: simple subr" 700000 user 0.91 benchmark 0.509456787109375 bench/interp 0.509456787109375 gc 0.0) +("subr.bm: subr application: generic subr" 700000 user 1.8 benchmark 1.39945678710938 bench/interp 1.39945678710938 gc 0.0) +("subr.bm: subr application: generic subr with rest arg" 700000 user 1.44 benchmark 1.03945678710937 bench/interp 1.03945678710937 gc 0.0) +("subr.bm: subr application: generic subr with rest arg and 3+ parameters" 700000 user 1.89 benchmark 1.48945678710937 bench/interp 1.48945678710937 gc 0.0) +("uniform-vector-read.bm: uniform-vector-read!: uniform-vector-write" 500 user 0.12 benchmark 0.119713897705078 bench/interp 0.119713897705078 gc 0.0) +("uniform-vector-read.bm: uniform-vector-read!: uniform-vector-read!" 500 user 0.02 benchmark 0.0197138977050781 bench/interp 0.0197138977050781 gc 0.0) +("uniform-vector-read.bm: uniform-vector-read!: string port" 5000 user 2.49 benchmark 2.48713897705078 bench/interp 2.48713897705078 gc 0.0) |