3 exec ${GUILE-guile} --no-debug -q -l "$0" \
4 -c '(apply main (cdr (command-line)))' "$@"
6 ;;; Copyright
(C
) 2008, 2011 Free Software Foundation
, Inc.
8 ;;; This program is free software
; you can redistribute it and
/or
9 ;;; modify it under the terms of the GNU Lesser General Public License
10 ;;; as published by the Free Software Foundation
; either version
3, or
11 ;;; (at your option
) any later version.
13 ;;; This program is distributed
in the hope that it will be useful
,
14 ;;; but WITHOUT ANY WARRANTY
; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ;;; GNU Lesser General Public License
for more details.
18 ;;; You should have received a copy of the GNU Lesser General Public
19 ;;; License along with this software
; see the
file COPYING.LESSER. If
20 ;;; not
, write to the Free Software Foundation
, Inc.
, 51 Franklin
21 ;;; Street
, Fifth Floor
, Boston
, MA
02110-1301 USA
23 (use-modules
(ice-9 format
)
35 (define
(memory-mappings pid
)
36 "Return an list of alists, each of which contains information about a
37 memory mapping of process @var{pid}. This information is obtained by reading
38 @file{/proc/PID/smaps} on Linux. See `procs(5)' for details."
40 (define mapping-line-rx
41 ;; As of Linux
2.6.32.28, an
`smaps' line looks like this:
42 ;; "00400000-00401000 r-xp 00000000 fe:00 108264 /home/ludo/soft/bin/guile"
44 "^([[:xdigit:]]+)-([[:xdigit:]]+) ([rwx-]{3}[ps]) ([[:xdigit:]]+) [[:xdigit:]]{2}:[[:xdigit:]]{2} [0-9]+[[:blank:]]+(.*)$"))
48 "^Rss:[[:blank:]]+([[:digit:]]+) kB$"))
50 (if (not (string-contains %host-type "-linux-"))
51 (error "this procedure only works on Linux-based systems" %host-type))
53 (with-input-from-port (open-input-file (format #f "/proc/~a/smaps" pid))
55 (let loop ((line (read-line))
57 (if (eof-object? line)
59 (cond ((regexp-exec mapping-line-rx line)
62 (let ((mapping-start (string->number
63 (match:substring match 1)
65 (mapping-end (string->number
66 (match:substring match 2)
68 (access-bits (match:substring match 3))
69 (name (match:substring match 5)))
71 (cons `((mapping-start .
,mapping-start
)
72 (mapping-end .
,mapping-end
)
73 (access-bits .
,access-bits
)
74 (name .
,(if (string
=? name
"")
78 ((regexp-exec rss-line-rx line
)
81 (let ((section
+ (cons
(cons
'rss
83 (match:substring match 1)))
86 (cons section+ (cdr result))))))
88 (loop (read-line) result))))))))
90 (define (total-heap-size pid)
91 "Return a pair representing the total and RSS heap size of PID."
93 (define heap-or-anon-rx
94 (make-regexp "\\[(heap|anon)\\]"))
96 (define private-mapping-rx
97 (make-regexp "^[r-][w-][x-]p$"))
99 (fold (lambda (heap total+rss)
100 (let ((name (assoc-ref heap 'name
))
101 (perm
(assoc-ref heap
'access-bits)))
102 ;; Include anonymous private mappings.
103 (if (or (and (not name)
104 (regexp-exec private-mapping-rx perm))
106 (regexp-exec heap-or-anon-rx name)))
107 (let ((start (assoc-ref heap 'mapping-start
))
108 (end
(assoc-ref heap
'mapping-end))
109 (rss (assoc-ref heap 'rss
)))
110 (cons
(+ (car total
+rss
) (- end start
))
111 (+ (cdr total
+rss
) rss
)))
114 (memory-mappings pid)))
117 (define (display-stats start end)
118 (define (->usecs sec+usecs)
119 (+ (* 1000000 (car sec+usecs))
122 (let ((usecs (- (->usecs end) (->usecs start)))
123 (heap-size (total-heap-size (getpid)))
124 (gc-heap-size (assoc-ref (gc-stats) 'heap-size
)))
126 (format
#t "execution time: ~6,3f seconds~%"
130 (format
#t "GC-reported heap size: ~8d B (~1,2f MiB)~%"
132 (/ gc-heap-size
1024.0 1024.0)))
134 (format
#t "heap size: ~8d B (~1,2f MiB)~%"
136 (/ (car heap-size
) 1024.0 1024.0))
137 (format
#t "heap RSS: ~8d KiB (~1,2f MiB)~%"
139 (/ (cdr heap-size
) 1024.0))
140 ;; (system
(format
#f "cat /proc/~a/smaps" (getpid)))
141 ;; (system
(format
#f "exmtool procs | grep -E '^(PID|~a)'" (getpid)))
146 ;;; Larceny
/Twobit benchmarking compability layer.
149 (define
*iteration-count
*
152 (define
(run-benchmark name . args
)
153 "A @code{run-benchmark} procedure compatible with Larceny's GC benchmarking
155 @url{http://www.ccs.neu.edu/home/will/Twobit/benchmarksAbout.html} for
158 (define
%concise-invocation?
159 ;; This procedure can be called with only two arguments
, NAME and
161 (procedure?
(car args
)))
163 (let ((count
(or
(*iteration-count
*)
164 (if %concise-invocation?
0 (car args
))))
165 (run-maker
(if %concise-invocation?
(car args
) (cadr args
)))
166 (ok?
(if %concise-invocation?
169 (args
(if %concise-invocation?
'() (cdddr args))))
172 (let ((result (apply run-maker args)))
173 (if (not (ok? result))
175 (format (current-output-port) "invalid result for `~A'~
%"
180 (define (save-directory-excursion directory thunk)
181 (let ((previous-dir (getcwd)))
187 (chdir previous-dir)))))
189 (define (load-larceny-benchmark file)
190 "Load the Larceny benchmark from @var
{file}.
"
191 (let ((name (let ((base (basename file)))
192 (substring base 0 (or (string-rindex base #\.)
193 (string-length base)))))
194 (module (let ((m (make-module)))
195 (beautify-user-module! m)
196 (module-use! m (resolve-interface '(ice-9 syncase)))
198 (save-directory-excursion (dirname file)
200 (save-module-excursion
202 (set-current-module module)
203 (module-define! module 'run-benchmark run-benchmark)
204 (load (basename file))
206 ;; Invoke the benchmark's entry point.
207 (let ((entry (module-ref (current-module)
208 (symbol-append (string->symbol name)
215 ;;; Option processing.
219 (list (option '(#\h "help") #f #f
223 (option '(#\l "larceny
") #f #f
224 (lambda (opt name arg result)
225 (alist-cons 'larceny? #t result)))
226 (option '(#\i "iterations
") #t #f
227 (lambda (opt name arg result)
228 (alist-cons 'iterations (string->number arg) result)))))
231 (format #t "Usage
: gc-profile
[OPTIONS
] FILE.SCM
232 Load FILE.SCM
, a Guile Scheme
source file, and report its execution
time and
235 -h, --help Show this
help message
237 -l, --larceny Provide mechanisms compatible with the Larceny
/Twobit
239 -i, --iterations=COUNT
240 Run the given benchmark COUNT
times, regardless of the
241 iteration count passed to
`run-benchmark' (for Larceny
244 Report bugs to <bug-guile@gnu.org>.~%"))
246 (define (parse-args args)
247 (define (leave fmt . args)
248 (apply format (current-error-port) (string-append fmt "~%") args)
251 (args-fold args %options
252 (lambda (opt name arg result)
253 (leave "~A: unrecognized option" opt))
254 (lambda (file result)
255 (if (pair? (assoc 'input result))
256 (leave "~a: only one input file at a time" file)
257 (alist-cons 'input file result)))
265 (define (main . args)
266 (let* ((options (parse-args args))
267 (prog (assoc-ref options 'input))
268 (load (if (assoc-ref options 'larceny?)
269 load-larceny-benchmark
272 (parameterize ((*iteration-count* (assoc-ref options 'iterations)))
273 (format #t "running `~a
' with Guile ~a...~%" prog (version))
275 (let ((start (gettimeofday)))
280 (set! quit (lambda args args))
283 (let ((end (gettimeofday)))
285 (display-stats start end))))))))