;;; -*- cold-load:t; Mode:Common-Lisp; Package:TIME; Fonts:(MEDFNT HL12B HL12BI); Base:10. -*-

;1;;                           RESTRICTED RIGHTS LEGEND*

;1;;Use, duplication, or disclosure by the Government is subject to*
;1;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in*
;1;;Technical Data and Computer Software clause at 52.227-7013.*

;1;;                     TEXAS INSTRUMENTS INCORPORATED.*
;1;;                              P.O. BOX 2909*
;1;;                           AUSTIN, TEXAS 78769*
;1;;                                 MS 2151*

;1;; Copyright (C) 1985-1989 Texas Instruments Incorporated. All rights reserved.*
;	1** (c) Copyright 1980 Massachusetts Institute of Technology ***

;1;;*
;1;; Change history:*
;1;;*
;1;;  Date      Author*	1Description*
;1;; ---------------------------------------------------------------------*
;;; 04-24-89 DAB Added all function, variables, flavors and instances that are documented to export list.
;1;; 03/06/87   JK            Export documented functions and variables.*
;1;; 02/05/86  LGO*		1Change FIXNUM-MICROSECOND-TIME to return one 25 bit value*
;1;;*			1Change TIME-LESSP, TIME-DIFFERENCE and TIME-INCREMENT to work*
;1;;*			1with 25 bit values (instead of 23).*
;1;; 12/11/86   SBW          Fixed Timeit documentation errors*
;1;;                            Fixed negative time in calculate-cpu-time-internal*
;1;; 10/29/86   LGO*		1Rewrite TIMEIT (even more options than before!)*
;1;; 10/22/86   LGO*	1        *  1Fixed consing constants in END-TIMING.*
;1;;*			1Enabled the si:%total-page-fault-time meter within TIME.*
;1;;*			1Added the DESCRIBE-CONSING-P argument to TIME.*
;1;; 09/23/86   SBW          Modified documentation string of macro Time.*
;1;; 09/15/86   TWE&RNB*	1Fixed FIXNUM-MICROSECOND-TIME to use octal byte specifiers instead of decimal ones.*
;1;; 01/29/88  * 1Rjf          * 1Added flush of extra pdl to time routines*
;1;; 08/22/88   RJF          Changed timeit to not allow repeat to be used if*
;1;;                           * 1timeit ran interpreted.  Also added some changed to*
;1;;                           * 1solve the 1.2 hours problem.*

