compare: Update for head-to-head comparisons

* Improve parallel algorithm so that it reports progress and displays
  startup and completion messages
* Lookup clients in dynamic variable and minimize the creation of
  client instances
* Use closed intervals for ranges
* Use keyword arguments in float-integer/range/parallel

code/compare/float-integer.lisp

@@ -3,104 +3,152 @@
 
 (cl:in-package #:quaviver/compare)
 
-(defun distribute-range (lower upper-exclusive parts)
- (assert (<= 1 parts (- upper-exclusive lower)))
- (multiple-value-bind (increment remainder) (floor (- upper-exclusive lower) parts)
- (loop for a = lower then b
+(defun distribute-range (start end parts)
+ (assert (<= 1 parts (- end start -1)))
+ (multiple-value-bind (increment remainder) (floor (- end start -1) parts)
+ (loop for a = start then b
  for b = (+ a increment (cond ((plusp remainder) (decf remainder) 1)
  (t 0)))
  repeat parts
- collect (cons a b))))
-
-(defun integer-string-zero-padded (integer limit-inclusive)
- (let ((n-digits (length (princ-to-string limit-inclusive))))
- (format nil "~v,,,'0@A" n-digits integer)))
+ collect (cons a (1- b)))))
 
 (defvar *ieee754-client* (make-instance 'quaviver/ieee754:client))
 
 (defvar *clients*
  '(:burger-dybvig (quaviver/burger-dybvig:client)
  :schubfach (quaviver/schubfach:client)))
 
-;;; Assumes IEEE-754 binary32 and binary64 for SINGLE-FLOAT and
-;;; DOUBLE-FLOAT, respectively.
-(defun float-integer (clients float-type base bits)
- (when (ecase float-type ; skip infinities and NaNs
- (single-float (eql (ldb (byte 8 0) -1)
- (ldb (byte 8 23) bits)))
- (double-float (eql (ldb (byte 11 0) -1)
- (ldb (byte 11 52) bits))))
- (return-from float-integer nil))
- (loop with value = (quaviver:bits-float *ieee754-client* float-type bits)
- with result
- for (name initargs) on clients by #'cddr
- for intrep = (handler-case (multiple-value-list
- (quaviver:float-integer
- (apply #'make-instance initargs) base value))
- (error (e) e))
- do (cond
- ((typep intrep 'error)
- (setf result (list* intrep (list name) result)))
- (t
- (loop with matched-p = nil
- for tail = result then (cddr tail)
- until (endp tail)
- do (let ((other-intrep (car tail))
- (other-names (cadr tail)))
- (when (equalp intrep other-intrep)
- (setf matched-p t
- (cadr tail) (cons name other-names))))
- finally (unless matched-p
- (setf result (list* intrep (list name) result))))))
- finally (return (if (null (cddr result)) nil ; all matched
- (list* bits value (nreverse result))))))
+(defun float-integer/compare (client-instance-1 client-instance-2 base value)
+ (multiple-value-bind (significand1 exponent1 sign1)
+ (ignore-errors (quaviver:float-integer client-instance-1 base value))
+ (multiple-value-bind (significand2 exponent2 sign2)
+ (ignore-errors (quaviver:float-integer client-instance-2 base value))
+ (unless (or (and (null significand1) ; both signaled errors
+ (null significand2))
+ (and (eql significand1 significand2) ; identical results
+ (eql exponent1 exponent2)
+ (eql sign1 sign2))
+ (and (eql sign1 sign2) ; significands have trailing zeros
+ (integerp significand2)
+ (integerp significand2)
+ (integerp exponent1)
+ (integerp exponent2)
+ (eql (* significand1
+ (expt base
+ (- exponent1
+ (min exponent1 exponent2))))
+ (* significand2
+ (expt base
+ (- exponent2
+ (min exponent1 exponent2)))))))
+ (list value
+ (when significand1
+ (list significand1 exponent1 sign1))
+ (when significand2
+ (list significand2 exponent2 sign2)))))))
+
+(defun float-integer/compare-bits (client-instance-1 client-instance-2 float-type base bits)
+ (let ((result (float-integer/compare client-instance-1 client-instance-2
+ base
+ (quaviver:bits-float *ieee754-client* float-type bits))))
+ (when result
+ (list* bits result))))
+
+(defun float-size (float-type)
+ (ecase float-type
+ (short-float 32)
+ (single-float 32)
+ (double-float 64)
+ (long-float
+ #-quaviver/long-float 64
+ #+quaviver/long-float 80)))
 
-;;; Tests only positive floats.
-(defun float-integer-random (clients float-type base count)
- (loop with limit = (ecase float-type
- (single-float (ash 1 32))
- (double-float (ash 1 64)))
+(defun float-hex-digits (float-type)
+ (/ (float-size float-type) 4))
+
+(defun write-discrepancy (float-type discrepancy &optional (stream t))
+ (format stream "~:<#x~v,'0x ~e ~s ~s~:@>~%"
+ (list* (float-hex-digits float-type) discrepancy)))
+
+(defun float-integer/random (name1 name2 float-type base count &optional (stream t))
+ (loop with limit = (ash 1 (float-size float-type))
+ with client-instance-1 = (apply #'make-instance (getf *clients* name1))
+ with client-instance-2 = (apply #'make-instance (getf *clients* name2))
+ with *print-base* = base
+ with pass = t
  repeat count
  for bits = (random limit)
- do (float-integer clients float-type base bits)))
+ for discrepancy = (float-integer/compare-bits client-instance-1 client-instance-2
+ float-type base bits)
+ finally (return pass)
+ when discrepancy
+ do (setf pass nil)
+ (write-discrepancy float-type discrepancy stream)))
+
+(defun float-integer/range (name1 name2 float-type base start end &optional (stream t))
+ (loop with client-instance-1 = (apply #'make-instance (getf *clients* name1))
+ with client-instance-2 = (apply #'make-instance (getf *clients* name2))
+ with *print-base* = base
+ with pass = t
+ for bits from start upto end
+ for discrepancy = (float-integer/compare-bits client-instance-1 client-instance-2
+ float-type base bits)
+ finally (return pass)
+ when discrepancy
+ do (setf pass nil)
+ (write-discrepancy float-type discrepancy stream)))
 
-(defun float-integer-range
- (clients float-type base lower upper-exclusive output &optional (parts 1))
- (etypecase output
- (stream
- (loop with lparallel:*kernel* = (lparallel:make-kernel parts :name "quaviver/compare")
- with channel = (lparallel:make-channel)
- with ranges = (distribute-range lower upper-exclusive parts)
- for (sublower . subupper-exclusive) in ranges
- for file-num from 1
- for prefix = (format nil "quaviver-compare-~A-"
- (integer-string-zero-padded file-num parts))
- do (let ((sublower sublower)
- (subupper-exclusive subupper-exclusive)
- (prefix prefix))
- (lparallel:submit-task
- channel
- (lambda ()
- (let ((*print-pretty* nil))
- (uiop:with-temporary-file (:stream stream :pathname pathname
- :prefix prefix :keep t)
- (loop for bits from sublower below subupper-exclusive
- for discrepancy = (float-integer clients float-type base bits)
- do (unless (null discrepancy)
- (format stream "(#x~v,'0X ~{~S~^ ~})~%"
- (ecase float-type
- (single-float 8)
- (double-float 16))
- (first discrepancy) (rest discrepancy))))
- :close-stream
- pathname)))))
- finally (let ((pathnames (loop repeat parts
- collect (lparallel:receive-result channel))))
- (lparallel:end-kernel :wait t)
- (setf pathnames (sort pathnames #'string< :key #'uiop:unix-namestring))
- (uiop:concatenate-files pathnames output)
- (loop for pathname in pathnames
- do (uiop:delete-file-if-exists pathname)))))
- (pathname
- (uiop:with-output-file (output output :if-exists :supersede)
- (float-integer-range clients float-type base lower upper-exclusive output parts)))))
+(defun float-integer/range/parallel (name1 name2 output
+ &key (float-type 'single-float) (base 10)
+ (start 0) end
+ (worker-count (or (cpu-count)
+ (error "WORKER-COUNT is required.") ))
+ (job-count 1024))
+ (setf end (or end
+ (1- (ash 1 (float-size float-type))))
+ job-count (min (- end start) job-count))
+ (format t "Starting ~s job~p on ~s worker~p.~%"
+ worker-count worker-count job-count job-count)
+ (finish-output)
+ (let* ((lparallel:*kernel* (lparallel:make-kernel worker-count))
+ (channel (lparallel:make-channel))
+ (start-time (get-internal-real-time)))
+ (loop for (start . end) in (distribute-range start end job-count)
+ for pos from 1
+ do (let ((start start)
+ (end end)
+ (pos pos))
+ (lparallel:submit-task
+ channel
+ (lambda (&aux (discrepancy-count 0))
+ (uiop:with-temporary-file (:stream stream :pathname pathname :keep t)
+ (unless (ignore-errors
+ (float-integer/range name1 name2 float-type base
+ start end stream))
+ (incf discrepancy-count))
+ :close-stream
+ (list pos pathname discrepancy-count))))))
+ (loop with all-discrepancy-count = 0
+ with pathnames = (list* (uiop:with-temporary-file (:stream stream
+ :pathname pathname
+ :keep t)
+ (format stream "~:@<~s ~s ~s ~s #x~v,'0x #x~v,'0x~:@>~%"
+ name1 name2
+ float-type base
+ (float-hex-digits float-type) start
+ (float-hex-digits float-type) end)
+ (terpri stream)
+ :close-stream
+ pathname)
+ (make-list job-count))
+ for job from 1 upto job-count
+ for (pos pathname discrepancy-count) = (lparallel:receive-result channel)
+ finally (uiop:concatenate-files pathnames output)
+ (mapc #'uiop:delete-file-if-exists pathnames)
+ (format t "Completed in ~/quaviver-compare:internal-time/ with ~d discrepanc~@p.~%"
+ (- (get-internal-real-time) start-time)
+ all-discrepancy-count all-discrepancy-count)
+ do (setf (car (nthcdr pos pathnames)) pathname)
+ (incf all-discrepancy-count discrepancy-count)
+ (format t "Completed ~a of ~a~%" job job-count)
+ (finish-output))))

code/compare/packages.lisp

@@ -3,6 +3,10 @@
 
 (cl:defpackage #:quaviver/compare
  (:use #:common-lisp)
- (:export #:float-integer
- #:float-integer-random
- #:float-integer-range))
+ (:nicknames #:quaviver-compare)
+ (:export #:*clients*
+ #:float-integer/compare
+ #:float-integer/compare-bits
+ #:float-integer/random
+ #:float-integer/range
+ #:float-integer/range/parallel))

code/compare/utility.lisp

@@ -0,0 +1,33 @@
+(in-package #:quaviver/compare)
+
+(defun run-program-capture (command &key directory)
+ "Run a program and capture the output as a string."
+ (ignore-errors
+ (multiple-value-bind (standard-output error-output code)
+ (uiop:run-program command
+ :directory directory
+ :ignore-error-status t
+ :output '(:string :stripped t)
+ :error-output '(:string :stripped t))
+ (declare (ignore error-output))
+ (when (zerop code)
+ standard-output))))
+
+(defun cpu-count ()
+ (loop for command in #+bsd '("sysctl -n hw.physicalcpu"
+ "sysctl -n hw.ncpu"
+ "sysctl -n hw.ncpufound")
+ #-bsd '("nproc --all")
+ for output = (run-program-capture command)
+ when output
+ return (parse-integer output :junk-allowed t)))
+
+(defun internal-time (stream value colon at &rest args)
+ (declare (ignore colon at args))
+ (multiple-value-bind (minutes seconds)
+ (floor (floor value internal-time-units-per-second)
+ 60)
+ (multiple-value-bind (hours minutes)
+ (floor minutes 60)
+ (format stream "~d:~2,'0d:~2,'0d"
+ hours minutes seconds))))

quaviver.asd

@@ -184,7 +184,8 @@
 (defsystem "quaviver/compare"
  :description "Compare implementations of Quaviver protocol"
  :license "MIT"
- :author ("Paul A. Patience")
+ :author ("Paul A. Patience"
+ "Tarn W. Burton")
  :version (:read-file-form "version.sexp")
  :homepage "https://github.com/s-expressionists/Quaviver"
  :bug-tracker "https://github.com/s-expressionists/Quaviver/issues"
@@ -197,4 +198,5 @@
  :pathname "code/compare/"
  :serial t
  :components ((:file "packages")
+ (:file "utility")
  (:file "float-integer")))))