From a13dc0b473bce1bb0206c997b72a316db21e5ef0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 7 Nov 2008 21:11:44 +0100 Subject: gc-benchmarks: Add a Larceny/Twobit benchmark compatibility layer. * gc-benchmarks/gc-profile.scm: Load "twobit-compat.scm". (save-directory-excursion, load-larceny-benchmark): New procedures. (%options): New variable. (show-help, parse-args): New procedures. (main): Use `parse-args' and `load-larceny-benchmark'. --- gc-benchmarks/gc-profile.scm | 111 +++++++++++++++++++++++++++++++++++----- gc-benchmarks/twobit-compat.scm | 45 ++++++++++++++++ 2 files changed, 144 insertions(+), 12 deletions(-) create mode 100644 gc-benchmarks/twobit-compat.scm (limited to 'gc-benchmarks') diff --git a/gc-benchmarks/gc-profile.scm b/gc-benchmarks/gc-profile.scm index f19753a5e..da2a493f1 100755 --- a/gc-benchmarks/gc-profile.scm +++ b/gc-benchmarks/gc-profile.scm @@ -1,7 +1,7 @@ #!/bin/sh # -*- Scheme -*- exec ${GUILE-guile} --no-debug -q -l "$0" \ - -c '(apply main (command-line))' "$@" + -c '(apply main (cdr (command-line)))' "$@" !# ;;; Copyright (C) 2008 Free Software Foundation, Inc. ;;; @@ -23,7 +23,13 @@ exec ${GUILE-guile} --no-debug -q -l "$0" \ (use-modules (ice-9 format) (ice-9 rdelim) (ice-9 regex) - (srfi srfi-1)) + (srfi srfi-1) + (srfi srfi-37)) + + +;;; +;;; Memory usage. +;;; (define (memory-mappings pid) "Return an list of alists, each of which contains information about a @@ -130,19 +136,100 @@ memory mapping of process @var{pid}. This information is obtained by reading )) -(define (main . args) - (if (not (= (length args) 2)) - (begin - (format #t "Usage: run FILE.SCM +;;; +;;; Larceny/Twobit benchmarking compability layer. +;;; + +(load "twobit-compat.scm") +(define (save-directory-excursion directory thunk) + (let ((previous-dir (getcwd))) + (dynamic-wind + (lambda () + (chdir directory)) + thunk + (lambda () + (chdir previous-dir))))) + +(define (load-larceny-benchmark file) + "Load the Larceny benchmark from @var{file}." + (let ((name (let ((base (basename file))) + (substring base 0 (or (string-rindex base #\.) + (string-length base))))) + (module (let ((m (make-module))) + (beautify-user-module! m) + (module-use! m (resolve-interface '(ice-9 syncase))) + m))) + (save-directory-excursion (dirname file) + (lambda () + (save-module-excursion + (lambda () + (set-current-module module) + (module-define! module 'run-benchmark run-benchmark) + (load (basename file)) + + ;; Invoke the benchmark's entry point. + (let ((entry (module-ref (current-module) + (symbol-append (string->symbol name) + '-benchmark)))) + (entry)))))))) + + + +;;; +;;; Option processing. +;;; + +(define %options + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\l "larceny") #f #f + (lambda (opt name arg result) + (alist-cons 'larceny? #t result))))) + +(define (show-help) + (format #t "Usage: gc-profile [OPTIONS] FILE.SCM Load FILE.SCM, a Guile Scheme source file, and report its execution time and -final heap usage.~%") - (exit 1))) +final heap usage. + + -h, --help Show this help message + + -l, --larceny Provide mechanisms compatible with the Larceny/Twobit + GC benchmark suite. + +Report bugs to .~%")) + +(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) + (if (pair? (assoc 'input result)) + (leave "~a: only one input file at a time" file) + (alist-cons 'input file result))) + '())) - (let ((prog (cadr args)) - (start (gettimeofday))) + +;;; +;;; Main program. +;;; + +(define (main . args) + (let* ((options (parse-args args)) + (prog (assoc-ref options 'input)) + (load (if (assoc-ref options 'larceny?) + load-larceny-benchmark + load))) (format #t "running `~a'...~%" prog) - (dynamic-wind + + (let ((start (gettimeofday))) + (dynamic-wind (lambda () #t) (lambda () @@ -151,4 +238,4 @@ final heap usage.~%") (lambda () (let ((end (gettimeofday))) (format #t "done~%") - (display-stats start end)))))) + (display-stats start end))))))) diff --git a/gc-benchmarks/twobit-compat.scm b/gc-benchmarks/twobit-compat.scm new file mode 100644 index 000000000..765b94f8b --- /dev/null +++ b/gc-benchmarks/twobit-compat.scm @@ -0,0 +1,45 @@ +;;; 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 General Public License as published by +;;; the Free Software Foundation; either version 2, 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 General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this software; see the file COPYING. If not, write to +;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;;; Boston, MA 02110-1301 USA + +;;; +;;; This file provides compatibility routines with the benchmarking framework +;;; used in Larceny/Twobit. +;;; +;;; See http://www.ccs.neu.edu/home/will/Twobit/benchmarksAbout.html for details. +;;; + +(define (run-benchmark name . args) + (define %concise-invocation? + ;; This procedure can be called with only two arguments, NAME and + ;; RUN-MAKER. + (procedure? (car args))) + + (let ((count (if %concise-invocation? 0 (car args))) + (run-maker (if %concise-invocation? (car args) (cadr args))) + (ok? (if %concise-invocation? + (lambda (result) #t) + (caddr args))) + (args (if %concise-invocation? '() (cdddr args)))) + (let loop ((i 0)) + (and (< i count) + (let ((result (apply run-maker args))) + (if (not (ok? result)) + (begin + (format (current-output-port) "invalid result for `~A'~%" + name) + (exit 1))) + (loop (1+ i))))))) -- cgit v1.2.1