exec ${GUILE-guile} --no-debug -q -l "$0" \
-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-37))
+ (srfi srfi-37)
+ (srfi srfi-39))
\f
;;;
@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)\\]"))
;;; Larceny/Twobit benchmarking compability layer.
;;;
-(load "twobit-compat.scm")
+(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."
+
+ (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)))
(exit 0)))
(option '(#\l "larceny") #f #f
(lambda (opt name arg result)
- (alist-cons 'larceny? #t 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
-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>.~%"))
(load (if (assoc-ref options 'larceny?)
load-larceny-benchmark
load)))
- (format #t "running `~a'...~%" prog)
- (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)))))))
+ (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))))))))
HCoop / bpt / guile.git / blobdiff