;;; Time-stamp: <2006-10-10 14:00:16 nhw>
;;; Copyright (C) by Noel Welsh.

;;; This library is free software; you can redistribute it
;;; and/or modify it under the terms of the GNU Lesser
;;; General Public License as published by the Free Software
;;; Foundation; either version 2.1 of the License, or (at
;;; your option) any later version.

;;; This library is distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the
;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
;;; PARTICULAR PURPOSE.  See the GNU Lesser General Public
;;; License for more details.

;;; You should have received a copy of the GNU Lesser
;;; General Public License along with this library; if not,
;;; write to the Free Software Foundation, Inc., 59 Temple
;;; Place, Suite 330, Boston, MA 02111-1307 USA

;;; Author: Noel Welsh <>
;; Commentary:

(module benchmark mzscheme

   (lib "")
   (lib "" "srfi" "42")
   (planet "plt/" ("schematics" "schemeunit.plt" 2))
   (planet "" ("schematics" "schemeunit.plt" 2))
   (planet "" ("williams" "science.plt" 2))
   (file ""))

   (lib "" "setup"))


  ;; struct (benchmark-test-case schemeunit-test-case) : string
  (define-struct (benchmark-test-case schemeunit-test-case) (log-file))

  ;; syntax this-expression-benchmark-log-file : () -> path
  (define-syntax (this-expression-benchmark-log-file stx)
    (syntax-case stx ()
       ;; The expressions generating directory and file-name
       ;; below are cut'n'paste from
       ;; this-expression-source-directory and
       ;; this-expression-file-name from in MzLib.  I
       ;; tried to use the macros (as so maintain
       ;; abstraction) but just couldn't get the things to
       ;; pickup the right source location.
             (let* ([source (syntax-source stx)]
                    [source (and (path? source) source)]
                    [local (or (current-load-relative-directory) (current-directory))]
                    [dir (path->main-collects-relative
                          (or (and source (file-exists? source)
                                   (let-values ([(base file dir?) (split-path source)])
                                     (and (path? base)
                                          (path->complete-path base local))))
               (if (and (pair? dir) (eq? 'collects (car dir)))
                   (with-syntax ([d dir])
                     #'(main-collects-relative->path 'd))
                   (with-syntax ([d (if (bytes? dir) dir (path->bytes dir))])
                     #'(bytes->path d))))]
             (let* ([f (syntax-source stx)]
                    [f (and f (path? f) (file-exists? f)
                            (let-values ([(base file dir?) (split-path f)]) file))])
               (if f
                   (with-syntax ([f (path->bytes f)]) #'(bytes->path f))
         (syntax/loc stx
             (path->string file-name)

  ;; syntax benchmark-case : expr ... -> test-case
  (define-syntax (benchmark-case stx)
    (syntax-case stx ()
      [(_ name expr ...)
       (with-syntax ([log-file
           (lambda ()
             (let* ([test-thunk (lambda () expr ...)]
                    [times (collect-and-time test-thunk)]
                    [previous-run (find-most-recent-run log-file name)])
               (if previous-run
                   (check-faster-times times (run-times previous-run)))
               (add-run log-file name times)

  ;; cpu-time : (() -> any) -> integer
  (define (cpu-time thunk)
    (let-values (([result cpu real gc] (time-apply thunk null)))

  ;; collect-and-time : (() -> any) -> (vectorof integer)
  (define (collect-and-time thunk)
    (vector-ec (:range i 0 10) (cpu-time thunk)))

  ;; faster? : (() -> any) (() -> any) : (U #t #f)
  ;; True if thunk1 is faster than thunk2, false otherwise
  (define (faster? thunk1 thunk2)
    (let ([time1 (collect-and-time thunk1)]
          [time2 (collect-and-time thunk2)])
      (< (mean time1) (mean time2))))

  (define-check (check-faster thunk1 thunk2)
    (let ([times1 (collect-and-time thunk1)]
          [times2 (collect-and-time thunk2)])
      (check-faster-times times1 times2)))

  (define (check-faster-times times1 times2)
    (if (< (mean times1) (mean times2))
         (('mean1 (mean times1))
          ('mean2 (mean times2))
          ('std-dev1 (standard-deviation times1))
          ('std-dev2 (standard-deviation times2))
          ('slowdown (/ (mean times1) (mean times2))))