| 1 | #!/bin/sh |
| 2 | # -*- Scheme -*- |
| 3 | exec ${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 | \f |
| 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 | \f |
| 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 | \f |
| 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... |
| 240 | Run BENCHMARKS (a list of Scheme files) and display a performance |
| 241 | comparison 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 | |
| 268 | Report 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 | \f |
| 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)))))) |