mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
53befeb700
(Not quite finished, the following will be done tomorrow. module/srfi/*.scm module/rnrs/*.scm module/scripts/*.scm testsuite/*.scm guile-readline/* )
269 lines
11 KiB
Scheme
Executable file
269 lines
11 KiB
Scheme
Executable file
#!/bin/sh
|
||
# -*- Scheme -*-
|
||
exec ${GUILE-guile} -q -l "$0" \
|
||
-c '(apply main (cdr (command-line)))' \
|
||
--benchmark-dir="$(dirname $0)" "$@"
|
||
!#
|
||
;;; Copyright (C) 2008 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)
|
||
(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 (print-line name result ref?)
|
||
(let ((name (string-pad-right name 23))
|
||
(time (assoc-ref result 'execution-time))
|
||
(heap (assoc-ref result 'heap-size))
|
||
(ref-heap (assoc-ref reference 'heap-size))
|
||
(ref-time (assoc-ref reference 'execution-time)))
|
||
(format #t "~a ~1,2f (~,2fx) ~6,3f (~,2fx)~A~%"
|
||
name
|
||
(/ heap 1000000.0) (/ heap ref-heap 1.0)
|
||
time (/ time ref-time 1.0)
|
||
(if (and (not ref?)
|
||
(<= heap ref-heap) (<= time ref-time))
|
||
" !"
|
||
""))))
|
||
|
||
(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))
|
||
|
||
|
||
;;;
|
||
;;; 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?))))))
|
||
|
||
(define %default-options
|
||
`((reference-environment . "GUILE=guile")
|
||
(benchmark-directory . "./gc-benchmarks")
|
||
(log-port . ,(current-output-port))
|
||
(profile-options . "")
|
||
(input . ())))
|
||
|
||
(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.
|
||
-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)))
|
||
(for-each (lambda (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
|
||
;;(format #t "ref=~A~%" ref)
|
||
;;(format #t "bdw-gc=~A~%" bdwgc)
|
||
(with-output-to-port log
|
||
(lambda ()
|
||
(pretty-print-result benchmark ref bdwgc)
|
||
(newline)
|
||
(force-output)))))
|
||
benchmark-files))))
|