;;;-*-Lisp-*-

;;; Copyright 1994 Point and Click Solutions, Inc.

#+lucid (in-package :user)
#-lucid (in-package :common-lisp-user)

(defparameter +optimal-metering-duration+ 0.1) ; in seconds
(defparameter +n-samples+ 50)
(defparameter +max-iterations+ 100000)
(defparameter +optimize-list+ '(:default :speed))
(defparameter +loop-var-types+ '(:unspecified :integer :single-float))


(defstruct (meter-entry (:type list))
  symbol
  string
  n-iterations
  result
  loop-var-type
  n-samples)


(defvar *fns-to-test* nil)


;;; Useful Utilities

(defmacro dump (&rest args)
  (loop with fstr = "~&"
        for arg in args
        do (setq fstr (format nil "~A~A=~~S " fstr arg))
        finally (return `(format t ,fstr ,@args))))

(defun string-truncate (string length)
  (if (stringp string)
      (if (> (length string) length)
          (subseq string 0 length)
        string)
    (error "Not String")))

(defun print-universal-time (stream universal-time)
  (multiple-value-bind (second minute hour date month year)
      (decode-universal-time universal-time)
      (format stream "~D:~D:~D ~D/~D/~D"
              hour minute second month date year)))

(defun print-time-difference (stream seconds)
  (multiple-value-bind (dd hh mm ss) (seconds-to-dd-hh-mm-ss seconds)
    (let ((day-str (if (> dd 0) (format nil " ~D day~:P" dd) ""))
          (hrs-str (if (> hh 0) (format nil " ~D hr~:P" hh) ""))
          (min-str (if (> mm 0) (format nil " ~D min~:P" mm) ""))
          (sec-str (if (or (> ss 0)
                           (and (= dd 0)
                                (= hh 0)
                                (= mm 0)))
                       (format nil " ~D sec~:P" ss) "")))
      (format stream "~A~A~A~A" day-str hrs-str min-str sec-str))))

(defun seconds-to-dd-hh-mm-ss (seconds)
  (multiple-value-bind (minutes secs) (floor seconds 60)
    (multiple-value-bind (hours mins) (floor minutes 60)
      (multiple-value-bind (days hrs) (floor hours 24)
        (values days hrs mins secs)))))

;;; Header Info

(defun print-system-info (stream &optional data-stream)
  (let ((utime (get-universal-time)))
    (format stream "Evaluation Performed at ")
    (print-universal-time stream utime)
    (format stream "~%Lisp Implementation Type: ~A"
	    (lisp-implementation-type))
    (format stream "~%Lisp Implementation Version: ~A"
	    (lisp-implementation-version))
    (format stream "~%Machine Type: ~A" (machine-type))
    (format stream "~%Machine Instance: ~A" (machine-instance))
    (format stream "~%Software Type: ~A" (software-type))
    ;; And now the data stream
    (when data-stream
      (format data-stream "~&(~S ~S ~S ~S ~S ~S)"
              utime (lisp-implementation-type) (lisp-implementation-version)
              (machine-type) (machine-instance) (software-type)))))

;;; The results of tested forms get passed to thses so that the compiler
;;; optimizer thinks the values are being used. 

(defun generic-identity (val) (declare (ignore val)) nil)
(defun int-identity (val)
  (declare (type (integer 0 #.most-positive-fixnum) val) (ignore val)) nil)
(defun float-identity (val)
  (declare (type single-float val) (ignore val)) nil)

#+lispworks
(defmacro record-consing (form)
  `(let ((start-alloc (total-allocation)))
     ,form
     (- (total-allocation) start-alloc)))

#+lucid
(defmacro record-consing (form)
  `(multiple-value-bind (rt tt ut st  pf do no db
			 gcf ephemeral-bytes  ngc)
       (time1 ,form)
     rt tt ut st pf do no db gcf ngc
     (values ephemeral-bytes)))

;;; Note Time returns cons-cells(8b), symbols(24b) and other bytes
#+allegro
(defmacro record-consing (form)
  `(let ((start-alloc (sys::gsgc-totalloc-bytes t)))
     ,form
     (- (sys::gsgc-totalloc-bytes t) start-alloc)))
     
(defmacro time-multiple-iterations-1 (loop-var loop-var-type n form)
  (unless loop-var (setq loop-var '.lv.))
  `(let (start-time end-time alloc alloc-adjust)
     ;; (ephemeral-gc)
     (setq alloc-adjust #+allegro 128 #-allegro 0)
     (setq alloc
       (record-consing
	(progn
	  (setq start-time (get-internal-real-time))
	  #-lucid
	  ,(ecase loop-var-type
	     (:integer
	      `(loop for ,loop-var of-type (integer 0 #.most-positive-fixnum)
		   from 1 to ,n
		   do (int-identity ,loop-var)
		      (int-identity ,form)))
	     (:single-float
	      `(loop for ,loop-var of-type single-float
		   from (the single-float 1.0)
		   to (the single-float (single-float n))
		   by (the single-float 1.0)
		   do (float-identity ,loop-var)
		      (float-identity ,form)))
	     (:unspecified
	      `(loop for ,loop-var from 1 to ,n
		   do (generic-identity ,loop-var)
		      (generic-identity ,form))))
	  #+lucid
	  (loop for ,loop-var from 1 to ,n
	      do (generic-identity ,loop-var)
		 (generic-identity ,form))
	  (setq end-time (get-internal-real-time)))))
     (when (>= end-time start-time)
       (values (- end-time start-time) (- alloc alloc-adjust)))))

;;; If the clock has wrapped we will return nil from
;;; time-multiple-iterations-1 - this will call it again
(defmacro time-multiple-iterations (loop-var loop-var-type n body)
  `(multiple-value-bind (time alloc)
      (time-multiple-iterations-1 ,loop-var ,loop-var-type ,n ,body)
    (unless time
      (multiple-value-setq (time alloc)
	  (time-multiple-iterations-1 ,loop-var ,loop-var-type ,n ,body)))
    (values time alloc)))
       
;;; Optimal duration is the preferred amount of time in seconds that
;;;  we would like to time this for to lose some of the variations

(defun determine-optimal-iteration (test-fn optimal-duration
				    &key (verbose? nil))
  (let ((ituo-duration (* optimal-duration internal-time-units-per-second))
        (count 10))
    (loop for duration = (time-test-fn test-fn
                                       :n-iterations count
				       :n-samples 8)
	while (< count 10000000) ; arbitary upper limit
	do
          (when (>= duration ituo-duration) (return))
          (when (>= count +max-iterations+) (return))
          (setq count (* count 10)))
    (when verbose?
      (format t "~&Optimal count for ~A is ~D" test-fn count))
    count))

(defun time-test-fn (test-fn &key (verbose? nil) (n-iterations nil)
                             (n-samples +n-samples+))
  (let* ((optimal-iteration (or n-iterations
                                (determine-optimal-iteration
                                 test-fn +optimal-metering-duration+)))
         (times nil)
         (conses nil))
    (loop for i from 0 below n-samples
          do (multiple-value-bind (raw-times raw-conses)
                 (funcall test-fn optimal-iteration)
	       ;; Standardize on microseconds
	       (push (/ (/ (* 1000000 raw-times)
                           (float internal-time-units-per-second))
			(float optimal-iteration))
                     times)
               (push (/ raw-conses (float optimal-iteration)) conses)))
    (multiple-value-bind (time-reasonable-av time-sd)
	(determine-reasonable-average times "~6,4Fus" :verbose? verbose?)
      (multiple-value-bind (cons-reasonable-av cons-sd)
	  (determine-reasonable-average conses "~6,2Fbytes" :verbose? verbose?)
        (values time-reasonable-av cons-reasonable-av
                time-sd cons-sd
	        optimal-iteration)))))

(defun determine-reasonable-average (data format-str &key (verbose? t))
  ;; Typically the values we want to ignore are the slow ones
  ;; so sort and ignore the top 25%
  (let* ((n-values-to-ignore (floor (length data) 4))
         (fastest-data (butlast (sort (copy-list data) #'<)
				n-values-to-ignore))
         (n-fastest-data (length fastest-data))
         (average (/ (loop for val in fastest-data sum val)
		     (float n-fastest-data)))
         (sum-sqs (loop for val in fastest-data
                        sum (* (- val average) (- val average))))
         (stddev (sqrt (/ sum-sqs (float n-fastest-data))))
         (filtered-data (loop for val in fastest-data
                              when (< (abs (- val average)) stddev)
                              collect val))
         (n-filtered-data (length filtered-data))
         (reasonable-average (if (> n-filtered-data 2)
                                 (/ (loop for val in filtered-data sum val)
				    (float n-filtered-data))
                               average)))
    (when verbose?
      (format t "~&av = ~A sd = ~6,4F reasonable av = ~A"
	      (format nil format-str average)
              stddev
              (format nil format-str reasonable-average)))
    (values reasonable-average stddev)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun get-meter-fn-name (symbol &key (optimize :default)
				      (check-fn? nil)
				      (loop-var-type :unspecified))
  (let ((lvt (ecase loop-var-type
	       (:unspecified "LVU") (:integer "LVI") (:single-float "LVF"))))
    (if check-fn?
        (intern (format nil "CHECK-~A-~A-~A" symbol optimize lvt))
      (intern (format nil "~A-~A-~A" symbol optimize lvt)))))

(defun get-optimize-form (optimize proclaim?)
  (if proclaim?
      (ecase optimize
	(:speed `(proclaim '(optimize #-lucid (debug 0)
				    (safety 0)
				    #-lucid (fixnum-safety 0)
				    (speed 3)
				    (compilation-speed 0))))
	(:safety `(proclaim '(optimize #-lucid (debug 3)
				     (safety 3)
				     #-lucid (fixnum-safety 3)
				     (speed 0)
				     (compilation-speed 0))))
	(:compilation-speed `(proclaim '(optimize (compilation-speed 3))))
	(:space `(proclaim '(optimize (space 3))))
	(:default nil))
    (ecase optimize
      (:speed `(declare (optimize #-lucid (debug 0)
				  (safety 0)
				  #-lucid (fixnum-safety 0)
				  (speed 3)
				  (compilation-speed 0))))
      (:safety `(declare (optimize #-lucid (debug 3)
				   (safety 3)
				   #-lucid (fixnum-safety 3)
				   (speed 0)
				   (compilation-speed 0))))
      (:compilation-speed `(declare (optimize (compilation-speed 3))))
      (:space `(declare (optimize (space 3))))
      (:default nil))))

(defun meter-product (product-name
			  &key (pathname "/home/davo/meter/data/")
			       (optimize-list +optimize-list+)
			       (n-samples +n-samples+))
  (let ((filename (format nil "~A~A-results.text" pathname product-name))
        (data-filename (format nil "~A~A-results.data" pathname product-name))
        (start-utime (get-universal-time))
        (count 0))
    (format t "~&Metering Started: ")
    (print-universal-time t start-utime)
    (with-open-file (stream filename :direction :output
		     :if-exists :new-version)
      (with-open-file (data-stream data-filename :direction :output
		       :if-exists :new-version)
        (print-system-info stream data-stream)
        (format t "~&Text saved to: ~A" filename)
        (format t "~&Data saved to: ~A" data-filename)
        (format t "~&~A tests to perform"
		(* (length optimize-list) (length *fns-to-test*)))
        (loop for optimize in optimize-list
	    do (loop for (symbol string) in *fns-to-test*
		   do (incf count)
		      (format t "~&~D." count)
		      (meter-test symbol :optimize optimize
				  :string string :stream stream
				  :data-stream data-stream
				  :monitor-stream t
				  :n-samples n-samples)))
        (format data-stream "~&")
        (format t "~&Completed in ")
        (print-time-difference t (- (get-universal-time) start-utime))))))


(defun meter-test (symbol &key (string nil) (optimize :default) (verbose? nil)
			       (stream t) (data-stream nil)
			       (monitor-stream nil)
			       (n-samples +n-samples+))
  (let ((meter-entry (find symbol *fns-to-test* :key #'meter-entry-symbol)))
    (if (null meter-entry)
	(format t "~%Error: ~A No such metering test defined" symbol)
      (let* ((expected-result (meter-entry-result meter-entry))
	     (loop-var-type (meter-entry-loop-var-type meter-entry))
	     (n-iterations (meter-entry-n-iterations meter-entry))
	     (test-specified-n-samples
	      (meter-entry-n-samples meter-entry))
	     (standard-fn
	      (get-meter-fn-name 'meter-standard :optimize optimize))
	     (test-fn
	      (get-meter-fn-name symbol :optimize optimize
				 :loop-var-type loop-var-type))
	     (check-fn
	      (get-meter-fn-name symbol :optimize optimize
				 :loop-var-type loop-var-type :check-fn? t)))
	(when test-specified-n-samples
	  (format t "~&For test ~A, using test specified sample count of ~A"
		  symbol test-specified-n-samples)
	  (setq n-samples test-specified-n-samples))
	(multiple-value-bind (result-match? actual-result)
	    (if (eq expected-result :do-not-check-result)
		(values t nil)
	      (funcall check-fn expected-result))
	  (multiple-value-bind (test-time test-alloc
				time-sd alloc-sd iterations)
	      (time-test-fn test-fn :n-iterations n-iterations
			    :verbose? verbose?
			    :n-samples n-samples)
	    (multiple-value-bind (standard-time standard-alloc)
		(time-test-fn standard-fn :n-iterations iterations
			      :verbose? verbose?)
	      (let ((time (- test-time standard-time))
		    (alloc (- test-alloc standard-alloc))
		    (fail-str (if result-match?
				  " "
				(format nil " <Fail exp=~A act=~A> "
					expected-result actual-result))))
		(when monitor-stream
		  (format monitor-stream " ~A (~A)~A~6,4Fus ~6,4Fbytes  (n=~D)"
			  symbol optimize fail-str
			  time alloc iterations))
		(format stream "~&~A (~A)~A~6,4Fus ~6,4Fbytes  (n=~D tsd=~6,4F asd=~6,4F)"
			symbol optimize fail-str
			time alloc iterations time-sd alloc-sd)
		(when string (format stream "   ~A" string))
		(when data-stream
		  (format data-stream "~&(~A ~A ~A ~A)" symbol optimize
			  (when result-match? time)
			  (when result-match? alloc)))))))))))

  
(defmacro def-standard-test (&key (optimize-list +optimize-list+)
				  (proclaim? nil))
  (let ((defuns (list :standards)))
    (loop for loop-var-type in +loop-var-types+
          do
          (loop for optimize in optimize-list
                do
                (push `(defun ,(get-meter-fn-name 'meter-standard
                                                  :optimize optimize
                                                  :loop-var-type loop-var-type)
                        (n &key (result nil))
		        ,(get-optimize-form optimize proclaim?)
		        result
                        (time-multiple-iterations .i. ,loop-var-type n .i.))
                      defuns)))
    (push 'progn defuns)
    defuns))


