1#!/bin/sh
2# -*- Scheme -*-
3exec ${GUILE-guile} -q -l "$0"                                  \
4                    -c '(apply main (cdr (command-line)))'      \
5                    --benchmark-dir="$(dirname $0)" "$@"
6!#
7;;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
8;;;
9;;; This program is free software; you can redistribute it and/or
10;;; modify it under the terms of the GNU Lesser General Public License
11;;; as published by the Free Software Foundation; either version 3, or
12;;; (at your option) any later version.
13;;;
14;;; This program is distributed in the hope that it will be useful,
15;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
17;;; GNU Lesser General Public License for more details.
18;;;
19;;; You should have received a copy of the GNU Lesser General Public
20;;; License along with this software; see the file COPYING.LESSER.  If
21;;; not, write to the Free Software Foundation, Inc., 51 Franklin
22;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
23
24(use-modules (ice-9 rdelim)
25             (ice-9 popen)
26             (ice-9 regex)
27             (ice-9 format)
28             (ice-9 pretty-print)
29             (srfi srfi-1)
30             (srfi srfi-37))
31
32
33;;;
34;;; Running Guile.
35;;;
36
37(define (run-reference-guile env bench-dir profile-opts bench)
38  "Run the ``mainstream'' Guile, i.e., Guile 1.9 with its own GC."
39  (open-input-pipe (string-append
40                    env " "
41                    bench-dir "/gc-profile.scm " profile-opts
42                    " \"" bench "\"")))
43
44(define (run-bdwgc-guile env bench-dir profile-opts options bench)
45  "Run the Guile port to the Boehm-Demers-Weiser GC (BDW-GC)."
46  (let ((fsd (assoc-ref options 'free-space-divisor)))
47    (open-input-pipe (string-append env " "
48                                    "GC_FREE_SPACE_DIVISOR="
49                                    (number->string fsd)
50
51                                    (if (or (assoc-ref options 'incremental?)
52                                            (assoc-ref options 'generational?))
53                                        " GC_ENABLE_INCREMENTAL=yes"
54                                        "")
55                                    (if (assoc-ref options 'generational?)
56                                        " GC_PAUSE_TIME_TARGET=999999"
57                                        "")
58                                    (if (assoc-ref options 'parallel?)
59                                        "" ;; let it choose the number of procs
60                                        " GC_MARKERS=1")
61                                    " "
62                                    bench-dir "/gc-profile.scm " profile-opts
63                                    " \"" bench "\""))))
64
65
66;;;
67;;; Extracting performance results.
68;;;
69
70(define (grep regexp input)
71  "Read line by line from the @var{input} port and return all matches for
72@var{regexp}."
73  (let ((regexp (if (string? regexp) (make-regexp regexp) regexp)))
74    (with-input-from-port input
75      (lambda ()
76        (let loop ((line   (read-line))
77                   (result '()))
78          (format #t "> ~A~%" line)
79          (if (eof-object? line)
80              (reverse result)
81              (cond ((regexp-exec regexp line)
82                     =>
83                     (lambda (match)
84                       (loop (read-line)
85                             (cons match result))))
86                    (else
87                     (loop (read-line) result)))))))))
88
89(define (parse-result benchmark-output)
90  (let ((result (grep "^(execution time|heap size):[[:blank:]]+([0-9.]+)"
91                      benchmark-output)))
92    (fold (lambda (match result)
93            (cond ((equal? (match:substring match 1) "execution time")
94                   (cons (cons 'execution-time
95                               (string->number (match:substring match 2)))
96                         result))
97                  ((equal? (match:substring match 1) "heap size")
98                   (cons (cons 'heap-size
99                               (string->number (match:substring match 2)))
100                         result))
101                  (else
102                   result)))
103          '()
104          result)))
105
106(define (pretty-print-result benchmark reference bdwgc)
107  (define ref-heap (assoc-ref reference 'heap-size))
108  (define ref-time (assoc-ref reference 'execution-time))
109
110  (define (distance x1 y1 x2 y2)
111    ;; Return the distance between (X1,Y1) and (X2,Y2).  Y is the heap size,
112    ;; in MiB and X is the execution time in seconds.
113    (let ((y1 (/ y1 (expt 2 20)))
114          (y2 (/ y2 (expt 2 20))))
115      (sqrt (+ (expt (- y1 y2) 2)
116               (expt (- x1 x2) 2)))))
117
118  (define (score time heap)
119    ;; Return a score lower than +1.0.  The score is positive if the
120    ;; distance to the origin of (TIME,HEAP) is smaller than that of
121    ;; (REF-TIME,REF-HEAP), negative otherwise.
122
123    ;; heap  ^         .
124    ;; size  |         .   worse
125    ;;       |         .    [-]
126    ;;       |         .
127    ;;       | . . . .ref. . . .
128    ;;       |         .
129    ;;       |  [+]    .
130    ;;       | better  .
131    ;;     0 +-------------------->
132    ;;                        exec. time
133
134    (let ((ref-dist (distance ref-time ref-heap 0 0))
135          (dist     (distance time heap 0 0)))
136      (/ (- ref-dist dist) ref-dist)))
137
138  (define (score-string time heap)
139    ;; Return a string denoting a bar to illustrate the score of (TIME,HEAP)
140    ;; relative to (REF-TIME,REF-HEAP).
141    (define %max-width 15)
142
143    (let ((s (score time heap)))
144      (make-string (inexact->exact (round (* (if (< s 0.0) (- s) s)
145                                             %max-width)))
146                   (if (< s 0.0)
147                       #\-
148                       #\+))))
149
150  (define (print-line name result ref?)
151    (let ((name (string-pad-right name 23))
152          (time (assoc-ref result 'execution-time))
153          (heap (assoc-ref result 'heap-size)))
154      (format #t "~a ~6,2f (~,2fx)    ~7,3f (~,2fx)~A~%"
155              name
156              (/ heap (expt 2.0 20)) (/ heap ref-heap 1.0)
157              time (/ time ref-time 1.0)
158              (if (not ref?)
159                  (string-append " "
160                                 (score-string time heap))
161                  ""))))
162
163  (format #t "benchmark: `~a'~%" benchmark)
164  (format #t "                       heap size (MiB)  execution time (s.)~%")
165  (print-line "Guile" reference #t)
166  (for-each (lambda (bdwgc)
167              (let ((name (format #f "BDW-GC, FSD=~a~a"
168                                  (assoc-ref bdwgc 'free-space-divisor)
169                                  (cond ((assoc-ref bdwgc 'incremental?)
170                                         " incr.")
171                                        ((assoc-ref bdwgc 'generational?)
172                                         " gene.")
173                                        ((assoc-ref bdwgc 'parallel?)
174                                         " paral.")
175                                        (else "")))))
176                (print-line name bdwgc #f)))
177            bdwgc))
178
179(define (print-raw-result benchmark reference bdwgc)
180  (pretty-print `(,benchmark
181                  (reference . ,reference)
182                  (bdw-gc    . ,bdwgc))))
183
184
185
186;;;
187;;; Option processing.
188;;;
189
190(define %options
191  (list (option '(#\h "help") #f #f
192                (lambda args
193                  (show-help)
194                  (exit 0)))
195        (option '(#\r "reference") #t #f
196                (lambda (opt name arg result)
197                  (alist-cons 'reference-environment arg
198                              (alist-delete 'reference-environment result
199                                            eq?))))
200        (option '(#\b "bdw-gc") #t #f
201                (lambda (opt name arg result)
202                  (alist-cons 'bdwgc-environment arg
203                              (alist-delete 'bdwgc-environment result
204                                            eq?))))
205        (option '(#\d "benchmark-dir") #t #f
206                (lambda (opt name arg result)
207                  (alist-cons 'benchmark-directory arg
208                              (alist-delete 'benchmark-directory result
209                                            eq?))))
210        (option '(#\p "profile-options") #t #f
211                (lambda (opt name arg result)
212                  (let ((opts (assoc-ref result 'profile-options)))
213                    (alist-cons 'profile-options
214                                (string-append opts " " arg)
215                                (alist-delete 'profile-options result
216                                              eq?)))))
217        (option '(#\l "log-file") #t #f
218                (lambda (opt name arg result)
219                  (alist-cons 'log-port (open-output-file arg)
220                              (alist-delete 'log-port result
221                                            eq?))))
222        (option '("raw") #f #f
223                (lambda (opt name arg result)
224                  (alist-cons 'printer print-raw-result
225                              (alist-delete 'printer result eq?))))
226        (option '("load-results") #f #f
227                (lambda (opt name arg result)
228                  (alist-cons 'load-results? #t result)))))
229
230(define %default-options
231  `((reference-environment . "GUILE=guile")
232    (benchmark-directory   . "./gc-benchmarks")
233    (log-port              . ,(current-output-port))
234    (profile-options       . "")
235    (input                 . ())
236    (printer               . ,pretty-print-result)))
237
238(define (show-help)
239  (format #t "Usage: run-benchmark [OPTIONS] BENCHMARKS...
240Run BENCHMARKS (a list of Scheme files) and display a performance
241comparison of standard Guile (1.9) and the BDW-GC-based Guile.
242
243  -h, --help      Show this help message
244
245  -r, --reference=ENV
246  -b, --bdw-gc=ENV
247                  Use ENV as the environment necessary to run the
248                  \"reference\" Guile (1.9) or the BDW-GC-based Guile,
249                  respectively.  At a minimum, ENV should define the
250                  `GUILE' environment variable.  For example:
251
252                    --reference='GUILE=/foo/bar/guile LD_LIBRARY_PATH=/foo'
253
254  -p, --profile-options=OPTS
255                  Pass OPTS as additional options for `gc-profile.scm'.
256  -l, --log-file=FILE
257                  Save output to FILE instead of the standard output.
258
259      --raw       Write benchmark results in raw (s-exp) format.
260      --load-results
261                  Load raw (s-exp) results instead of actually running
262                  the benchmarks.
263
264  -d, --benchmark-dir=DIR
265                  Use DIR as the GC benchmark directory where `gc-profile.scm'
266                  lives (it is automatically determined by default).
267
268Report bugs to <bug-guile@gnu.org>.~%"))
269
270(define (parse-args args)
271  (define (leave fmt . args)
272    (apply format (current-error-port) (string-append fmt "~%") args)
273    (exit 1))
274
275  (args-fold args %options
276             (lambda (opt name arg result)
277               (leave "~A: unrecognized option" opt))
278             (lambda (file result)
279               (let ((files (or (assoc-ref result 'input) '())))
280                 (alist-cons 'input (cons file files)
281                             (alist-delete 'input result eq?))))
282             %default-options))
283
284
285;;;
286;;; The main program.
287;;;
288
289(define (main . args)
290  (let* ((args            (parse-args args))
291         (benchmark-files (assoc-ref args 'input)))
292
293    (let* ((log       (assoc-ref args 'log-port))
294           (bench-dir (assoc-ref args 'benchmark-directory))
295           (ref-env   (assoc-ref args 'reference-environment))
296           (bdwgc-env (or (assoc-ref args 'bdwgc-environment)
297                          (string-append "GUILE=" bench-dir
298                                         "/../meta/guile")))
299           (prof-opts (assoc-ref args 'profile-options))
300           (print     (assoc-ref args 'printer)))
301      (define (run benchmark)
302        (let ((ref   (parse-result (run-reference-guile ref-env
303                                                        bench-dir
304                                                        prof-opts
305                                                        benchmark)))
306              (bdwgc (map (lambda (fsd incremental?
307                                       generational? parallel?)
308                            (let ((opts
309                                   (list
310                                    (cons 'free-space-divisor fsd)
311                                    (cons 'incremental? incremental?)
312                                    (cons 'generational? generational?)
313                                    (cons 'parallel? parallel?))))
314                              (append opts
315                                      (parse-result
316                                       (run-bdwgc-guile bdwgc-env
317                                                        bench-dir
318                                                        prof-opts
319                                                        opts
320                                                        benchmark)))))
321                          '( 3  6  9  3  3)
322                          '(#f #f #f #t #f)      ;; incremental
323                          '(#f #f #f #f #t)      ;; generational
324                          '(#f #f #f #f #f))))   ;; parallel
325          `(,benchmark
326            (reference . ,ref)
327            (bdw-gc    . ,bdwgc))))
328
329      (define (load-results file)
330        (with-input-from-file file
331          (lambda ()
332            (let loop ((results '()) (o (read)))
333              (if (eof-object? o)
334                  (reverse results)
335                  (loop (cons o results)
336                        (read)))))))
337
338      (for-each (lambda (result)
339                  (let ((benchmark (car result))
340                        (ref       (assoc-ref (cdr result) 'reference))
341                        (bdwgc     (assoc-ref (cdr result) 'bdw-gc)))
342                    (with-output-to-port log
343                      (lambda ()
344                        (print benchmark ref bdwgc)
345                        (newline)
346                        (force-output)))))
347                (if (assoc-ref args 'load-results?)
348                    (append-map load-results benchmark-files)
349                    (map run benchmark-files))))))
350