Skip to content

Commit

Permalink
compare: add test names
Browse files Browse the repository at this point in the history
  • Loading branch information
@yitzchak
yitzchak committed Jul 1, 2024
1 parent 504538b commit 69732c1
Show file tree
Hide file tree
Showing 3 changed files with 63 additions and 40 deletions.
21 changes: 12 additions & 9 deletions code/compare/float-integer.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4,7 +4,10 @@
(cl:in-package #:quaviver/compare)

(defclass float-integer ()
((client1 :accessor client1
((name :reader test-name
:initarg :name
:initform nil)
(client1 :accessor client1
:initarg :client1)
(client2 :accessor client2
:initarg :client2)
Expand Down Expand Up @@ -57,17 +60,17 @@
(iterator-bits iterator))
nil)))

(defun float-integer/bd.s/f (output &rest rest &key (coverage 1) &allow-other-keys)
(defun float-integer/bd.s/f (&rest rest &key (coverage 1) &allow-other-keys)
(apply #'test
(list (make-instance 'float-integer
:client1 (make-instance 'quaviver/burger-dybvig:client)
:client2 (make-instance 'quaviver/schubfach:client)
:base 10))
(list (make-instance 'bit-interval
:coverage coverage))
output rest))
rest))

(defun float-integer/bd.s/d (output &rest rest &key (coverage (expt 2 -32)) &allow-other-keys)
(defun float-integer/bd.s/d (&rest rest &key (coverage (expt 2 -32)) &allow-other-keys)
(apply #'test
(list (make-instance 'float-integer
:client1 (make-instance 'quaviver/burger-dybvig:client)
Expand All @@ -76,19 +79,19 @@
(list (make-instance 'bit-interval
:float-type 'double-float
:coverage coverage))
output rest))
rest))

(defun float-integer/s.d/f (output &rest rest &key (coverage 1) &allow-other-keys)
(defun float-integer/s.d/f (&rest rest &key (coverage 1) &allow-other-keys)
(apply #'test
(list (make-instance 'float-integer
:client1 (make-instance 'quaviver/schubfach:client)
:client2 (make-instance 'quaviver/dragonbox:nearest-client)
:base 10))
(list (make-instance 'bit-interval
:coverage coverage))
output rest))
rest))

(defun float-integer/s.d/d (output &rest rest &key (coverage (expt 2 -32)) &allow-other-keys)
(defun float-integer/s.d/d (&rest rest &key (coverage (expt 2 -32)) &allow-other-keys)
(apply #'test
(list (make-instance 'float-integer
:client1 (make-instance 'quaviver/schubfach:client)
Expand All @@ -97,4 +100,4 @@
(list (make-instance 'bit-interval
:float-type 'double-float
:coverage coverage))
output rest))
rest))
11 changes: 7 additions & 4 deletions code/compare/integer-float.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4,7 +4,10 @@
(cl:in-package #:quaviver/compare)

(defclass integer-float ()
((client1 :accessor client1
((name :reader test-name
:initarg :name
:initform nil)
(client1 :accessor client1
:initarg :client1)
(client2 :accessor client2
:initarg :client2)
Expand Down Expand Up @@ -40,15 +43,15 @@
(iterator-bits iterator))
nil)))

(defun integer-float/j.l/f (output &rest rest &key (coverage 1) &allow-other-keys)
(defun integer-float/j.l/f (&rest rest &key (coverage 1) &allow-other-keys)
(apply #'test
(list (make-instance 'integer-float
:client1 (make-instance 'quaviver/jaffer:client)
:client2 (make-instance 'quaviver/liebler:client)
:base 10))
(list (make-instance 'bit-interval
:coverage coverage))
output rest))
rest))

(defun integer-float/j.l/d (&rest rest &key (coverage (expt 2 -32)) &allow-other-keys)
(apply #'test
Expand All @@ -59,4 +62,4 @@
(list (make-instance 'bit-interval
:float-type 'double-float
:coverage coverage))
output rest))
rest))
71 changes: 44 additions & 27 deletions code/compare/test.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,11 +2,13 @@

(defgeneric iterator-value-pass-p (test iterator stream))

(defun test (tests intervals output
(defgeneric test-name (test))

(defun test (tests intervals
&key (worker-count (or (cpu-count)
(error "WORKER-COUNT is required.") ))
(job-count 1024)
exit
exit output
&allow-other-keys)
(setf intervals (split-interval intervals (floor job-count (length tests)))
job-count (* (length intervals)
Expand All @@ -26,35 +28,50 @@
(interval interval))
(lparallel:submit-task
channel
(lambda ()
(uiop:with-temporary-file (:stream stream :pathname pathname :keep t)
(handler-case (loop with iterator = (make-iterator interval)
finally (return (list pos pathname total failures))
while (iterator-next-p iterator)
count t into total
count (not (iterator-value-pass-p test
iterator
stream))
into failures)
(error (condition)
(declare (ignore condition))
(list pos pathname 0 0)))))))))
(loop with total = 0
with failures = 0
(lambda (&aux (name (test-name test)))
(flet ((doit (pathname stream)
(when name
(write name :stream stream)
(terpri stream)
(finish-output stream))
(handler-case (loop with iterator = (make-iterator interval)
finally (return (list pos pathname name total failures))
while (iterator-next-p iterator)
count t into total
count (not (iterator-value-pass-p test
iterator
stream))
into failures)
(error (condition)
(declare (ignore condition))
(list pos pathname name 0 0)))))
(if output
(uiop:with-temporary-file (:stream stream :pathname pathname :keep t)
(doit pathname stream))
(doit nil (make-broadcast-stream)))))))))
(loop with counts = (make-hash-table :test #'equalp)
with pathnames = (make-list job-count)
for job from 1 upto job-count
for (pos pathname job-total job-failures) = (lparallel:receive-result channel)
finally (uiop:concatenate-files (remove nil pathnames) output)
(mapc #'uiop:delete-file-if-exists (remove nil pathnames))
(format t "Completed in ~/quaviver-compare:internal-time/ with ~d failure~p out of ~d tests~%"
(- (get-internal-real-time) start-time)
failures failures total)
for (pos pathname name job-total job-failures) = (lparallel:receive-result channel)
for count = (gethash name counts)
finally (when output
(uiop:concatenate-files (remove nil pathnames) output)
(mapc #'uiop:delete-file-if-exists (remove nil pathnames)))
(terpri)
(loop for (total . failures) being each hash-value in counts using (hash-key name)
do (format t "Completed ~@[~a ~]in ~/quaviver-compare:internal-time/ with ~d failure~p out of ~d tests~%"
name
(- (get-internal-real-time) start-time)
failures failures total))
(when exit
(uiop:quit (if (zerop failures) 0 1)))
when count
do (incf (car count) job-total)
(incf (cdr count) job-failures)
else
do (setf (gethash name counts) (cons job-total job-failures))
do (setf (car (nthcdr pos pathnames)) pathname)
(incf total job-total)
(incf failures job-failures)
(format t "Completed ~a of ~a with ~a failure~p out of ~a tests.~%"
job job-count
(format t "Completed ~@[~a ~]~a of ~a with ~a failure~p out of ~a tests.~%"
name job job-count
job-failures job-failures job-total)
(finish-output))))

0 comments on commit 69732c1

Please sign in to comment.