mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-06 15:40:29 +02:00
b777f3b64c
* gc-benchmarks/gc-profile.scm: Load "twobit-compat.scm". (save-directory-excursion, load-larceny-benchmark): New procedures. (%options): New variable. (show-help, parse-args): New procedures. (main): Use `parse-args' and `load-larceny-benchmark'.
241 lines
8.2 KiB
Scheme
Executable file
241 lines
8.2 KiB
Scheme
Executable file
#!/bin/sh
|
||
# -*- Scheme -*-
|
||
exec ${GUILE-guile} --no-debug -q -l "$0" \
|
||
-c '(apply main (cdr (command-line)))' "$@"
|
||
!#
|
||
;;; Copyright (C) 2008 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 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.
|
||
;;;
|
||
;;; 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
|
||
|
||
(use-modules (ice-9 format)
|
||
(ice-9 rdelim)
|
||
(ice-9 regex)
|
||
(srfi srfi-1)
|
||
(srfi srfi-37))
|
||
|
||
|
||
;;;
|
||
;;; 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
|
||
(make-regexp
|
||
"^([[:xdigit:]]+)-([[:xdigit:]]+) ([rwx-]{3}[ps]) ([[:xdigit:]]+) [0-9]{2}:[0-9]{2} [0-9]+[[:blank:]]+(.*)$"))
|
||
|
||
(define rss-line-rx
|
||
(make-regexp
|
||
"^Rss:[[:blank:]]+([[:digit:]]+) kB$"))
|
||
|
||
(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 the total heap size of process @var{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.
|
||
;;;
|
||
|
||
(load "twobit-compat.scm")
|
||
|
||
(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)))))
|
||
|
||
(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.
|
||
|
||
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)))
|
||
(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)))))))
|