Commit | Line | Data |
---|---|---|
1b706edf LC |
1 | ;;; Gambit-style run-benchmark. |
2 | ;;; | |
3 | ;;; Invoke this procedure to run a benchmark. | |
4 | ;;; The first argument is a string identifying the benchmark. | |
5 | ;;; The second argument is the number of times to run the benchmark. | |
6 | ;;; The third argument is a thunk that runs the benchmark. | |
7 | ;;; The fourth argument is a unary predicate that warns if the result | |
8 | ;;; returned by the benchmark is incorrect. | |
9 | ;;; | |
10 | ;;; Example: | |
11 | ;;; (run-benchmark "make-vector" | |
12 | ;;; 1 | |
13 | ;;; (lambda () (make-vector 1000000)) | |
14 | ;;; (lambda (v) (and (vector? v) (= (vector-length v) #e1e6)))) | |
15 | ||
16 | ;;; For backward compatibility, this procedure also works with the | |
17 | ;;; arguments that we once used to run benchmarks in Larceny. | |
18 | ||
19 | (define (run-benchmark name arg2 . rest) | |
20 | (let* ((old-style (procedure? arg2)) | |
21 | (thunk (if old-style arg2 (car rest))) | |
22 | (n (if old-style | |
23 | (if (null? rest) 1 (car rest)) | |
24 | arg2)) | |
25 | (ok? (if (or old-style (null? (cdr rest))) | |
26 | (lambda (result) #t) | |
27 | (cadr rest))) | |
28 | (result '*)) | |
29 | (define (loop n) | |
30 | (cond ((zero? n) #t) | |
31 | ((= n 1) | |
32 | (set! result (thunk))) | |
33 | (else | |
34 | (thunk) | |
35 | (loop (- n 1))))) | |
36 | (if old-style | |
37 | (begin (newline) | |
38 | (display "Warning: Using old-style run-benchmark") | |
39 | (newline))) | |
40 | (newline) | |
41 | (display "--------------------------------------------------------") | |
42 | (newline) | |
43 | (display name) | |
44 | (newline) | |
45 | ; time is a macro supplied by Chez Scheme | |
46 | (time (loop n)) | |
47 | (if (not (ok? result)) | |
48 | (begin (display "Error: Benchmark program returned wrong result: ") | |
49 | (write result) | |
50 | (newline))))) |