benchmark: Add database and report

.gitignore

@@ -15,4 +15,7 @@
 *.sx32fsl
 *.wx64fsl
 *.wx32fsl
-dependencies/
+/dependencies/
+/benchmark/
+*~
+.#*

code/benchmark/float-integer.lisp

@@ -14,13 +14,12 @@
  :initargs (quaviver/schubfach:client)
  :types (single-float double-float long-float))
  #+(or abcl ccl clasp cmucl ecl sbcl)
- (:label ,(format nil
- "Native (~a)"
- (lisp-implementation-type))
+ (:label "Native"
  :initargs (quaviver/native:benchmark-client)
  :types (single-float double-float long-float))))
 
-(defun float-integer (&optional (base 10))
+(defun float-integer (&key (base 10)
+ (name (uiop:implementation-identifier)))
  (labels ((bench (clients limit key)
  (mapcar (lambda (properties
  &aux (client (apply #'make-instance
@@ -68,6 +67,7 @@
  (plot (format nil "float-integer ~(~a~)" type)
  results type)
  (terpri))
+ (write-results name `(quaviver:float-integer ,base) results)
  (loop with mins = (loop for test in *tests*
  for type = (getf test :type)
  collect type

code/benchmark/packages.lisp

@@ -2,4 +2,5 @@
 
 (defpackage #:quaviver/benchmark
  (:use #:common-lisp)
- (:export #:float-integer))
+ (:export #:float-integer
+ #:report))

code/benchmark/report.lisp

@@ -0,0 +1,118 @@
+(in-package #:quaviver/benchmark)
+
+(defvar *results* nil)
+
+(defun report/test (name
+ &aux (implementation-width (loop for (implementation . result) in *results*
+ when (assoc name result :test #'equalp)
+ maximize (length implementation)))
+ (algo-width (loop for (implementation . result) in *results*
+ for (nil . v) = (assoc name result :test #'equalp)
+ when v
+ maximize (loop for algo in v
+ maximize (length (getf algo :label)))))
+ (types (remove-if-not (lambda (type)
+ (block wibble
+ (loop for (nil . result) in *results*
+ for (nil . v) = (assoc name result :test #'equalp)
+ do (loop for algo in v
+ when (getf algo type)
+ do (return-from wibble t)))))
+ '(short-float single-float double-float long-float))))
+ (write-line
+ (cl-spark:vspark
+ (loop with gap = nil
+ for (implementation . result) in *results*
+ for (nil . v) = (assoc name result :test #'equalp)
+ nconc (loop for type in types
+ for max = (loop for algo in v
+ for val = (getf algo type)
+ when val
+ maximize val)
+ nconc (loop with first = t
+ for algo in v
+ for val = (getf algo type)
+ when (and val first gap)
+ collect 0
+ when val
+ collect (/ val max)
+ and do (setf gap t
+ first nil))))
+ :title "Relative Times within Implementation and Type"
+ :min 0
+ :size 132
+ :labels (loop with gap = nil
+ for (implementation . result) in *results*
+ for (nil . v) = (assoc name result :test #'equalp)
+ nconc (loop for type in types
+ nconc (loop with first = t
+ for algo in v
+ for val = (getf algo type)
+ when (and val first gap)
+ collect ""
+ when val
+ do (setf gap t
+ first nil)
+ and collect (format nil "~va | ~va | ~(~12a~)"
+ implementation-width
+ implementation
+ algo-width
+ (getf algo :label)
+ type))))))
+ (format t "~%Absolute and Relative Times~%")
+ (let ((table (ascii-table:make-table
+ (list* (format nil "~va | ~va"
+ implementation-width "Implementation"
+ algo-width "Client")
+ (loop for type in types
+ collect (ecase type
+ (short-float " abs short")
+ (single-float "abs single")
+ (double-float "abs double")
+ (long-float " abs long"))
+ collect (ecase type
+ (short-float " rel short")
+ (single-float "rel single")
+ (double-float "rel double")
+ (long-float " rel long")))))))
+ (loop for (implementation . result) in *results*
+ for (nil . v) = (assoc name result :test #'equalp)
+ for max = (loop for type in types
+ collect type
+ collect (loop for algo in v
+ for val = (getf algo type)
+ when val
+ maximize val))
+ do (loop for algo in v
+ do (ascii-table:add-row
+ table
+ (list* (format nil "~va | ~va"
+ implementation-width
+ implementation
+ algo-width
+ (getf algo :label))
+ (loop for type in types
+ for val = (getf algo type)
+ when val
+ collect (format nil "~10,5g"
+ (coerce val 'double-float))
+ and collect (format nil "~10,8f"
+ (/ (coerce val 'double-float)
+ (getf max type)))
+ else
+ collect ""
+ and collect "")))))
+ (ascii-table:display table)))
+
+
+(defun report ()
+ (loop with *results* = (loop for path in (directory (merge-pathnames "*.sexp" *database-path*))
+ collect (cons (pathname-name path)
+ (with-open-file (stream path)
+ (with-standard-io-syntax
+ (read stream)))))
+ for test in (remove-duplicates
+ (loop for (nil . result) in *results*
+ nconc (mapcar #'car result))
+ :test #'equalp)
+ do (report/test test)))

code/benchmark/results.lisp

@@ -0,0 +1,22 @@
+(in-package #:quaviver/benchmark)
+
+(defvar *database-path* (make-pathname :directory '(:relative "benchmark")))
+
+(defun write-results (name key value)
+ (ensure-directories-exist *database-path*)
+ (let* ((path (merge-pathnames (concatenate 'string name ".sexp")
+ *database-path*))
+ (current (when (probe-file path)
+ (with-open-file (stream path)
+ (with-standard-io-syntax
+ (read stream)))))
+ (pair (assoc key current :test #'equalp)))
+ (if pair
+ (setf (cdr pair) value)
+ (setf current (acons key value current)))
+ (with-open-file (stream path
+ :if-exists :supersede :if-does-not-exist :create
+ :direction :output)
+ (with-standard-io-syntax
+ (write current :stream stream))))
+ (values))

quaviver.asd

@@ -177,6 +177,8 @@
  :pathname "code/benchmark/"
  :serial t
  :components ((:file "packages")
+ (:file "results")
+ (:file "report")
  (:file "float-integer")))))
 
 (defsystem "quaviver/compare"