;;; -*- Mode: LISP; Syntax: Common-lisp; Package: Timer; Base: 10 -*-
;*********************************************************************
;*                                                                   *
;*    PROGRAM      H I G H   R E S O L U T I O N    T I M E R        *
;*    PACKAGE      TIMER                                             *
;*                                                                   *
;*********************************************************************
   ;* Author:     Alex Repenning, ralex@cs.colorado.edu              *
   ;*             Copyright (c) 1992 Alex Repenning                  *
   ;* Address:    Computer Science Department                        *
   ;*             University of Colorado at Boulder                  *
   ;*             Boulder, CO 80309-0430                             *
   ;*                                                                *
   ;* Filename:   hires-timer.lisp                                   *
   ;* Update:     8/16/96                                            *
   ;* Version:                                                       *
   ;*   1.0  10/18/91 Alex Repenning                                 *
   ;*   1.1   1/ 8/92 Alex: CLtL2                                    *
   ;*   1.2   2/22/92 Alex & Brent Reeves: Symbolics                 *
   ;*   1.3   8/16/96 MCL 3.0 updates                                *
   ;* System:     Macintosh II, MCL 2.0                              *
   ;* Abstract:   Not your father's TIME macro anymore.              *
   ;*   Have you ever written code like:                             *
   ;*     (time (dotimes (i 10000..) <some-form-to-be-timed>))       *
   ;*   .. then this is for you! No more playing with the number of  *
   ;*   times to call your code, measure time of an empty dotimes,   *
   ;*   compilation, etc.                                            *
   ;*   The whole thing started really small and got out of hand     *
   ;*   big time.                                                    *
   ;* Features:                                                      *
   ;*   - High Resolution: gives you the time it takes to eval forms *
   ;*       with a resolution much better than that of the built-in  *
   ;*       TIME macro.                                              *
   ;*   - Portable: Only relies on Common Lisp functionality.        *
   ;*   - (Mac only) FRED Timer command: c-x c-t TIME-OF-SEXP        *
   ;* Status: interesting hack                                       *
   ;* How: compile the form to be tested, call it as many times as   *
   ;*   required to determine the time it takes. Compare the time    *
   ;*   with the time of an empty loop.                              *
   ;* Bugs, Problems: It may take a while to determine the time if   *
   ;*   the form to be timed is very fast (e.g., (SVREF ..)).        *
   ;*                                                                *
   ;******************************************************************

(defpackage TIMER
  (:use "COMMON-LISP")
  (:export duration))

(in-package "TIMER")

;----------------------------------
;  Parameters                      |
;----------------------------------

(defvar *Maximum-User-Patience* 40.0 
 "  Seconds. Time after which the test gets aborted.")