(defun update-common-lisp-fns-to-test (fn-symbol short-string n-iterations result loop-var-type n-samples)
  (setq *fns-to-test*
	(delete fn-symbol *fns-to-test* :key #'meter-entry-symbol))
  (push (make-meter-entry :symbol fn-symbol
                           :string short-string
                           :n-iterations n-iterations
                           :result result
                           :loop-var-type loop-var-type
			   :n-samples n-samples)
        *fns-to-test*)
  (setq *fns-to-test*
	(sort *fns-to-test*
	      #'(lambda (a b)
		  (let ((a-str (string (first a)))
			(b-str (string (first b))))
		    (string-lessp a-str b-str)))))
  ;; Return nil so it doesn't eval *fns-to-test*
  nil)

(defmacro def-meter-test (fn-symbol short-string
			  &key vars form init-form
			       (result :do-not-check-result)
			       n-iterations
			       (loop-var nil)
			       (loop-var-type :unspecified)
			       (result-loop-var 1000)
			       (optimize-list +optimize-list+)
			       (proclaim? nil)
			       ;; Must be greater than 4 (50 is good)
			       (n-samples nil))
  (let ((defuns nil)
        (let-form (if vars (list 'let* vars) (list 'progn)))
        (result-let-form (list (list 'my-result form))))
    (when loop-var (push (list  loop-var result-loop-var) result-let-form))
    (loop for optimize in optimize-list
          for check-fn-name = (get-meter-fn-name fn-symbol
                                                 :optimize optimize :check-fn? t
					         :loop-var-type loop-var-type)
          for test-fn-name = (get-meter-fn-name fn-symbol
                                                :optimize optimize
					        :loop-var-type loop-var-type)
          do
          (unless (eq result :do-not-check-result)
            (push `(defun ,check-fn-name (required-result)
		    ,(get-optimize-form optimize proclaim?)
		    ,(append let-form
			     (list init-form)
			     (list (list 'let* result-let-form
			                 '(values
                                           (if (and (numberp my-result)
                                                    (numberp required-result))
				               (= my-result required-result)
				             (equal my-result required-result))
					   my-result)))))
		  defuns))
          (push `(defun ,test-fn-name (n)
		  ,(get-optimize-form optimize proclaim?)
		  ,(append let-form
			   (list init-form)
			   `((time-multiple-iterations
			      ,loop-var ,loop-var-type n ,form))))
		defuns))
    (push `(update-common-lisp-fns-to-test
            ',fn-symbol ,short-string
	    ,n-iterations ,result ,loop-var-type ,n-samples)
          defuns)
    (push 'progn defuns)
    defuns))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Report Generation - CLIM free for portability
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun report-all-results (&key (stream *standard-output*)
				(sort-by :test)
				(product-to-sort-on nil)
				(excel? nil))
  (format stream "~%~%CL")
  (report-results :stream stream :component-name "cl" :sort-by sort-by
		  :product-to-sort-on product-to-sort-on :excel? excel?)
  (format stream "~%~%CL Numerics")
  (report-results :stream stream :component-name "cl-numerics" :sort-by sort-by
		  :product-to-sort-on product-to-sort-on  :excel? excel?)
  (format stream "~%~%CLOS")
  (report-results :stream stream :component-name "clos" :sort-by sort-by
		  :product-to-sort-on product-to-sort-on :excel? excel?)
  (format stream "~%~%Gabriels")
  (report-results :stream stream :component-name "gabriels" :sort-by sort-by
		  :product-to-sort-on product-to-sort-on  :excel? excel?)
  (format stream "~%~%CLIM")
  (report-results :stream stream :component-name "clim"
		  :optimize-list '(:default) :excel? excel?
		   :sort-by sort-by :product-to-sort-on product-to-sort-on)
  (format stream "~%~%Compiler")
  (report-results :stream stream :component-name "compiler" :sort-by sort-by
		  :product-to-sort-on product-to-sort-on :excel? excel?)
  (format stream "~%~%GC")
  (report-results :stream stream :component-name "gc"
		  :optimize-list '(:default) :excel? excel?
		   :sort-by sort-by :product-to-sort-on product-to-sort-on))
  
;;; Acceptable sort-by values are:  :test, :product
(defun report-results (&key
		       (stream *standard-output*)
		       (product-names '("allegro" "lispworks" "lucid"))
		       (component-name nil)
                       (pathname #+MCL "Macintosh HD:Point & Click:Meter:"
                                 #-MCL "/usr2/davo/meter/data/")
                       (sort-by :test)
                       (product-to-sort-on nil)
                       (time-or-conses :time)
                       (optimize-list +optimize-list+)
                       (excel? nil)
		       (time-units :microseconds))
  (let ((results-table (make-hash-table :test #'equal))
        (test-table (make-hash-table)))
    (when component-name
      (setq product-names
	(loop for product-name in product-names
	  collect (format nil "~A-~A" product-name component-name)))
      (when product-to-sort-on
	(setq product-to-sort-on
	  (format nil "~A-~A" product-to-sort-on component-name))))
    ;;; Read data
    (loop for name in product-names
          for data-filename = (format nil "~A~A-results.data" pathname name)
          do (with-open-file (data-stream data-filename :direction :input)
               ;(format t "~&Reading ~A" data-filename)
               (print-header-info stream name data-stream)
	       (read-report-data data-stream name results-table test-table)))
    (let ((tests nil))
      (maphash #'(lambda (key entry) entry (push key tests)) test-table)
      (loop for goal in optimize-list
            for igoal = (intern (string goal))
            do
	    (format stream "~%~%Goal: ~A" goal)
	    (ecase sort-by
              (:test
               (format stream "  (sorted by test name)")
               (setq tests (sort tests #'string-lessp)))
              (:product
               (unless product-to-sort-on
                 (setq product-to-sort-on (first product-names)))
	       (format stream
                       "  (sorted by product performance on product: ~A)"
                       product-to-sort-on)
               (setq tests (sort-tests-by-product-performance
                            tests igoal product-to-sort-on product-names
                            results-table time-or-conses))))
            (if excel?
                (print-excel-report-heading stream product-names)
              (print-report-heading stream product-names))
            (loop for test in tests
		  do (print-report-data stream product-names product-to-sort-on
                                        test igoal results-table
					time-or-conses excel?
					time-units))
            (unless excel?
	      (print-horiz-line stream product-names))))))

(defun print-header-info (stream name data-stream)
  (multiple-value-bind (utime lisp-type lisp-version
			      machine-type machine-instance software-type)
      (read-header-info-line data-stream)
    (format stream "~%~%Product Name: ~A" name)
    (format stream "~&Data Collection Time: ~A"
            (print-universal-time nil utime))
    (format stream "~&Lisp Type: ~A"  lisp-type)
    (format stream "~&Lisp Version: ~A" lisp-version)
    (format stream "~&Machine Type: ~A" machine-type)
    (format stream "~&Machine Instance: ~A" machine-instance)
    (format stream "~&Software Type: ~A" software-type)))

(defun sort-tests-by-product-performance (tests igoal product-name
					  product-names
					  results-table time-or-conses)
  (sort tests
	#'(lambda (a b)
            (let ((delta-a (product-performance-delta
		a igoal product-name product-names
		results-table time-or-conses :min))
                  (delta-b (product-performance-delta
		b igoal product-name product-names
		results-table time-or-conses :min)))
              (cond ((and delta-a delta-b) (< delta-a delta-b))
                    (delta-a t)
                    (delta-b nil))))))

(defun product-performance-delta (test igoal product-name product-names
                                       results-table time-or-conses type)
  (let* ((key (list (intern (string test)) igoal))
	 (entry (gethash key results-table nil))
	 (product-item
	  (find product-name entry :key #'first :test #'string-equal))
	 (product-value (ecase time-or-conses
			  (:time (second product-item))
			  (:conses (third product-item))))
	 (best-delta nil))
    (when product-value
      (loop for product-name in product-names
	    for (name time conses) = (find product-name entry
                                           :key #'first :test #'string-equal)
	    for val = (ecase time-or-conses (:time time) (:conses conses))
	    for delta = (if val (- product-value val) 0)
	    do (ecase type
                 (:max (when (or (null best-delta) (> delta best-delta))
                    (setq best-delta delta)))
                 (:min (when (or (null best-delta) (< delta best-delta))
                         (setq best-delta delta)))
                 (:max-abs (when (or (null best-delta)
				     (> (abs delta) best-delta))
                                     (setq best-delta (abs delta)))))))
    best-delta))
                

(defun read-header-info-line (data-stream)
  (let ((line (read data-stream)))
    (destructuring-bind (utime lisp-type lisp-version machine-type
                               machine-instance software-type)
        line
      (values utime lisp-type lisp-version
              machine-type machine-instance software-type))))

(defun read-report-data (data-stream product-name results-table test-table)
  (loop for line = (read data-stream nil :eof)
        until (eq line :eof)
        do (destructuring-bind (test goal time conses) line
	     (let* ((key (list test goal))
                    (entry (gethash key results-table nil)))
	       (when (and entry (find product-name entry
                                      :key #'first :test #'string-equal))
		 (format t "~&Error: Multiple entries for key -> ~A ~A"
			 key product-name))
               (push (list product-name time conses)
		     (gethash key results-table))
               (setf (gethash test test-table) t)))))

(defun print-report-data (stream product-names product-name
			  test igoal results-table time-or-conses
			  excel? time-units)
  (let* ((key (list (intern test) igoal))
	 (entry (gethash key results-table nil))
	 (unit-str nil)
	 (cons-unit-str nil))
    (when entry
      (if excel?
          (format stream "~&;~A;~A" (first key) (second key))
        (format stream "~&| ~A ~27T| ~A~37T|"
                (string-truncate (format nil "~A" (first key)) 23)
                (string-truncate (format nil "~A" (second key)) 7)))
      product-name time-or-conses
      ;; Debugging Only
      #+ignore (when product-name
                 (format stream " ~7,2F | "
	                 (product-performance-delta
	                  test igoal product-name product-names
	                  results-table time-or-conses :min)))
      (loop for product-name in product-names
	  for (name time conses) = (find product-name entry
					 :key #'first :test #'string-equal)
	  do (when (and (numberp time) (< time 0))
	       (setq time 0))
	     (when (and (numberp conses) (< conses 0))
	       (setq conses 0))
	     (when (numberp time)
	       (ecase time-units
		 (:microseconds
		  (setq unit-str "us"))
		 (:milliseconds
		  (setq time (/ time 1000.0))
		  (setq unit-str "ms"))
		 (:seconds (setq time (/ time 1000000.0))
			   (setq unit-str "s"))))
	     (when (and (not excel?) (numberp conses))
	       (cond ((> conses 1000000)
		      (setq conses (floor conses 1000000)
			    cons-unit-str "Mb"))
		     ((> conses 1000)
		      (setq conses (floor conses 1000)
			    cons-unit-str "Kb"))
		     (t (setq cons-unit-str "b"))))
	     (if excel?
		 (format stream ";~A;~A"
			 (if time (format nil "~7,2F" time) "--")
			 (if conses (format nil "~D" (round conses)) "--"))
	       (format stream " ~9A ~7A |"
		       (if time
			   (let ((str (format nil "~7,2F~A" time unit-str)))
			     (if (<= (length str) 9)
				 str
			       (format nil "~7F~A" time unit-str)))
			 "   ---   ")
		       (if conses
			   (format nil "(~D~A)" (round conses) cons-unit-str)
			 "(--)")))
	     ))))

(defun print-report-heading (stream product-names)
  (print-horiz-line stream product-names)
  (format stream "~&| Test ~27T| Goal ~37T|")
  (loop for name in product-names
	do (format stream " ~17A |" (string-truncate name 17)))
  (print-horiz-line stream product-names))

(defun print-excel-report-heading (stream product-names)
  (format stream "~&;Test;Goal")
  (loop for name in product-names
	do (format stream ";~A" name)))

(defun print-horiz-line (stream product-names)
  (format stream "~&+--------------------------+---------+")
  (loop repeat (length product-names)
      do (format stream "-------------------+")))