From 6486c341eb4afc3ef71c150ce6b0c20f4ded8eca Mon Sep 17 00:00:00 2001 From: "Tarn W. Burton" Date: Sat, 22 Jun 2024 10:44:48 -0400 Subject: [PATCH] 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 | 222 +++++++++++++++++++------------- code/compare/packages.lisp | 10 +- code/compare/utility.lisp | 33 +++++ quaviver.asd | 4 +- 4 files changed, 178 insertions(+), 91 deletions(-) create mode 100644 code/compare/utility.lisp diff --git a/code/compare/float-integer.lisp b/code/compare/float-integer.lisp index 1d6e80c8..0cdd290b 100644 --- a/code/compare/float-integer.lisp +++ b/code/compare/float-integer.lisp @@ -3,18 +3,14 @@ (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)) @@ -22,85 +18,137 @@ '(: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)))) diff --git a/code/compare/packages.lisp b/code/compare/packages.lisp index 5d2ef5c1..b8dd5812 100644 --- a/code/compare/packages.lisp +++ b/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)) diff --git a/code/compare/utility.lisp b/code/compare/utility.lisp new file mode 100644 index 00000000..4d62a9e7 --- /dev/null +++ b/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)))) diff --git a/quaviver.asd b/quaviver.asd index 3a0a83ba..268f3873 100644 --- a/quaviver.asd +++ b/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")))))