#!/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.
+;;; Copyright (C) 2008, 2011 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 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 General Public License for more details.
+;;; GNU Lesser 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
+;;; 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 format)
(ice-9 rdelim)
(ice-9 regex)
- (srfi srfi-1))
+ (srfi srfi-1)
+ (srfi srfi-37)
+ (srfi srfi-39))
+
+\f
+;;;
+;;; Memory usage.
+;;;
(define (memory-mappings pid)
"Return an list of alists, each of which contains information about a
@file{/proc/PID/smaps} on Linux. See `procs(5)' for details."
(define mapping-line-rx
+ ;; As of Linux 2.6.32.28, an `smaps' line looks like this:
+ ;; "00400000-00401000 r-xp 00000000 fe:00 108264 /home/ludo/soft/bin/guile"
(make-regexp
- "^([[:xdigit:]]+)-([[:xdigit:]]+) ([rwx-]{3}[ps]) ([[:xdigit:]]+) [0-9]{2}:[0-9]{2} [0-9]+[[:blank:]]+(.*)$"))
+ "^([[:xdigit:]]+)-([[:xdigit:]]+) ([rwx-]{3}[ps]) ([[:xdigit:]]+) [[:xdigit:]]{2}:[[:xdigit:]]{2} [0-9]+[[:blank:]]+(.*)$"))
(define rss-line-rx
(make-regexp
"^Rss:[[:blank:]]+([[:digit:]]+) kB$"))
+ (if (not (string-contains %host-type "-linux-"))
+ (error "this procedure only works on Linux-based systems" %host-type))
+
(with-input-from-port (open-input-file (format #f "/proc/~a/smaps" pid))
(lambda ()
(let loop ((line (read-line))
(loop (read-line) result))))))))
(define (total-heap-size pid)
- "Return the total heap size of process @var{pid}."
+ "Return a pair representing the total and RSS heap size of PID."
(define heap-or-anon-rx
(make-regexp "\\[(heap|anon)\\]"))
))
\f
-(define (main . args)
- (if (not (= (length args) 2))
- (begin
- (format #t "Usage: run FILE.SCM
+;;;
+;;; Larceny/Twobit benchmarking compability layer.
+;;;
-Load FILE.SCM, a Guile Scheme source file, and report its execution time and
-final heap usage.~%")
- (exit 1)))
+(define *iteration-count*
+ (make-parameter #f))
+
+(define (run-benchmark name . args)
+ "A @code{run-benchmark} procedure compatible with Larceny's GC benchmarking
+framework. See
+@url{http://www.ccs.neu.edu/home/will/Twobit/benchmarksAbout.html} for
+details."
- (let ((prog (cadr args))
- (start (gettimeofday)))
- (format #t "running `~a'...~%" prog)
+ (define %concise-invocation?
+ ;; This procedure can be called with only two arguments, NAME and
+ ;; RUN-MAKER.
+ (procedure? (car args)))
+
+ (let ((count (or (*iteration-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)))))))
+
+(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 ()
- #t)
- (lambda ()
- (set! quit (lambda args args))
- (load prog))
- (lambda ()
- (let ((end (gettimeofday)))
- (format #t "done~%")
- (display-stats start end))))))
+ (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))))))))
+
+
+\f
+;;;
+;;; 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)))
+ (option '(#\i "iterations") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'iterations (string->number arg) 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.
+
+ -h, --help Show this help message
+
+ -l, --larceny Provide mechanisms compatible with the Larceny/Twobit
+ GC benchmark suite.
+ -i, --iterations=COUNT
+ Run the given benchmark COUNT times, regardless of the
+ iteration count passed to `run-benchmark' (for Larceny
+ benchmarks).
+
+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)
+ (if (pair? (assoc 'input result))
+ (leave "~a: only one input file at a time" file)
+ (alist-cons 'input file result)))
+ '()))
+
+\f
+;;;
+;;; 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)))
+
+ (parameterize ((*iteration-count* (assoc-ref options 'iterations)))
+ (format #t "running `~a' with Guile ~a...~%" prog (version))
+
+ (let ((start (gettimeofday)))
+ (dynamic-wind
+ (lambda ()
+ #t)
+ (lambda ()
+ (set! quit (lambda args args))
+ (load prog))
+ (lambda ()
+ (let ((end (gettimeofday)))
+ (format #t "done~%")
+ (display-stats start end))))))))