#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))
         (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)))
             (loop (- n 1)))))
    (when old-style
        (begin (newline)
               (display "Warning: Using old-style run-benchmark")
    (display "--------------------------------------------------------")
    (display name)
    ; 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)