57 lines
1.8 KiB
Racket
57 lines
1.8 KiB
Racket
#lang s-exp "../../lang/base.rkt"
|
|
|
|
(provide run-benchmark)
|
|
|
|
|
|
;;; Gambit-style run-benchmark.
|
|
;;;
|
|
;;; Invoke this procedure to run a benchmark.
|
|
;;; The first argument is a string identifying the benchmark.
|
|
;;; The second argument is the number of times to run the benchmark.
|
|
;;; The third argument is a thunk that runs the benchmark.
|
|
;;; The fourth argument is a unary predicate that warns if the result
|
|
;;; returned by the benchmark is incorrect.
|
|
;;;
|
|
;;; Example:
|
|
;;; (run-benchmark "make-vector"
|
|
;;; 1
|
|
;;; (lambda () (make-vector 1000000))
|
|
;;; (lambda (v) (and (vector? v) (= (vector-length v) #e1e6))))
|
|
|
|
;;; For backward compatibility, this procedure also works with the
|
|
;;; arguments that we once used to run benchmarks in Larceny.
|
|
|
|
(define (run-benchmark name arg2 . rest)
|
|
(let* ((old-style (procedure? arg2))
|
|
(thunk (if old-style arg2 (car rest)))
|
|
(n (if old-style
|
|
(if (null? rest) 1 (car rest))
|
|
arg2))
|
|
(ok? (if (or old-style (null? (cdr rest)))
|
|
(lambda (result) #t)
|
|
(cadr rest)))
|
|
(result '*))
|
|
(define (loop n)
|
|
(cond ((zero? n) #t)
|
|
((= n 1)
|
|
(set! result (thunk)))
|
|
(else
|
|
(thunk)
|
|
(loop (- n 1)))))
|
|
(when old-style
|
|
(begin (newline)
|
|
(display "Warning: Using old-style run-benchmark")
|
|
(newline)))
|
|
(newline)
|
|
(display "--------------------------------------------------------")
|
|
(newline)
|
|
(display name)
|
|
(newline)
|
|
; time is a macro supplied by Chez Scheme
|
|
(time (loop n))
|
|
(when (not (ok? result))
|
|
(begin (display "Error: Benchmark program returned wrong result: ")
|
|
(write result)
|
|
(newline)))))
|
|
|