diff options
Diffstat (limited to 'gc-benchmarks/run-benchmark.scm')
-rwxr-xr-x | gc-benchmarks/run-benchmark.scm | 349 |
1 files changed, 349 insertions, 0 deletions
diff --git a/gc-benchmarks/run-benchmark.scm b/gc-benchmarks/run-benchmark.scm new file mode 100755 index 000000000..7a9e67b2f --- /dev/null +++ b/gc-benchmarks/run-benchmark.scm @@ -0,0 +1,349 @@ +#!/bin/sh +# -*- Scheme -*- +exec ${GUILE-guile} -q -l "$0" \ + -c '(apply main (cdr (command-line)))' \ + --benchmark-dir="$(dirname $0)" "$@" +!# +;;; Copyright (C) 2008, 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 + +(use-modules (ice-9 rdelim) + (ice-9 popen) + (ice-9 regex) + (ice-9 format) + (ice-9 pretty-print) + (srfi srfi-1) + (srfi srfi-37)) + + +;;; +;;; Running Guile. +;;; + +(define (run-reference-guile env bench-dir profile-opts bench) + "Run the ``mainstream'' Guile, i.e., Guile 1.9 with its own GC." + (open-input-pipe (string-append + env " " + bench-dir "/gc-profile.scm " profile-opts + " \"" bench "\""))) + +(define (run-bdwgc-guile env bench-dir profile-opts options bench) + "Run the Guile port to the Boehm-Demers-Weiser GC (BDW-GC)." + (let ((fsd (assoc-ref options 'free-space-divisor))) + (open-input-pipe (string-append env " " + "GC_FREE_SPACE_DIVISOR=" + (number->string fsd) + + (if (or (assoc-ref options 'incremental?) + (assoc-ref options 'generational?)) + " GC_ENABLE_INCREMENTAL=yes" + "") + (if (assoc-ref options 'generational?) + " GC_PAUSE_TIME_TARGET=999999" + "") + (if (assoc-ref options 'parallel?) + "" ;; let it choose the number of procs + " GC_MARKERS=1") + " " + bench-dir "/gc-profile.scm " profile-opts + " \"" bench "\"")))) + + +;;; +;;; Extracting performance results. +;;; + +(define (grep regexp input) + "Read line by line from the @var{input} port and return all matches for +@var{regexp}." + (let ((regexp (if (string? regexp) (make-regexp regexp) regexp))) + (with-input-from-port input + (lambda () + (let loop ((line (read-line)) + (result '())) + (format #t "> ~A~%" line) + (if (eof-object? line) + (reverse result) + (cond ((regexp-exec regexp line) + => + (lambda (match) + (loop (read-line) + (cons match result)))) + (else + (loop (read-line) result))))))))) + +(define (parse-result benchmark-output) + (let ((result (grep "^(execution time|heap size):[[:blank:]]+([0-9.]+)" + benchmark-output))) + (fold (lambda (match result) + (cond ((equal? (match:substring match 1) "execution time") + (cons (cons 'execution-time + (string->number (match:substring match 2))) + result)) + ((equal? (match:substring match 1) "heap size") + (cons (cons 'heap-size + (string->number (match:substring match 2))) + result)) + (else + result))) + '() + result))) + +(define (pretty-print-result benchmark reference bdwgc) + (define ref-heap (assoc-ref reference 'heap-size)) + (define ref-time (assoc-ref reference 'execution-time)) + + (define (distance x1 y1 x2 y2) + ;; Return the distance between (X1,Y1) and (X2,Y2). Y is the heap size, + ;; in MiB and X is the execution time in seconds. + (let ((y1 (/ y1 (expt 2 20))) + (y2 (/ y2 (expt 2 20)))) + (sqrt (+ (expt (- y1 y2) 2) + (expt (- x1 x2) 2))))) + + (define (score time heap) + ;; Return a score lower than +1.0. The score is positive if the + ;; distance to the origin of (TIME,HEAP) is smaller than that of + ;; (REF-TIME,REF-HEAP), negative otherwise. + + ;; heap ^ . + ;; size | . worse + ;; | . [-] + ;; | . + ;; | . . . .ref. . . . + ;; | . + ;; | [+] . + ;; | better . + ;; 0 +--------------------> + ;; exec. time + + (let ((ref-dist (distance ref-time ref-heap 0 0)) + (dist (distance time heap 0 0))) + (/ (- ref-dist dist) ref-dist))) + + (define (score-string time heap) + ;; Return a string denoting a bar to illustrate the score of (TIME,HEAP) + ;; relative to (REF-TIME,REF-HEAP). + (define %max-width 15) + + (let ((s (score time heap))) + (make-string (inexact->exact (round (* (if (< s 0.0) (- s) s) + %max-width))) + (if (< s 0.0) + #\- + #\+)))) + + (define (print-line name result ref?) + (let ((name (string-pad-right name 23)) + (time (assoc-ref result 'execution-time)) + (heap (assoc-ref result 'heap-size))) + (format #t "~a ~6,2f (~,2fx) ~7,3f (~,2fx)~A~%" + name + (/ heap (expt 2.0 20)) (/ heap ref-heap 1.0) + time (/ time ref-time 1.0) + (if (not ref?) + (string-append " " + (score-string time heap)) + "")))) + + (format #t "benchmark: `~a'~%" benchmark) + (format #t " heap size (MiB) execution time (s.)~%") + (print-line "Guile" reference #t) + (for-each (lambda (bdwgc) + (let ((name (format #f "BDW-GC, FSD=~a~a" + (assoc-ref bdwgc 'free-space-divisor) + (cond ((assoc-ref bdwgc 'incremental?) + " incr.") + ((assoc-ref bdwgc 'generational?) + " gene.") + ((assoc-ref bdwgc 'parallel?) + " paral.") + (else ""))))) + (print-line name bdwgc #f))) + bdwgc)) + +(define (print-raw-result benchmark reference bdwgc) + (pretty-print `(,benchmark + (reference . ,reference) + (bdw-gc . ,bdwgc)))) + + + +;;; +;;; Option processing. +;;; + +(define %options + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\r "reference") #t #f + (lambda (opt name arg result) + (alist-cons 'reference-environment arg + (alist-delete 'reference-environment result + eq?)))) + (option '(#\b "bdw-gc") #t #f + (lambda (opt name arg result) + (alist-cons 'bdwgc-environment arg + (alist-delete 'bdwgc-environment result + eq?)))) + (option '(#\d "benchmark-dir") #t #f + (lambda (opt name arg result) + (alist-cons 'benchmark-directory arg + (alist-delete 'benchmark-directory result + eq?)))) + (option '(#\p "profile-options") #t #f + (lambda (opt name arg result) + (let ((opts (assoc-ref result 'profile-options))) + (alist-cons 'profile-options + (string-append opts " " arg) + (alist-delete 'profile-options result + eq?))))) + (option '(#\l "log-file") #t #f + (lambda (opt name arg result) + (alist-cons 'log-port (open-output-file arg) + (alist-delete 'log-port result + eq?)))) + (option '("raw") #f #f + (lambda (opt name arg result) + (alist-cons 'printer print-raw-result + (alist-delete 'printer result eq?)))) + (option '("load-results") #f #f + (lambda (opt name arg result) + (alist-cons 'load-results? #t result))))) + +(define %default-options + `((reference-environment . "GUILE=guile") + (benchmark-directory . "./gc-benchmarks") + (log-port . ,(current-output-port)) + (profile-options . "") + (input . ()) + (printer . ,pretty-print-result))) + +(define (show-help) + (format #t "Usage: run-benchmark [OPTIONS] BENCHMARKS... +Run BENCHMARKS (a list of Scheme files) and display a performance +comparison of standard Guile (1.9) and the BDW-GC-based Guile. + + -h, --help Show this help message + + -r, --reference=ENV + -b, --bdw-gc=ENV + Use ENV as the environment necessary to run the + \"reference\" Guile (1.9) or the BDW-GC-based Guile, + respectively. At a minimum, ENV should define the + `GUILE' environment variable. For example: + + --reference='GUILE=/foo/bar/guile LD_LIBRARY_PATH=/foo' + + -p, --profile-options=OPTS + Pass OPTS as additional options for `gc-profile.scm'. + -l, --log-file=FILE + Save output to FILE instead of the standard output. + + --raw Write benchmark results in raw (s-exp) format. + --load-results + Load raw (s-exp) results instead of actually running + the benchmarks. + + -d, --benchmark-dir=DIR + Use DIR as the GC benchmark directory where `gc-profile.scm' + lives (it is automatically determined by default). + +Report bugs to <bug-guile@gnu.org>.~%")) + +(define (parse-args args) + (define (leave fmt . args) + (apply format (current-error-port) (string-append fmt "~%") args) + (exit 1)) + + (args-fold args %options + (lambda (opt name arg result) + (leave "~A: unrecognized option" opt)) + (lambda (file result) + (let ((files (or (assoc-ref result 'input) '()))) + (alist-cons 'input (cons file files) + (alist-delete 'input result eq?)))) + %default-options)) + + +;;; +;;; The main program. +;;; + +(define (main . args) + (let* ((args (parse-args args)) + (benchmark-files (assoc-ref args 'input))) + + (let* ((log (assoc-ref args 'log-port)) + (bench-dir (assoc-ref args 'benchmark-directory)) + (ref-env (assoc-ref args 'reference-environment)) + (bdwgc-env (or (assoc-ref args 'bdwgc-environment) + (string-append "GUILE=" bench-dir + "/../meta/guile"))) + (prof-opts (assoc-ref args 'profile-options)) + (print (assoc-ref args 'printer))) + (define (run benchmark) + (let ((ref (parse-result (run-reference-guile ref-env + bench-dir + prof-opts + benchmark))) + (bdwgc (map (lambda (fsd incremental? + generational? parallel?) + (let ((opts + (list + (cons 'free-space-divisor fsd) + (cons 'incremental? incremental?) + (cons 'generational? generational?) + (cons 'parallel? parallel?)))) + (append opts + (parse-result + (run-bdwgc-guile bdwgc-env + bench-dir + prof-opts + opts + benchmark))))) + '( 3 6 9 3 3) + '(#f #f #f #t #f) ;; incremental + '(#f #f #f #f #t) ;; generational + '(#f #f #f #f #f)))) ;; parallel + `(,benchmark + (reference . ,ref) + (bdw-gc . ,bdwgc)))) + + (define (load-results file) + (with-input-from-file file + (lambda () + (let loop ((results '()) (o (read))) + (if (eof-object? o) + (reverse results) + (loop (cons o results) + (read))))))) + + (for-each (lambda (result) + (let ((benchmark (car result)) + (ref (assoc-ref (cdr result) 'reference)) + (bdwgc (assoc-ref (cdr result) 'bdw-gc))) + (with-output-to-port log + (lambda () + (print benchmark ref bdwgc) + (newline) + (force-output))))) + (if (assoc-ref args 'load-results?) + (append-map load-results benchmark-files) + (map run benchmark-files)))))) |