(EXPORT '(microsecond-time))
(export '(time:*timeit-defaults*           ;variable   ; DAB 04-24-89
	   time:timeit-report              ;function
	   time:define-meter               ;macro
	   time:microsecond-time           ;function
           time:microsecond-time-difference ;function
	   time:fixnum-microsecond-time    ;function
           )
	'time)

(PROCLAIM '(inline microsecond-time))

(DEFUN MICROSECOND-TIME ()
  "2Return the current value of the microsecond clock (a bignum).
Only differences in clock values are meaningful.  There are 32.
bits of data, so the value wraps around about every 72 minutes.*"
  (si:%MICROSECOND-TIME))

(PROCLAIM '(inline fixnum-microsecond-time))
(DEFUN FIXNUM-MICROSECOND-TIME ()
  "2Return the bottom 25 bits of the microsecond clock as a (possibly negative) fixnum.
Values can be used with TIME-LESSP, TIME-DIFFERENCE and TIME-INCREMENT.
Note that this isn't good for intervals greater than 16 seconds.*"
  (si:%fixnum-microsecond-time))

;1;; These two functions deal with the wrap-around lossage*
;; 4/28/89 clm - due to increased complexity, removed the inline
;; declaration for TIME-LESSP.
;;(PROCLAIM '(inline time-lessp)) 
;; 4/28/89 clm for ab - fix to handle wrap conditions correctly.
(DEFUN time-lessp (time1 time2 &aux difference)
  "Compare two values of (TIME); return T if the first is less.
If two times too far apart are compared, you get the wrong answer,
since (TIME) wraps around.  Do not use (TIME) for applications where that can
matter."
  (IF (PLUSP (SETF difference (- time2 time1)))
      (< difference (FLOOR (1+ most-positive-fixnum) 2))
      (PROGN
	(INCF time2 (1+ most-positive-fixnum))
	(< (- time2 time1) (FLOOR (1+ most-positive-fixnum) 2)))))

(DEFUN TIME-DIFFERENCE (TIME1 TIME2)
  "2Subtract one value of (TIME) from another, or subtract an interval from a time.
Both the interval and the time are measured in 60'ths of a second.
This works correctly with wrap around provided times are not too far apart
or the interval is not too long.*"
  (DECLARE (inline time-difference))
  (ldb (byte 24 0) ;1; Only return positive values*
       (SI:%POINTER-DIFFERENCE TIME1 TIME2)))

(PROCLAIM '(inline time-increment))
(DEFUN TIME-INCREMENT (TIME INCREMENT)
  "2Add an interval to value of (TIME), both measured in 60'ths of a second.
This works correctly with wrap around provided times are not too far apart
or the interval is not too long.*"
 (si:%MAKE-POINTER-OFFSET SI:DTP-FIX TIME INCREMENT))

(PROCLAIM '(inline paging-time))
(DEFUN paging-time ()
  "2Measure the time spent processing page faults.
   This is disk-wait-time plus the time for creating new pages*"
  (si:read-meter 'si:%total-page-fault-time))

(PROCLAIM '(inline  hard-page-fault-count))
(DEFUN hard-page-fault-count ()
  "2Return the number of page-faults*"
  (+ (si:READ-METER 'si:%count-disk-page-reads)
     (si:READ-METER 'si:%count-fresh-pages)))   

;1;;  Analogue of time-difference;  handles wraparound.*
(defun microsecond-time-difference (end start)
  "2Return the difference between end and start microsecond times
   Handles microsecond clock wraparound (see microsecond-time.)*"
  (let ((diff (- end start)))
    (if (< diff 0)
	(+ end (- #x+100000000 start))
      diff)))

(DEFUN area-size (&optional area-number)
  "2Return the number of words used in AREA-NUMBER, or all areas.*"
  (IF (NOT area-number)
      (LOOP for area below (LENGTH si:area-list)
	    ;1; Don't include EXTRA-PDL area, as that just confuses most people*
	    unless #+explorer (= area si:extra-pdl-area) #-explorer nil
	    sum (area-size area))
    (DO ((region (si:area-region-list area-number) (si:region-list-thread region))
	 (sum 0 (+ sum (si:REGION-FREE-POINTER REGION))))
	((MINUSP region) sum))))

;1;*
;1; The TIME macro*
;1;*

(DEFMACRO TIME (&OPTIONAL FORM DESCRIBE-CONSING-P)
  "2 nil FORM:  
    Returns Time in 60'ths of a second.  Only differences
    between values are significant.  Time values wrap around
    about once a day, so use TIME-LESSP, TIME-INCREMENT and
    TIME-DIFFERENCE to compare and compute times.
 FORM: 
    Returns the value of evaluated form while printing to
    *TRACE-OUTPUT* RealTime, PagingTime, Number of Page Faults,
    and Number of conses.
 DESCRIBE-CONSING-P:
    When non-nil, describe number of conses by area.*"

  (IF (Null FORM)
      '(si:time-in-60ths)
    (LET ((VECTOR (GENSYM))
	  (start-time (GENSYM))
	  (end-time (GENSYM)))
      `(letf-globally (((LDB si:%%Time-Page-Faults-Enable si:%disk-switches) 1))
	 (LET ((,vector (start-timing))
	       (,start-time (si:%microsecond-time))
	       ,end-time)
	   (PROG1 ,form
		  (SETQ ,end-time (si:%microsecond-time))
		  (si:%flush-extra-pdl)
		  (end-timing ,vector ,start-time ,end-time ',form ,(NOT (NULL describe-consing-p)))))))))

(DEFRESOURCE area-size-vector (size)
  :constructor (MAKE-ARRAY size :leader-length 4))

(DEFUN start-timing ()
  "2Return a vector containg the number of words consed in every area.*"
  (DECLARE (inline paging-time hard-page-fault-count area-size))
  (si:%flush-extra-pdl)
  (LOOP with length = (LENGTH si:area-list)
	with vector = (ALLOCATE-RESOURCE 'area-size-vector length) ;;(MAKE-ARRAY length :leader-length 4)
	for area-number below length
	do (SETF (AREF vector area-number) (area-size area-number))
	finally
	(SETF (ARRAY-LEADER vector 0) length)
	(SETF (ARRAY-LEADER vector 1) (si:time-in-60ths))
	(SETF (ARRAY-LEADER vector 2) (hard-page-fault-count))
	(SETF (ARRAY-LEADER vector 3) (paging-time))
	(Return vector)))

(DEFUN end-timing (VECTOR start-time end-time form describe-consing-p)
  (DECLARE (inline area-size hard-page-fault-count paging-time microsecond-time-difference))
  (LET ((paging (microsecond-time-difference (paging-time) (ARRAY-LEADER vector 3)))
	(faults (- (hard-page-fault-count) (ARRAY-LEADER vector 2)))
	(timems (correct-for-us-clock-rollover (microsecond-time-difference end-time start-time)
					       (ARRAY-LEADER vector 1)))
        (consing-overhead 0)
	consing)
    ;; Check for bignums consed and than flushed to default-cons-area
    (if (not (fixnump end-time))  (incf consing-overhead 2))
    (if (not (fixnump start-time))(incf consing-overhead 2))
    ;1; Subtract current area length with lengths in AREA-VECTOR*
    (LOOP for area-number below (ARRAY-ACTIVE-LENGTH vector)
	  for size = (- (area-size area-number) (AREF vector area-number))
	  do (SETF (AREF vector area-number) size))
    (DEALLOCATE-RESOURCE 'area-size-vector vector)
    ;1; Collect those area lengths that have changed*
    (LOOP with consing-by-me = consing-overhead
	  for area-number below (ARRAY-ACTIVE-LENGTH vector)
	  for name in si:area-list
	  for size = (AREF vector area-number)
	  when (= area-number si:extra-pdl-area)           ;;ignore extra pdl (flushed)
	   do (SETQ size 0)
	  when (= area-number si:default-cons-area)        ;;Compensate for bignums copied out
	   do (setq size (MAX 0 (- size consing-by-me)))
	  unless (ZEROP size)
	  collect (LIST name size) into cons-list
	  finally (SETQ consing cons-list))
    
    (LET ((*print-pretty* t)
	  (total-consing (LOOP for area in consing sum (SECOND area))))
      (FORMAT *trace-output* "~%Evaluation of ~a took ~f Seconds of elapsed time,~@
			    including ~f seconds of paging time for ~d faults, Consed ~d word~:p."
	      form (/ timems 1E6) (/ paging 1e6) faults total-consing total-consing))
    (WHEN describe-consing-p
      (LOOP for (area size) in consing
	    do (FORMAT *trace-output* "~%~d word~:p consed into ~a" size area))))
  )

(DEFUN correct-for-us-clock-rollover (TIME time-60)
  (LET ((sixtith-to-usec (* (/ 1 60.0) 1e6)))	   ;1Conversion factor for 1/60 second to microseconds*
    (WHEN (PLUSP (SETQ time-60 (TIME-DIFFERENCE (si:time-in-60ths) time-60)))
      (SETQ time (+ time (* #x+100000000 (FLOOR time-60 (/ #x+100000000 sixtith-to-usec))))))
    time))


;1;;*
;1;; The TIMEIT macro*
;1;;*

;1; First define the different timing meters*

(eval-when (eval load compile)

;1; Currently, the timings TIMEIT produces is fixed at compile time (because its a macro).*
;1; It would probably be better to have TIMEIT compile its body into an internal function,*
;1; and pass that to a timing Function that would record all possable timings and report the ones asked for.*
;1; If ths was done, then *TIMEIT-DEFAULTS* would be effective at run-time, not just compile-time.*

(DEFVAR *TIMEIT-DEFAULTS* '(:cpu) "2Default options for the TIMEIT macro.*") 

(DEFMACRO define-meter (name &body options)
  "2Define a performance meter NAME with optional parameters:
 FORM is a form which returns the meter value.
 DIFFERENCE is used to subtract two meter values (default is -)
 HEADER is a string used for printing the value header.
 FORMAT is a format string used for reporting the value.
 REPORT is a function to apply to the value before printing it (with format).*"
  (DECLARE (ARGLIST name &key form difference header format report &allow-other-keys))
  `(DEFPROP ,name ,options meter))

(define-meter :cpu
  :header "2  CPU  *"
  :format "~7a"
  :difference calculate-cpu-time-internal
  :report pretty-time
  :form si:(read-meter '%total-page-fault-time))

(define-meter :time
  :header "2Real Time*"
  :format "~8a"
  :report pretty-time)

) ;1end eval-when*

(define-meter :label
  :header "2Name                *"
  :format "~20a")

(define-meter :faults
  :header "2Page-faults*"
  :format " ~9d "
  :form si:(+ (read-meter '%count-disk-page-reads)
	      (READ-METER '%count-fresh-pages)))

(define-meter :disk
  :header "2 Disk  *"
  :format "~7a"
  :difference microsecond-time-difference
  :report pretty-time
  :form si:(read-meter '%disk-wait-time))

(define-meter :paging
  :header "2Paging *"
  :format "~7a"
  :difference microsecond-time-difference
  :report pretty-time
  :form si:(read-meter '%total-page-fault-time))

(DEFMACRO calculate-cpu-time-internal (end start)
  ;1; This macro gets expanded within RECORD-TIMING where TIME is bound to real-time.*
  `(microsecond-time-difference time (microsecond-time-difference ,end ,start)))

(DEFSUBST subtract-cons-count (a b)
  (TRUNCATE (- a b) 4))

(define-meter :cons-meter
  :header "2  Consing  *"
  :format "~5d words"
  :difference subtract-cons-count
  :form si:(read-meter '%count-cons-work))

(define-meter :cons
  :header "2  Consing  *"
  :format "~5d words"
  :form (area-size))

(define-meter :number-cons
  :header "2Number Cons*"
  :format "~5d words"
  :form (area-size si:extra-pdl-area))

(DEFMACRO TIMEIT (OPTIONS &BODY BODY)
  "Execute body and print or return the execution time.  OPTIONS is a list of one or
more of the following option keywords:

  :label string		\"label to print\"
  :print stream    	; defaults to *trace-output*
  :repeat count	 	; Execute BODY count times, report averages
  :min			; if present, report minimum values for repeat
  :interrupts		; If present, allow interrupts
  :time			; If present, print total real-time
  :cpu	 		; If present, print time excluding  paging time
  :paging		; If present, print total paging time
  :disk 		; If present, print disk wait time
  :faults		; If present, print number of page faults
  :cons			; If present, print number of words consed
			; excluding number consing
  :number-cons		; If present, print number consing words
			; (for extended and floating-point numbers)
  :units time-unit	; Time units to report in. One of :seconds :microseconds :milliseconds
 			; :s :sec :ms :us or NIL.  When NIL, choose the \"best\" units
  :microseconds		; Short for :units :microseconds
  :milliseconds		; Short for :units :milliseconds
  :seconds		; Short for :units :seconds (same applies for :s :sec :ms and :us)
  :collect variable	; If present, collect timings into VARIABLE.
			; Use TIMEIT-REPORT to print these.
  :values keywords	; Values to return. One of (or a list of for multiple values):
			; :VALUE :DISK :PAGING :CPU :CONS :FAULTS
			; Values reported in the units specified (default is microseconds)
			; Defaults to :VALUE
  :separator string	; String printed between values.  Default is \", \"
  :header t-or-nil	; When T, print two lines, headers on first, values on second.
			; When NIL, don't print any value headers.
			; When :SIDE (the default) print headers beside values.
  :report function	; The report function to use.  Defaults to timeit-print

You may set default options in TIME:*TIMEIT-DEFAULTS*

Parameters can also be specified as (:keyword value).  This can be used to turn off
features selected in TIME:*TIMEIT-DEFAULTS*.  For example, (:cpu nil) or (:cpu) turns
off cpu time reporting.  

New meters can be defined with time:DEFINE-METER

If the first option is a string, it is taken as the label."
  ;; Parse options
  (LET (LABEL (PRINT :default) repeat min units interrupts values meters collect report args)
    (WHEN (STRINGP (CAR OPTIONS))
      (SETQ LABEL (POP OPTIONS)))
    (SETQ OPTIONS (APPEND *TIMEIT-DEFAULTS* OPTIONS))
    (KEYWORD-EXTRACT OPTIONS TEMP (label print repeat report values meters collect units)
		     (min interrupts)
      ((:seconds :milliseconds :microseconds :s :sec :ms :us) (SETQ units (CAR temp)))
      (otherwise (LET ((option (CAR temp)))
		         ;; Handle options that are lists
		   (COND ((CONSP option)
			  (LET ((opt (CAR option))
				(val (CDR option)))	           ;; Allow both (:values :time :cons) AND
			    (UNLESS (CDR val) (SETQ val (CAR val)));;            (:values (:time :cons))
			    (COND ((EQ opt :min) (SETQ min val))
				  ((EQ opt :interrupts) (SETQ interrupts val))
				  ((GET opt 'meter)
				   (SETQ meters (DELETE opt meters))
				   (WHEN val (PUSH opt meters)))
				  (t ;; Convert list to normal format
				   (SETQ temp (LIST* nil opt val (CDR temp)))))))
			 ;; Handle report options
			 ((MEMBER option '(:stream :separator :header :correct))
			  (PUSH (SECOND temp) args)
			  (PUSH option args)
			  (POP temp))
			 ;; Handle metering options
			 ((GET option 'meter)
			  (SETQ meters (DELETE option meters))
			  (PUSH option meters))
			 (t (FERROR "~a isn't a timeit option" option))))))
    ;; Print when there is a label, when :stream is non-nil, or when there are no :values options
    ;; Don't print when there's no label, no stream is specified, and values have been specified
    (UNLESS (LISTP values) (SETQ values (LIST values)))
    (WHEN (AND (NULL label) (EQ print :default) values)
      (SETQ print nil)
      (UNLESS (GETF args :collect)
	(SETQ meters nil))) ;; Don't calculate meters that can't be viewed
    (SETQ meters (REMOVE-DUPLICATES (NSET-DIFFERENCE (NCONC (NREVERSE meters) values) '(:label :value :all))))
    (WHEN (NOT (MEMBER print '(t :default))) (SETQ args (APPEND `(:stream ,print) args)))
    (WHEN values (SETQ args (APPEND `(:values ',values) args)))
    (WHEN units (SETQ args (APPEND `(:units ,units) args)))
    (WHEN collect (SETQ args (APPEND `(:collect ',collect) args)))
    (WHEN label (SETQ args (APPEND `(:label ,label) args)))
    (UNLESS report (SETQ report 'timeit-print))
    (WHEN (AND min (NOT repeat))
      (FERROR "It is not meaningful to specify :MIN and not :REPEAT"))
    (IF min
	(LET ((min-timing (GENSYM))
	      (temp-timing (GENSYM))
	      (min-meter (OR (AND (MEMBER min meters) min)
			     (AND (MEMBER :time meters) :time)
			     (AND (MEMBER :cpu meters) :cpu)
			     (CAR meters))))
	  `(LET (,min-timing ,temp-timing)
	     (DOTIMES (,(GENSYM) ,repeat)
	       (SETQ ,temp-timing (record-timing (,meters ,interrupts identity-rest ,repeat) ,@body))  ;;Rjf
	       (COND ((NULL ,min-timing)
		      (SETQ ,min-timing ,temp-timing))
		     ((< (GETF ,min-timing ,min-meter) (GETF ,temp-timing ,min-meter))
		      (SETQ ,min-timing ,temp-timing))))
	     (APPLY ',report ,@args ,min-timing)
	     ))
      (WHEN repeat (SETQ args (APPEND `(:repeat ,repeat) args)))
      `(record-timing (,meters ,interrupts ,report ,repeat ,@args)     ;;Rjf
	 ,@(IF repeat
	       (LET ((repeat-count (GENSYM))
		     (repeat-value (GENSYM)))
		 `((DO ((,repeat-count ,repeat (1- ,repeat-count))
			,repeat-value)
		       ((NOT (PLUSP ,repeat-count)) ,repeat-value)
		     (SETQ ,repeat-value (PROGN ,@body)))))
	     body)))))


(defun interpreted-p ()                                                ;;Rjf
  "Returns T if called from code that is being interpreted"
   (let* ((reg-pdl (si:sg-regular-pdl si:current-stack-group)) 
          (current-local-block
               (si:%pointer-difference (si:%STACK-FRAME-POINTER) 
                                       (locf (aref reg-pdl 0)))))
     (eq (aref reg-pdl (- current-local-block 2))
         #'si:*eval)))

(defmacro record-timing ((meters interrupts report-function repeat . args) &body body)  ;;Rjf
  "Execute BODY, then call REPORT-FUNCTION with arguments 
 ARGS followed by REAL-TIME in microseconds and the keyword arguments specified by METER-LIST."
  (LET* ((TIME (GENSYM))
	 (new-time (GENSYM))
	 (newer-time (GENSYM))
	 (time-60 (GENSYM))
	 (value (GENSYM))
	 (timep (OR (AND (MEMBER :time meters) :time) (MEMBER :cpu meters)))
	 meter-vars)
;;    (WHEN timep (SETQ meters (DELETE :time meters)))
    (SETQ meter-vars (LOOP for x in meters collecting (GENSYM)))
    `(,@(IF (OR (MEMBER :CPU METERS :TEST #'EQ)
		(MEMBER :paging METERS :TEST #'EQ))
	    '(letf-globally (((LDB si:%%Time-Page-Faults-Enable si:%disk-switches) 1)))
	  '(PROGN))
       ,@(when repeat                                                                 ;;Rjf
          '((when (interpreted-p)
            (FERROR ":Repeat may only be used when TIMEIT is in compiled code. ~%         ~
               Compile a form like the following: (defun test () (timeit (:repeat ..) ....))"))))
       (let* (,@(UNLESS interrupts `((si:inhibit-scheduling-flag t)))
              (,value (progn                                                          ;;Rjf 
                        (if (fboundp 'si:%flush-extra-pdl) (si:%flush-extra-pdl))
                        (si:page-in-structure #'si:%microsecond-time)
                        (si:page-in-structure 'si:%total-page-fault-time)
                        (si:page-in-structure 'si:%disk-wait-time)
                        (si:page-in-structure 'si:%count-fresh-pages)
                        (si:page-in-structure 'si:extra-pdl-area)
                        (si:page-in-structure #'time::area-size)
			(si:page-in-structure #'time:microsecond-time-difference)
 			(si:page-in-structure #'time::correct-for-us-clock-rollover) 
			(compiler::undefined-value)))
	      ,@(WHEN timep
		  `((,time (compiler::undefined-value))
		    (,new-time (compiler::undefined-value))
		    (,newer-time (compiler::undefined-value))
		    (,time-60 (si:time-in-60ths))))
	      ,@(LOOP for meter-name in meters
		      for meter = (OR (GET meter-name 'meter)
				      (FERROR "~a isn't the name of a meter" meter-name))
		      for var in meter-vars
		      unless (EQ meter-name :time)
		      collect `(,var ,(GETF meter :form)) into init-forms
		      finally (RETURN (NREVERSE init-forms))))
	 ,@(WHEN timep `((setq ,time (si:%microsecond-time))))
	 (SETQ ,value (PROGN ,@body))
	 ,@(WHEN timep
	     `((setq ,new-time (si:%microsecond-time))
	       (setq ,newer-time (si:%microsecond-time))))
	 (,@(IF (NOT timep) '(PROGN)
	      `(LET ((TIME (- (microsecond-time-difference ,new-time ,time)
			      (microsecond-time-difference ,newer-time ,new-time))))                 
		    ;; Correct for the number of times the microsecond clock has rolled over (every 72 minutes)
		    (SETQ time (correct-for-us-clock-rollover time ,time-60))
                    (IF (< time 0)(SETQ time 0))))                                  ;;Rjf
	  (,report-function
	   ,@(LOOP for name in meters
		   for meter = (GET name 'meter)
		   for function = (GETF meter :form)
		   for difference = (GETF meter :difference)
		   for var in meter-vars
		   collect `',name
		   collect (IF (EQ name :time) 'TIME (MACROEXPAND `(,(OR difference '-) ,function ,var))))
	   ,@args
	   :return-value ,value
	   ))))))

;1; We could add options to TIMEIT-REPORT like :average :standard-deviation :min :max*

(DEFUN timeit-report (timings &key label units plot (STREAM *terminal-io*))
  "2Report timings collected with the TIMEIT :COLLECT option.
 When LABEL is specified, only those timings whose label is string-equal
 to LABEL are reported.  When PLOT is the name of one of the meters collected
 when TIMEIT was run, (e.g. :TIME :CPU :DISK :CONS) this value is displayed graphically.
UNITS specifies a default time unit to use when TIMINGS doesn't specify one.*"
  (COND (plot (IF (NOT label)
		  (timeit-plot timings plot stream)
		(timeit-plot (LOOP for timing in timings
				   when (STRING-EQUAL (GETF timing :label) label)
				   collect timing)
			     plot)))
	(t (LOOP with firstp = t
		 for timing in timings
		 when (OR (NULL label) (STRING-EQUAL (GETF timing :label) label))
		 do (APPLY 'timeit-print :header firstp :stream stream :units units timing)
		 (SETQ firstp nil)))))

(DEFUN timeit-print (&rest options)
  "2Function called to report timeit timings.*"
  (LET ((inhibit-scheduling-flag nil)
	(units nil)
	(STREAM *trace-output*)
	separator
	(header :side)
	label
	repeat
	collect
	(correct t)
	keyword-values return-value return-type)
    ;1; Pick off report keywords*
    (LOOP for (keyword value) on options by 'CDDR
	  do (CASE keyword
		   (:units (SETQ units value))
		   (:STREAM (SETQ stream value))
		   (:separator (SETQ separator value))
		   (:repeat (SETQ repeat value))
		   (:return-value (SETQ return-value value))
		   (:values (SETQ return-type value))
		   (:header (SETQ header value))
		   (:label (SETQ label value))
		   (:collect (SETQ collect value))
		   (:correct (SETQ correct value))
		   (otherwise (PUSH-END keyword keyword-values)
			      (PUSH-END value keyword-values))))
    (IF collect
	(PROGN (UNLESS (BOUNDP collect) (SET collect nil))
	       (SETQ options (COPY-LIST options))
	       (REMF options :collect)
	       (SET collect (NCONC (SYMBOL-VALUE collect) (LIST options))))
      (WHEN stream
	;1; Get default separator*
	(UNLESS separator
	  (SETQ separator (IF (EQ header :side) ", " "  ")))
	;1; Ensure the label comes first (do we need another option for putting the label last?)*
	(WHEN label (SETQ keyword-values (LIST* :label label keyword-values)))
	;1; Print the header line*
	(WHEN (AND header (NOT (EQ header :side)))
	  (FRESH-LINE stream)
	  (LOOP for (keyword value) on keyword-values by 'CDDR
		for meter = (GET keyword 'meter)
		do (UNLESS meter (FERROR "~a isn't a timeit option" keyword))
		(FORMAT stream (GETF meter :header "~10@t"))
		(PRINC separator stream)))
	(FRESH-LINE stream))
      ;1; Correct for looping overhead*
      (WHEN (AND repeat correct)
	(LET ((correction (timeit-loop-correction repeat)))
	  (DOLIST (parm '(:time :cpu))
	    (WHEN (GETF keyword-values parm)
	      (SETF (GETF keyword-values parm)
		    (- (GETF keyword-values parm) correction))))))
      ;1; Print the values*
      (LOOP for pair on keyword-values by 'CDDR
	    for (keyword value) = pair
	    for meter = (GET keyword 'meter)
	    for report = (GETF meter :report)
	    with print-value and temp
	    ;1; Get average for repeat count*
	    do (WHEN (AND repeat correct (NUMBERP value) (NOT (ZEROP repeat)))
		 (SETQ value (/ value (FLOAT repeat))))
	    (SETQ print-value value)
	    ;1; Get print string and value corrected for units*
	    (WHEN (AND report correct)
	      (MULTIPLE-VALUE-SETQ (print-value temp)
		(FUNCALL report value units))
	      (WHEN (AND units temp) (SETQ value temp)))
	    ;1; Set return value to repeat and unit adjusted value*
	    (WHEN correct (SETF (GETF options keyword) value))
	    (WHEN stream
	      ;1; Print value*
	      (COND ((EQ header :side)
		     (WHEN (NOT (EQ keyword :label))
		       (PRINC (STRING-TRIM #\space (GETF meter :header "")) stream)
		       (PRINC ": " stream))
		     (SETQ print-value (FORMAT nil (GETF meter :format " ~s") print-value))
		     (PRINC (STRING-TRIM #\space print-value) stream))
		    (t (FORMAT stream (GETF meter :format " ~s") print-value)))
	      (WHEN (CDDR pair) (PRINC separator stream)))))
    ;1; Return values*
    (COND ((NULL return-type) return-value)
	  ((EQ return-type :all) (COPY-LIST options))
	  ((ATOM return-type) (GETF options return-type))
	  (t (VALUES-LIST
	       (LOOP for type in return-type
		     collect (IF (EQ type :value)
				 return-value
			       (GETF options type))))))))

;1; Cache loop-corrections for speed and consistency*
(DEFVAR timeit-loop-corrections nil) ;1; Alist of loop correction counts*

;1; Return the amount of time it takes TIMEIT to repeat*
(DEFUN timeit-loop-correction (repeat &aux (average-over 30))
  (OR (CDR (ASSOC REPEAT TIMEIT-LOOP-CORRECTIONS :TEST #'EQ) )
      (WITHOUT-INTERRUPTS
	;1; Average over several runs*
	(LOOP repeat (1+ average-over)
	      for first first t then nil
	      for time = (timeit (:values :time :repeat repeat :correct nil) nil)
	      unless first sum time into sum ;1; Skip the first number*
	      finally (SETQ time (/ sum (FLOAT average-over)))
	              (PUSH (CONS repeat time) timeit-loop-corrections)
		      (RETURN time)))))

(DEFUN identity-rest (&rest args)
  "2Like IDENTITY, but returns a list of ALL arguments.*"
  (COPY-LIST args))  

(DEFUN pretty-time (TIME &OPTIONAL UNITS)
  "2Print TIME on STREAM using UNITS which is one of :microseconds, :milliseconds,
:seconds, :minutes, or :hours.*"
  (LET* ((MICRO-MILLI 1000.0)		   ;1 micro to milli conversion*
	 (MICRO-SEC 1000000.0)		   ;1 micro to second conversion*
	 (MICRO-MIN (* MICRO-SEC 60.))	   ;1 micro to minute conversion*
	 (MICRO-HOUR (* MICRO-MIN 60.))	   ;1 micro to hour conversion*
	 (result time))
    (UNLESS UNITS
      (SETQ UNITS
	    (COND
	      ((MINUSP time) :minus)
	      ((< time 0.001) :ZERO)
	      ((< time 1) :NANOSECONDS)
	      ((< TIME MICRO-MILLI) :MICROSECONDS)
	      ((< TIME MICRO-SEC) :MILLISECONDS)
	      ((> time micro-hour) :hours)
	      ((> time micro-min) :minutes)
	      (T :SECONDS))))
    (VALUES
      (CASE UNITS
	    (:minus " ????  ")
	    (:ZERO " 0.0   ")
	    (:NANOSECONDS (FORMAT NIL "~4f ns" (SETQ result (* TIME 1000.0))))
	    ((:MICROSECONDS :us) (FORMAT NIL "~4f us" TIME))
	    ((:MILLISECONDS :ms) (FORMAT NIL "~4F ms" (SETQ result (/ TIME MICRO-MILLI))))
	    ((:SECONDS :sec :s) (FORMAT NIL "~5F s" (SETQ result (/ TIME MICRO-SEC))))
	    (:MINUTES (FORMAT NIL "~3f min" (SETQ result (/ TIME MICRO-MIN))))
	    (:HOURS (FORMAT NIL "~3f hours" (SETQ result (/ TIME MICRO-HOUR))))
	    (OTHERWISE (FSIGNAL "unknown time unit: ~s" UNITS)))
      result)))

(DEFUN timeit-plot (timings type &optional (STREAM *terminal-io*))
  "2Plot the TYPE TIMINGS collected by TIMEIT on STREAM.*"
  (FLET ((interpolate (value size max min)
	   (IF (= MAX MIN) 0
	     (ROUND (* (- value min) (/ size (FLOAT (- max min))))))))
    (let (min max timings-list)
      (IF (NOT (NUMBERP (GETF (FIRST timings) type)))
	  (FORMAT stream "~& ~s isn't a meter in the timings" type)
	;1; Get MIN/MAX*
	(LOOP for item in timings
	      for value = (GETF item type)
	      for repeat = (GETF item :repeat)
	      ;1; Correct for repeat count*
	      do (WHEN (AND repeat (NUMBERP value) (NOT (ZEROP repeat)))
		   (SETQ value (/ (- value (timeit-loop-correction repeat)) (FLOAT repeat))))
	      maximize value into maxv
	      minimize value into minv
	      collect value into tlist
	      finally (SETQ min minv max maxv timings-list tlist))
	;1; Print left axis*
	(FORMAT stream "~%~12a~2%~12a~2%~12a" (pretty-time max) type (pretty-time min))
	;1; Plot graph and bottom axis*
	(MULTIPLE-VALUE-BIND (x-base y-base) (SEND stream :read-cursorpos)
	  (INCF y-base (FLOOR (SEND stream :line-height) 2))
	  (LOOP with plot-width = (* 4 (SEND stream :line-height))
		for value in timings-list
		for p-x first nil then x
		for x upfrom x-base by 4
		for p-y first nil then y
		for i upfrom 1
		with y do
		;1; Draw the graph*
		(SETQ y (- y-base (interpolate value plot-width max min)))
		(WHEN p-y 
		  (SEND stream :draw-line p-x p-y x y))
		;1; Draw the bottom axis*
		(SEND stream :draw-point x (+ y-base 2))
		(WHEN (ZEROP (MOD i 10))
		  (SEND stream :draw-point x (+ y-base 3)))))))))