;;;
;;; 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 <noelwelsh@yahoo.com>
;;
;;
;; Commentary:

(module benchmark mzscheme

  (require
   (lib "etc.ss")
   (lib "comprehensions.ss" "srfi" "42")
   (planet "plt/base.ss" ("schematics" "schemeunit.plt" 2))
   (planet "test.ss" ("schematics" "schemeunit.plt" 2))
   (planet "science.ss" ("williams" "science.plt" 2))
   (file "benchmark-log.ss"))

  (require-for-syntax
   (lib "main-collects.ss" "setup"))

  (provide
   benchmark-case
   benchmark-test-case-log-file
   this-expression-benchmark-log-file
   collect-and-time
   check-faster
   check-faster-times
   faster?)

  ;; 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 ()
      [(this-expression-benchmark-log-file)
       ;; The expressions generating directory and file-name
       ;; below are cut'n'paste from
       ;; this-expression-source-directory and
       ;; this-expression-file-name from etc.ss 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.
       (with-syntax
           ([directory
             (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))))
                              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))))]
            [file-name
             (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))
                   #'#f))])
         (syntax/loc stx
           (build-path
            directory
            (string-append
             (path->string file-name)
             ".benchmark-log"))))]))

  ;; syntax benchmark-case : expr ... -> test-case
  (define-syntax (benchmark-case stx)
    (syntax-case stx ()
      [(_ name expr ...)
       (with-syntax ([log-file
                      (datum->syntax-object
                       stx
                       '(this-expression-benchmark-log-file)
                       stx)])
         (syntax
          (make-benchmark-test-case
           name
           (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)
               #t))
           log-file)))]))

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

  ;; collect-and-time : (() -> any) -> (vectorof integer)
  (define (collect-and-time thunk)
    (collect-garbage)
    (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))
        #t
        (with-check-info
         (('mean1 (mean times1))
          ('mean2 (mean times2))
          ('std-dev1 (standard-deviation times1))
          ('std-dev2 (standard-deviation times2))
          ('slowdown (/ (mean times1) (mean times2))))
         (fail-check))))
  )