#!/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 .~%")) (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))))))))