(defvar *Minimum-Test-Form-Run-Time* 1.0 
 "  Seconds. The minimal time spent in the test form to
   get acceptable results.")

(defvar *Minimum-Loop-Run-Time* 0.1
 " Seconds. The minimal time spend in the loop CONTAINING the test
  form to compute an upper estimate of the test form time.")

;----------------------------------
;  Portable Code                   |
;----------------------------------

(defmacro DURATION (Form &key (Verbose t) (Print nil) (Count 5) (GC nil) Vars
                         (Stream t)) "
  in:  Form {t},
       &key Verbose {boolean} default t; print final result,
       Print {boolean} default nil; print progress,
       Count {fixnum} default 4; number of times the empty loop and the
         loop containing <form> get executed in one test sequence,
       GC {boolean} default nil; start with a garbage collection if non-nil,
       Vars {list of: {(<varname> <value>) or {varname}}; additional
         variables lexically accessible to <form>,
       Stream {stream} default t.
  out: Result {t}, Time {float}.
  Determine the time to evaluate a compiled version of <Form>. Only CL timing 
  functions are used. It therefore might be necessary to evaluate <Form> 
  several times in order to get an accurate time depending on the timer 
  resolution."
  (let ((Loopvar (gensym)) (Timesvar (gensym)))
    `(time-of-form
      #'(lambda (,Timesvar)
          (declare (optimize (speed 3) (safety 0)))
          (let ,Vars
            (values
             ,Form
             (get-internal-real-time)
             (progn 
               ;lets hope non-MCL compilers will not
               ; optimize the empty dotimes loop away!
               (dotimes (,Loopvar ,Timesvar)
		 #+:symbolics (declare (ignore ,Loopvar)))
               (get-internal-real-time))
             (progn 
               (dotimes (,Loopvar ,Timesvar)
		 #+:symbolics (declare (ignore ,Loopvar))
		 ,Form)
               (get-internal-real-time)))))
      ',Form
      ',Verbose
      ',Print
      ',Count
      ',GC
      ',Stream)))


(defun TIME-OF-FORM (Function Form Verbose Print Count GC Stream)
  (declare (special *Minimum-Test-Form-Run-Time* *Maximum-User-Patience*
                    *Minimum-Loop-Run-Time*))
  (let ((Loops 1)
        (Time-to-Quit (+ (get-internal-real-time)
                         (* *Maximum-User-Patience*
			    Internal-Time-Units-Per-Second)))
        (Time 0)
        (Code-Time 0)
        (Iterations 0)
        Result)
    (when GC (garbage-collection))
    ;; some Lisp systems compile automatically
    ; compiled-function-p of a compiled lexical closures returns nil
    ; in MCL 2.0b1p3. Bug?
    (unless 
      #-:ccl (compiled-function-p Function)
      #+:ccl ccl:*Compile-Definitions* 
      (setq Function (compile nil Function)))
    ; if there is a problem in the form to be tested you better know it soon..
    (setq Result (funcall Function 0))
    (loop
      (dotimes (I Count)
	#+:symbolics (declare (ignore I))
        (multiple-value-bind (Form T0 T1 T2) (funcall Function Loops)
          (declare (ignore Form) (fixnum T0 T1 T2))
          (incf Code-Time (- T2 T1))
          (incf Time (- T2 T1 (- T1 T0)))))
      (incf Iterations (* Loops Count)) 
      (let ((STime (/ Time Internal-Time-Units-Per-Second))
            (SCode-Time (/ Code-Time Internal-Time-Units-Per-Second)))
        (cond
         ((> (get-internal-real-time) Time-to-Quit)
          ; Time to quit!
          (when Verbose
            (format Stream "~&Iterations: ~6D  Time: < " Iterations)
            (print-time (/ SCode-Time Iterations) Stream))
          (return (values Result (float (/ STime Iterations)) Function)))
         ((< STime *Minimum-Test-Form-Run-Time*)
          ; the result is not good enough (noise and/or timer resolution)
          (when Print
            (format Stream "~&Iterations: ~6D" Iterations)
            (when (> SCode-Time *Minimum-Loop-Run-Time*)
              (format Stream "  Time: < ")
              (print-time (/ SCode-Time Iterations) Stream)))
          (setq Loops (* Loops 2)))
         (t ; determined the time
          (when Verbose
            (format Stream "~&Iterations: ~D, Time: " Iterations)
            (print-time (/ STime Iterations) Stream)
            (format Stream ", Form: ~A " Form))
          (return (values Result (float (/ STime Iterations)) Function))))))))



(defun PRINT-TIME (Time &optional (S t))
  "
  in:  Time {float} time in seconds,
       &optional S {stream} default t.
  Print <Time> using s, ms, us, or ns representation."
  (if (zerop time)
    (format S "~E seconds" Time)
    (let ((E (/ (log (abs Time)) #.(log 10))))
      (cond
       ((> E 0)  (format S "~E seconds" Time))
       ((> E -3) (format S "~6,2F ms" (* Time 1e3)))
       ((> E -6) (format S "~6,2F us" (* Time 1e6)))
       ((> E -9) (format S "~6,2F ns" (* Time 1e9)))
       (t (format S "~E seconds" Time))))))


(defun GARBAGE-COLLECTION ()
  #+:coral (ccl:gc) 
  #+:allegro (excl:gc))

;-------------------------
;  MCL only               |
;-------------------------
#+:mcl
(defmethod TIME-OF-SEXP ((Self ccl:fred-mixin)) "
  in: Self {fred-mixin}." 
  (let ((*Package* (or (ccl:window-package Self) *Package*))
        (ccl::*Clear-Mini-Buffer* nil))
    (ccl:set-mini-buffer 
     (ccl:view-window Self)
     (print
     (with-output-to-string (String)
       (eval `(duration ; ok, I could have done without eval..
               ,(ccl:buffer-current-sexp (ccl:fred-buffer Self))
               :stream ,String)))))))

#+:mcl
(ccl:comtab-set-key ccl:*Control-X-Comtab* '(:control #\t) 'time-of-sexp)



#| Examples (times are on a MacII, using MCL 2.0b1p3):

Arithmetic
==========

(duration (sin 5.0))                    ; 77 us amazing; this get not optimized!
(duration (sin x) :vars ((x 5.0)))      ; 78 us 
(duration (sin pi))                     ; 63 us  hmmm..
; the :print keyword will show intermediate steps
(duration (+ 5 6) :print t)             ; 110 ns well optimized - just put 11 on stack

(duration (+ a b) :vars ((a 5) (b 6)) :print t)   ; 1.7 us  that's more like it

Array Access
============

(setq a (make-array 10))

(duration (aref a 3))                   ; 19 us
(duration (svref a 3))                  ;  7 us better but still slow

local variables
---------------

(duration (svref a 3) :vars ((a a)) :print t)   ; 500 ns !!!
; accessing the global non-special variable a was more than 10 times
; slower than the actual array access!

(defvar a2 a)

(duration (svref a2 3))                 ; 1 us 
; accessing special variables is much faster

(duration (aref a 3) :vars ((a a)))     ; 13 us

(duration (ccl::%svref a 3) :vars ((a a)))   ; 500 ns

;******* The Art of Noise *************

(defvar *Noise* nil)

#-:ccl
(defun RECORD-NOISE (N)
  (setq *Noise* nil)
  (let* ((Start-Time (get-internal-real-time))
         (Time (progn (should-take-constant-time)
                      (- (get-internal-real-time) Start-Time))))
    (dotimes (I N)
      (let* ((Start-Time (get-internal-real-time))
             (New-Time (progn (should-take-constant-time)
                              (- (get-internal-real-time) Start-Time))))
        (push (- New-Time Time) *Noise*)))))


#+:ccl
(defun RECORD-NOISE (N)
  (setq *Noise* nil)
  (let* (Time)
    (ccl:time-code Time  (should-take-constant-time))
    (dotimes (I N)
      (let* (New-Time)
        (ccl:time-code New-Time  (should-take-constant-time))
        (push (- New-Time Time) *Noise*)))))

(time (record-noise 100))

(plot-noise)

(defun PLOT-NOISE ()
  (dolist (I *Noise*) (print I)))
        

(defun SHOULD-TAKE-CONSTANT-TIME ()
  (dotimes (I 1000)))

|#