shootout.rkt
#lang racket/base
;;; @Package  shootout
;;; @Subtitle Expression Performance Comparison for Racket
;;; @HomePage http://www.neilvandyke.org/racket-shootout/
;;; @Author   Neil Van Dyke
;;; @Version  0.2
;;; @Date     2010-12-22
;;; @PLaneT   neil/shootout:1:=1

;; $Id: shootout.rkt,v 1.19 2011/08/22 12:11:48 neilpair Exp $

;;; @legal
;;; Copyright @copyright{} 2010 Neil Van Dyke.  This program 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 3 of the License (LGPL 3), or (at your option) any later version.
;;; This program 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
;;; @indicateurl{http://www.gnu.org/licenses/} for details.  For other licenses
;;; and consulting, please contact the author.
;;; @end legal

(require (for-syntax racket/base))

;;; @section Introduction

;;; This package provides the @code{shootout} syntax, which is a convenient
;;; tool to help compare the performance of multiple Racket expressions.  This
;;; can be useful when hand-optimizing performance-sensitive Racket code.
;;;
;;; For example, the program:
;;;
;;; @lisp
;;; (define (va x (y "bbb") (z "ccc"))
;;;   (expt 42 42)
;;;   (string-append x y z))
;;;
;;; (define (fa x y z)
;;;   (expt 42 42)
;;;   (string-append x y z))
;;;
;;; (shootout (va "aaa")
;;;           (fa "aaa" "bbb" "ccc")
;;;           #:repeat 1000000)
;;; @end lisp
;;;
;;; might produce a log similar to:
;;;
;;; @example
;;; SHOOTOUT-SAMPLING-GC-BASE
;;;
;;; SHOOTOUT-BEGIN (REPEAT 1000000, GC-BASE-MS 2498, GC-BASE-GCMS 2496)
;;;
;;; SHOOTOUT-EXPRESSION 1:
;;; (va "aaa")
;;; SHOOTOUT-TIMING (RUN 275, RUN-GCMS 12, COST 274, COST-GCMS 12, CLEANUP-DIFF -2.0)
;;;
;;; SHOOTOUT-EXPRESSION 2:
;;; (fa "aaa" "bbb" "ccc")
;;; SHOOTOUT-TIMING (RUN 255, RUN-GCMS 12, COST 254, COST-GCMS 13, CLEANUP-DIFF -1.0)
;;;
;;; SHOOTOUT-END
;;; @end example
;;;
;;; The most meaningful numbers in this version of @code{shootout} are ``RUN''
;;; and ``RUN-GCMS''.  RUN is the real time in milliseconds during which the
;;; expression ran for the specificed number of iteractions (the ``REPEAT''
;;; number).  ``RUN-GMCS'' is the number of milliseconds of garbage collection
;;; (GC) time that occurred during the run.  Neither of these numbers includes
;;; the GC ``cleanup'' time that @code{shootout} performs in an attempt to
;;; gauge any lingering GC cost of the expression.
;;;
;;; Note that multiple runs of @code{shootout} may give substantially different
;;; results.  So, you may wish to run multiple times and take the variation
;;; into consideration before drawing any conclusions.
;;;
;;; Note that @code{shootout} is only an aid for performance-comparison, and
;;; does not control for all variables, nor are its measurements necessarily
;;; accurate.

;; TODO: !!! Improve documentation, once this has stabilized.

;;; @section Interface

;;; @defsyntax shootout expr ... [ #:repeat repeat ]
;;;
;;; Performs @var{repeat} iterations of each @var{expr} and reports performance
;;; information in a log.
;;;
;;; Note that the format of this log and the information is reports is likely
;;; to change in future versions of this package.

(define-syntax shootout
  (syntax-rules ()
    ((_ ARGn ...)
     (%shootout:1 (ARGn ...)
                  ()
                  #f
                  #f
                  1000))))

(define-syntax %shootout:1
  ;; (_ ARGs EXPRs GC-BASE-MS GC-BASE-GCMS REPEAT)
  (syntax-rules ()
    ;; Arg is "#:gc-base-ms":
    ((_ (#:gc-base-ms    X ARGn ...) EXPRs GC-BASE-MS GC-BASE-GCMS REPEAT)
     (%shootout:1 (ARGn ...)         EXPRs X          GC-BASE-GCMS REPEAT))
    ;; Arg is "#:gc-base-gcms":
    ((_ (#:gc-base-gcms X ARGn ...) EXPRs GC-BASE-MS GC-BASE-GCMS REPEAT)
     (%shootout:1 (ARGn ...)        EXPRs GC-BASE-MS X            REPEAT))
    ;; Arg is "#:repeat":
    ((_ (#:repeat X ARGn ...) EXPRs GC-BASE-MS GC-BASE-GCMS REPEAT)
     (%shootout:1 (ARGn ...)  EXPRs GC-BASE-MS GC-BASE-GCMS X))
    ;; Arg is expression:
    ((_ (ARG0 ARGn ...)      (EXPRn ...     ) GC-BASE-MS GC-BASE-GCMS REPEAT)
     (%shootout:1 (ARGn ...) (EXPRn ... ARG0) GC-BASE-MS GC-BASE-GCMS REPEAT))
    ;; No more args:
    ((_ () EXPRs GC-BASE-MS GC-BASE-GCMS REPEAT)
     (let ((gc-base-ms   GC-BASE-MS)
           (gc-base-gcms GC-BASE-GCMS)
           (repeat       REPEAT)
           (log          (current-output-port)))
       (%shootout:2 EXPRs gc-base-ms gc-base-gcms repeat log (+ 1) ())))))

(define-syntax %shootout:2
  ;; (_ EXPRs GC-BASE-MS GC-BASE-GCMS REPEAT LOG PLUS OUT)
  (syntax-rules ()
    ((_ () GC-BASE-MS GC-BASE-GCMS REPEAT LOG PLUS (OUTn ...))
     (begin
       (or (and GC-BASE-MS GC-BASE-GCMS)
           (begin
             ;; TODO: Give warning if one is specified but not the other.
             (display "\nSHOOTOUT-SAMPLING-GC-BASE\n")
             (flush-output)
             (collect-garbage)
             (collect-garbage)
             (collect-garbage)
             (let ((start-ms   (current-inexact-milliseconds))
                   (start-gcms (current-gc-milliseconds)))
               (collect-garbage)
               (collect-garbage)
               (collect-garbage)
               (let ((end-ms   (current-inexact-milliseconds))
                     (end-gcms (current-gc-milliseconds)))
                 (set! GC-BASE-MS   (- end-ms   start-ms))
                 (set! GC-BASE-GCMS (- end-gcms start-gcms))))))
       (display "\nSHOOTOUT-BEGIN (REPEAT "           LOG)
       (display REPEAT                                LOG)
       (display ", GC-BASE-MS "                       LOG)
       (display (inexact->exact (round GC-BASE-MS))   LOG)
       (display ", GC-BASE-GCMS "                     LOG)
       (display (inexact->exact (round GC-BASE-GCMS)) LOG)
       (display ")\n"                                 LOG)
       OUTn ...
       (display "\nSHOOTOUT-END\n" LOG)))
    ((_ (EXPR0 EXPRn ...)
        GC-BASE-MS
        GC-BASE-GCMS
        REPEAT
        LOG
        (PLUSn ...)
        (OUTn ...))
     (%shootout:2
      (EXPRn ...)
      GC-BASE-MS
      GC-BASE-GCMS
      REPEAT
      LOG
      (PLUSn ... 1)
      (OUTn ...
            (display    "\nSHOOTOUT-EXPRESSION " LOG)
            (display    (PLUSn ...)              LOG)
            (display    ":\n"                    LOG)
            (write      (quote EXPR0)            LOG)
            (write-char #\newline                LOG)
            (flush-output LOG)
            (collect-garbage)
            (collect-garbage)
            (collect-garbage)
            (let* ((start-mstp   (current-inexact-milliseconds))
                   (start-gcmstp (current-gc-milliseconds)))
              (let loop ((times REPEAT))
                (or (<= times 0)
                    (begin EXPR0
                           (loop (- times 1)))))
              ;; Note: We can't inhibit the GC, so little point in getting the
              ;; cleanup cost here.
              (let ((ran-mstp   (current-inexact-milliseconds))
                    (ran-gcmstp (current-gc-milliseconds)))
                (collect-garbage)
                (collect-garbage)
                (collect-garbage)
                (let* ((end-mstp        (current-inexact-milliseconds))
                       (end-gcmstp      (current-gc-milliseconds))
                       (run-ms          (- ran-mstp start-mstp))
                       (cleanup-ms      (- end-mstp ran-mstp))
                       (cleanup-cost-ms (- cleanup-ms GC-BASE-MS))
                       (total-ms        (- end-mstp start-mstp))
                       (cost-ms         (- total-ms GC-BASE-MS))
                       (run-gcms        (- ran-gcmstp start-gcmstp))
                       (total-gcms      (- end-gcmstp start-gcmstp))
                       (cost-gcms       (- total-gcms GC-BASE-GCMS)))
                  ;; (printf "*DEBUG* ~S\n"
                  ;;         `((cleanup-ms ,cleanup-ms)
                  ;;           (cleanup-cost-ms ,cleanup-cost-ms)))
                  (display "SHOOTOUT-TIMING (RUN "             LOG)
                  (display (inexact->exact (round run-ms))     LOG)
                  (display ", RUN-GCMS "                       LOG)
                  (display (inexact->exact (round run-gcms))   LOG)
                  (display ", COST "                           LOG)
                  (display (inexact->exact (round cost-ms))    LOG)
                  (display ", COST-GCMS "                      LOG)
                  (display (inexact->exact (round cost-gcms))  LOG)
                  (display ", CLEANUP-DIFF "                   LOG)
                  (display (round cleanup-cost-ms)             LOG)
                  (display ")\n"                               LOG)))))))))

;;; @unnumberedsec History

;;; @table @asis
;;;
;;; @item Version 0.2 --- 2011-08-22 -- PLaneT @code{(1 1)}
;;; Fixed typo in legal notice.
;;;
;;; @item Version 0.1 --- 2010-12-21 -- PLaneT @code{(1 0)}
;;; Initial release.
;;;
;;; @end table

(provide shootout)