Commit | Line | Data |
---|---|---|
8da56ffc LC |
1 | #!/bin/sh |
2 | # -*- Scheme -*- | |
3 | exec ${GUILE-guile} --no-debug -q -l "$0" \ | |
a13dc0b4 | 4 | -c '(apply main (cdr (command-line)))' "$@" |
8da56ffc | 5 | !# |
249f2788 | 6 | ;;; Copyright (C) 2008, 2011 Free Software Foundation, Inc. |
8da56ffc | 7 | ;;; |
53befeb7 NJ |
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. | |
8da56ffc LC |
12 | ;;; |
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 | |
53befeb7 | 16 | ;;; GNU Lesser General Public License for more details. |
8da56ffc | 17 | ;;; |
53befeb7 NJ |
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 | |
8da56ffc LC |
22 | |
23 | (use-modules (ice-9 format) | |
24 | (ice-9 rdelim) | |
25 | (ice-9 regex) | |
a13dc0b4 | 26 | (srfi srfi-1) |
1b04c499 LC |
27 | (srfi srfi-37) |
28 | (srfi srfi-39)) | |
a13dc0b4 LC |
29 | |
30 | \f | |
31 | ;;; | |
32 | ;;; Memory usage. | |
33 | ;;; | |
8da56ffc LC |
34 | |
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." | |
39 | ||
40 | (define mapping-line-rx | |
249f2788 LC |
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" | |
8da56ffc | 43 | (make-regexp |
249f2788 | 44 | "^([[:xdigit:]]+)-([[:xdigit:]]+) ([rwx-]{3}[ps]) ([[:xdigit:]]+) [[:xdigit:]]{2}:[[:xdigit:]]{2} [0-9]+[[:blank:]]+(.*)$")) |
8da56ffc LC |
45 | |
46 | (define rss-line-rx | |
47 | (make-regexp | |
48 | "^Rss:[[:blank:]]+([[:digit:]]+) kB$")) | |
49 | ||
821eca02 LC |
50 | (if (not (string-contains %host-type "-linux-")) |
51 | (error "this procedure only works on Linux-based systems" %host-type)) | |
52 | ||
8da56ffc LC |
53 | (with-input-from-port (open-input-file (format #f "/proc/~a/smaps" pid)) |
54 | (lambda () | |
55 | (let loop ((line (read-line)) | |
56 | (result '())) | |
57 | (if (eof-object? line) | |
58 | (reverse result) | |
59 | (cond ((regexp-exec mapping-line-rx line) | |
60 | => | |
61 | (lambda (match) | |
62 | (let ((mapping-start (string->number | |
63 | (match:substring match 1) | |
64 | 16)) | |
65 | (mapping-end (string->number | |
66 | (match:substring match 2) | |
67 | 16)) | |
68 | (access-bits (match:substring match 3)) | |
69 | (name (match:substring match 5))) | |
70 | (loop (read-line) | |
71 | (cons `((mapping-start . ,mapping-start) | |
72 | (mapping-end . ,mapping-end) | |
73 | (access-bits . ,access-bits) | |
74 | (name . ,(if (string=? name "") | |
75 | #f | |
76 | name))) | |
77 | result))))) | |
78 | ((regexp-exec rss-line-rx line) | |
79 | => | |
80 | (lambda (match) | |
81 | (let ((section+ (cons (cons 'rss | |
82 | (string->number | |
83 | (match:substring match 1))) | |
84 | (car result)))) | |
85 | (loop (read-line) | |
86 | (cons section+ (cdr result)))))) | |
87 | (else | |
88 | (loop (read-line) result)))))))) | |
89 | ||
90 | (define (total-heap-size pid) | |
249f2788 | 91 | "Return a pair representing the total and RSS heap size of PID." |
8da56ffc LC |
92 | |
93 | (define heap-or-anon-rx | |
94 | (make-regexp "\\[(heap|anon)\\]")) | |
95 | ||
96 | (define private-mapping-rx | |
97 | (make-regexp "^[r-][w-][x-]p$")) | |
98 | ||
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)) | |
105 | (and name | |
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))) | |
112 | total+rss))) | |
113 | '(0 . 0) | |
114 | (memory-mappings pid))) | |
115 | ||
116 | ||
117 | (define (display-stats start end) | |
118 | (define (->usecs sec+usecs) | |
119 | (+ (* 1000000 (car sec+usecs)) | |
120 | (cdr sec+usecs))) | |
121 | ||
122 | (let ((usecs (- (->usecs end) (->usecs start))) | |
123 | (heap-size (total-heap-size (getpid))) | |
124 | (gc-heap-size (assoc-ref (gc-stats) 'heap-size))) | |
125 | ||
126 | (format #t "execution time: ~6,3f seconds~%" | |
127 | (/ usecs 1000000.0)) | |
128 | ||
129 | (and gc-heap-size | |
130 | (format #t "GC-reported heap size: ~8d B (~1,2f MiB)~%" | |
131 | gc-heap-size | |
132 | (/ gc-heap-size 1024.0 1024.0))) | |
133 | ||
134 | (format #t "heap size: ~8d B (~1,2f MiB)~%" | |
135 | (car heap-size) | |
136 | (/ (car heap-size) 1024.0 1024.0)) | |
137 | (format #t "heap RSS: ~8d KiB (~1,2f MiB)~%" | |
138 | (cdr heap-size) | |
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))) | |
142 | )) | |
143 | ||
144 | \f | |
a13dc0b4 LC |
145 | ;;; |
146 | ;;; Larceny/Twobit benchmarking compability layer. | |
147 | ;;; | |
148 | ||
1b04c499 LC |
149 | (define *iteration-count* |
150 | (make-parameter #f)) | |
151 | ||
152 | (define (run-benchmark name . args) | |
153 | "A @code{run-benchmark} procedure compatible with Larceny's GC benchmarking | |
154 | framework. See | |
155 | @url{http://www.ccs.neu.edu/home/will/Twobit/benchmarksAbout.html} for | |
156 | details." | |
157 | ||
158 | (define %concise-invocation? | |
159 | ;; This procedure can be called with only two arguments, NAME and | |
160 | ;; RUN-MAKER. | |
161 | (procedure? (car args))) | |
162 | ||
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? | |
167 | (lambda (result) #t) | |
168 | (caddr args))) | |
169 | (args (if %concise-invocation? '() (cdddr args)))) | |
170 | (let loop ((i 0)) | |
171 | (and (< i count) | |
172 | (let ((result (apply run-maker args))) | |
173 | (if (not (ok? result)) | |
174 | (begin | |
175 | (format (current-output-port) "invalid result for `~A'~%" | |
176 | name) | |
177 | (exit 1))) | |
178 | (loop (1+ i))))))) | |
8da56ffc | 179 | |
a13dc0b4 LC |
180 | (define (save-directory-excursion directory thunk) |
181 | (let ((previous-dir (getcwd))) | |
182 | (dynamic-wind | |
183 | (lambda () | |
184 | (chdir directory)) | |
185 | thunk | |
186 | (lambda () | |
187 | (chdir previous-dir))))) | |
188 | ||
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))) | |
197 | m))) | |
198 | (save-directory-excursion (dirname file) | |
199 | (lambda () | |
200 | (save-module-excursion | |
201 | (lambda () | |
202 | (set-current-module module) | |
203 | (module-define! module 'run-benchmark run-benchmark) | |
204 | (load (basename file)) | |
205 | ||
206 | ;; Invoke the benchmark's entry point. | |
207 | (let ((entry (module-ref (current-module) | |
208 | (symbol-append (string->symbol name) | |
209 | '-benchmark)))) | |
210 | (entry)))))))) | |
211 | ||
212 | ||
213 | \f | |
214 | ;;; | |
215 | ;;; Option processing. | |
216 | ;;; | |
217 | ||
218 | (define %options | |
219 | (list (option '(#\h "help") #f #f | |
220 | (lambda args | |
221 | (show-help) | |
222 | (exit 0))) | |
223 | (option '(#\l "larceny") #f #f | |
224 | (lambda (opt name arg result) | |
1b04c499 LC |
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))))) | |
a13dc0b4 LC |
229 | |
230 | (define (show-help) | |
231 | (format #t "Usage: gc-profile [OPTIONS] FILE.SCM | |
8da56ffc | 232 | Load FILE.SCM, a Guile Scheme source file, and report its execution time and |
a13dc0b4 LC |
233 | final heap usage. |
234 | ||
235 | -h, --help Show this help message | |
236 | ||
237 | -l, --larceny Provide mechanisms compatible with the Larceny/Twobit | |
238 | GC benchmark suite. | |
1b04c499 LC |
239 | -i, --iterations=COUNT |
240 | Run the given benchmark COUNT times, regardless of the | |
241 | iteration count passed to `run-benchmark' (for Larceny | |
242 | benchmarks). | |
a13dc0b4 LC |
243 | |
244 | Report bugs to <bug-guile@gnu.org>.~%")) | |
245 | ||
246 | (define (parse-args args) | |
247 | (define (leave fmt . args) | |
248 | (apply format (current-error-port) (string-append fmt "~%") args) | |
249 | (exit 1)) | |
250 | ||
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))) | |
258 | '())) | |
8da56ffc | 259 | |
a13dc0b4 LC |
260 | \f |
261 | ;;; | |
262 | ;;; Main program. | |
263 | ;;; | |
264 | ||
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 | |
270 | load))) | |
a13dc0b4 | 271 | |
1b04c499 | 272 | (parameterize ((*iteration-count* (assoc-ref options 'iterations))) |
b9ecffc5 | 273 | (format #t "running `~a' with Guile ~a...~%" prog (version)) |
1b04c499 LC |
274 | |
275 | (let ((start (gettimeofday))) | |
276 | (dynamic-wind | |
277 | (lambda () | |
278 | #t) | |
279 | (lambda () | |
280 | (set! quit (lambda args args)) | |
281 | (load prog)) | |
282 | (lambda () | |
283 | (let ((end (gettimeofday))) | |
284 | (format #t "done~%") | |
285 | (display-stats start end)))))))) |