123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286 |
- #!/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))))))))
|