summaryrefslogtreecommitdiff
path: root/gc-benchmarks/gc-profile.scm
diff options
context:
space:
mode:
Diffstat (limited to 'gc-benchmarks/gc-profile.scm')
-rwxr-xr-xgc-benchmarks/gc-profile.scm285
1 files changed, 285 insertions, 0 deletions
diff --git a/gc-benchmarks/gc-profile.scm b/gc-benchmarks/gc-profile.scm
new file mode 100755
index 000000000..d95e29572
--- /dev/null
+++ b/gc-benchmarks/gc-profile.scm
@@ -0,0 +1,285 @@
+#!/bin/sh
+# -*- Scheme -*-
+exec ${GUILE-guile} --no-debug -q -l "$0" \
+ -c '(apply main (cdr (command-line)))' "$@"
+!#
+;;; 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 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 format)
+ (ice-9 rdelim)
+ (ice-9 regex)
+ (srfi srfi-1)
+ (srfi srfi-37)
+ (srfi srfi-39))
+
+
+;;;
+;;; Memory usage.
+;;;
+
+(define (memory-mappings pid)
+ "Return an list of alists, each of which contains information about a
+memory mapping of process @var{pid}. This information is obtained by reading
+@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:]]+) [[: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))
+ (result '()))
+ (if (eof-object? line)
+ (reverse result)
+ (cond ((regexp-exec mapping-line-rx line)
+ =>
+ (lambda (match)
+ (let ((mapping-start (string->number
+ (match:substring match 1)
+ 16))
+ (mapping-end (string->number
+ (match:substring match 2)
+ 16))
+ (access-bits (match:substring match 3))
+ (name (match:substring match 5)))
+ (loop (read-line)
+ (cons `((mapping-start . ,mapping-start)
+ (mapping-end . ,mapping-end)
+ (access-bits . ,access-bits)
+ (name . ,(if (string=? name "")
+ #f
+ name)))
+ result)))))
+ ((regexp-exec rss-line-rx line)
+ =>
+ (lambda (match)
+ (let ((section+ (cons (cons 'rss
+ (string->number
+ (match:substring match 1)))
+ (car result))))
+ (loop (read-line)
+ (cons section+ (cdr result))))))
+ (else
+ (loop (read-line) result))))))))
+
+(define (total-heap-size pid)
+ "Return a pair representing the total and RSS heap size of PID."
+
+ (define heap-or-anon-rx
+ (make-regexp "\\[(heap|anon)\\]"))
+
+ (define private-mapping-rx
+ (make-regexp "^[r-][w-][x-]p$"))
+
+ (fold (lambda (heap total+rss)
+ (let ((name (assoc-ref heap 'name))
+ (perm (assoc-ref heap 'access-bits)))
+ ;; Include anonymous private mappings.
+ (if (or (and (not name)
+ (regexp-exec private-mapping-rx perm))
+ (and name
+ (regexp-exec heap-or-anon-rx name)))
+ (let ((start (assoc-ref heap 'mapping-start))
+ (end (assoc-ref heap 'mapping-end))
+ (rss (assoc-ref heap 'rss)))
+ (cons (+ (car total+rss) (- end start))
+ (+ (cdr total+rss) rss)))
+ total+rss)))
+ '(0 . 0)
+ (memory-mappings pid)))
+
+
+(define (display-stats start end)
+ (define (->usecs sec+usecs)
+ (+ (* 1000000 (car sec+usecs))
+ (cdr sec+usecs)))
+
+ (let ((usecs (- (->usecs end) (->usecs start)))
+ (heap-size (total-heap-size (getpid)))
+ (gc-heap-size (assoc-ref (gc-stats) 'heap-size)))
+
+ (format #t "execution time: ~6,3f seconds~%"
+ (/ usecs 1000000.0))
+
+ (and gc-heap-size
+ (format #t "GC-reported heap size: ~8d B (~1,2f MiB)~%"
+ gc-heap-size
+ (/ gc-heap-size 1024.0 1024.0)))
+
+ (format #t "heap size: ~8d B (~1,2f MiB)~%"
+ (car heap-size)
+ (/ (car heap-size) 1024.0 1024.0))
+ (format #t "heap RSS: ~8d KiB (~1,2f MiB)~%"
+ (cdr heap-size)
+ (/ (cdr heap-size) 1024.0))
+;; (system (format #f "cat /proc/~a/smaps" (getpid)))
+;; (system (format #f "exmtool procs | grep -E '^(PID|~a)'" (getpid)))
+ ))
+
+
+;;;
+;;; Larceny/Twobit benchmarking compability layer.
+;;;
+
+(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)))
+ (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)))
+ (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)))
+ '()))
+
+
+;;;
+;;; 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))))))))