diff --git a/benchmarks/bbtrees.lisp b/benchmarks/bbtrees.lisp index 6be2e7b93..4947c3b3c 100644 --- a/benchmarks/bbtrees.lisp +++ b/benchmarks/bbtrees.lisp @@ -2,6 +2,9 @@ (load "src/code/redblack.lisp") (with-compilation-unit () (load "tests/test-util.lisp")) +(eval-when (:compile-toplevel :load-toplevel :execute) + (import 'sb-int:dovector)) + (in-package "SB-RBTREE.WORD") (defun height (tree) (sb-int:named-let recurse ((tree tree)) @@ -35,48 +38,54 @@ (defvar *hash-table* nil) (defvar *lotta-strings* - (mapcar (lambda (x) - (sb-kernel:%make-lisp-obj - (logandc2 (sb-kernel:get-lisp-obj-address x) - sb-vm:lowtag-mask))) - (sb-vm:list-allocated-objects - :read-only - :type sb-vm:simple-base-string-widetag))) + (coerce + ;; Collect al pseudostatic symbols and all readonly strings + (mapcar (lambda (x) + (sb-kernel:%make-lisp-obj + (logandc2 (sb-kernel:get-lisp-obj-address x) + sb-vm:lowtag-mask))) + (nconc (sb-vm:list-allocated-objects + :dynamic + :type sb-vm:symbol-widetag + :test (lambda (x) (= (sb-kernel:generation-of x) + sb-vm:+pseudo-static-generation+))) + (sb-vm:list-allocated-objects + :read-only + :type sb-vm:simple-base-string-widetag))) + 'vector)) +(declaim (simple-vector *lotta-strings*)) (defun insert-all-brothertree () (let ((tree nil)) - (dolist (str *lotta-strings*) + (dovector (str *lotta-strings*) (setq tree (sb-brothertree:insert str tree))) (setq *brothertree* tree))) (defun insert-all-redblack () (let ((tree nil)) - (dolist (str *lotta-strings*) + (dovector (str *lotta-strings*) ;; because OF COURSE the arg orders are opposite (setq tree (sb-rbtree.word:insert tree str))) (setq *rbtree* tree))) (defun insert-all-solist () - (let ((set (let ((sb-lockless::*desired-elts-per-bin* 1)) + (let ((set (let ((sb-lockless::*desired-elts-per-bin* 2)) (sb-lockless:make-so-set/addr)))) - (dolist (str *lotta-strings*) + (dovector (str *lotta-strings*) (sb-lockless:so-insert set str)) (setq *solist* set))) (defun insert-all-hash-table () - (let ((set (make-hash-table :test 'eq))) - (dolist (str *lotta-strings*) + (let ((set (make-hash-table :test 'eq :synchronized t))) + (dovector (str *lotta-strings*) (setf (gethash str set) t)) (setq *hash-table* set))) -(gc) -(time (insert-all-redblack)) -(gc) -(time (insert-all-brothertree)) -(gc) -(time (insert-all-solist)) -(gc) -(time (insert-all-hash-table)) +(dolist (test '(insert-all-redblack insert-all-brothertree insert-all-solist insert-all-hash-table)) + (gc) + (format t "Running ~S~%" test) + (time (funcall test))) + (let ((n (length *lotta-strings*))) (format t "~&Memory:~:{~% ~8a=~8D ~3,1f~}~%" (loop for (name . val) in `(("brother" . ,*brothertree*) @@ -91,27 +100,80 @@ (sb-rbtree.word::height *rbtree*) (sb-brothertree::height *brothertree*)) -(defun find-all-in-brothertree (&aux (tree *brothertree*)) - (loop for str in *lotta-strings* - count (sb-brothertree:find= str tree))) -(defun find-all-in-redblack-tree (&aux (tree *rbtree*)) - (loop for str in *lotta-strings* - count (sb-rbtree.word:find= str tree))) -(defun find-all-in-solist (&aux (set *solist*)) - (loop for str in *lotta-strings* - count (sb-lockless:so-find set str))) -(defun find-all-in-hash-table (&aux (set *hash-table*)) - (loop for str in *lotta-strings* - count (gethash str set))) +(macrolet ((exercise (find-it) + `(ecase direction + (:up (loop for str across *lotta-strings* + count ,find-it)) + (:down (let ((v *lotta-strings*)) + (loop for i downfrom (1- (length v)) to 0 + count (let ((str (svref v i))) ,find-it))))))) + (defun find-all-in-brothertree (&optional (direction :up) &aux (tree *brothertree*)) + (exercise (sb-brothertree:find= str tree))) + (defun find-all-in-redblack-tree (&optional (direction :up) &aux (tree *rbtree*)) + (exercise (sb-rbtree.word:find= str tree))) + (defun find-all-in-solist (&optional (direction :up) &aux (set *solist*)) + (exercise (sb-lockless:so-find set str))) + (defun find-all-in-hash-table (&optional (direction :up) &aux (set *hash-table*)) + (exercise (gethash str set)))) -(find-all-in-brothertree) -(find-all-in-redblack-tree) -(find-all-in-solist) -(find-all-in-hash-table) -(time (find-all-in-brothertree)) -(time (find-all-in-redblack-tree)) -(time (find-all-in-solist)) -(time (find-all-in-hash-table)) +;;; Each test will run *nthreads* threads and each thread will find each item. +(defvar *start-sem* (sb-thread:make-semaphore)) +(defvar *completion-sem* (sb-thread:make-semaphore)) +(defvar *function-to-run* nil) +(defglobal *results* nil) +(defun say (s) + (declare (simple-base-string s)) + (sb-sys:with-pinned-objects (s) + ;; avoid interleaved output, usually + (sb-unix:unix-write 2 s 0 (length s)))) + +(defmacro with-cycle-counter (form) + `(multiple-value-bind (hi0 lo0) (sb-vm::%read-cycle-counter) + (values ,form + (multiple-value-bind (hi1 lo1) (sb-vm::%read-cycle-counter) + (+ (ash (- hi1 hi0) 32) (- lo1 lo0)))))) + +(defun workfun (my-index) + (let ((direction-to-scan (if (oddp my-index) :up :down))) + (loop ; (say (format nil "thread ~d waiting~%" my-index)) + (sb-thread:wait-on-semaphore *start-sem*) + ; (say (format nil "thread ~d starting function under test~%" my-index)) + (let ((test-fun *function-to-run*)) + (when (null test-fun) + ;(say (format nil "thread ~d exiting~%" my-index)) + (return)) + ;(say (format nil "thread ~d working~%" my-index)) + (multiple-value-bind (answer cycle-time) + (with-cycle-counter (funcall test-fun direction-to-scan)) + (assert (= answer (length *lotta-strings*))) + (sb-ext:atomic-push cycle-time *results*)) + (sb-thread:signal-semaphore *completion-sem*))))) + +(defun perform-work-in-threads (test nthreads) + (setf *function-to-run* test + *results* nil) + (sb-thread:signal-semaphore *start-sem* nthreads) + (sb-thread:wait-on-semaphore *completion-sem* :n nthreads)) + +(defvar *find-tests* '(find-all-in-brothertree find-all-in-redblack-tree + find-all-in-solist find-all-in-hash-table)) + +(defun test-nthreads (&optional (nthreads 6)) + (let ((threads (make-array nthreads))) + (dotimes (i nthreads) + (setf (aref threads i) (sb-thread:make-thread #'workfun :arguments (list i)))) + (dolist (test *find-tests*) + (format t "~&Testing ~S~%" test) + (time (perform-work-in-threads test nthreads)) + (let* ((cycle-times *results*) + (min (reduce #'min cycle-times)) + (max (reduce #'max cycle-times)) + (sum (reduce #'+ cycle-times))) + (format t " ==> min=~E max=~E avg=~E~2%" + min max (/ sum nthreads)))) + (setq *function-to-run* nil) + (sb-thread:signal-semaphore *start-sem* nthreads) + (map nil #'sb-thread:join-thread threads))) #| * (load"benchmarks/bbtrees") diff --git a/float-math.lisp-expr b/float-math.lisp-expr index 53011bb40..bb63fabc6 100644 --- a/float-math.lisp-expr +++ b/float-math.lisp-expr @@ -1834,7 +1834,9 @@ (= (#x-4000000000000000 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (= (#x-1000000000000001 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (= (#x-1000000000000000 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) +(= (#x-80000000 #.(MAKE-DOUBLE-FLOAT #x-3E200000 #x0)) T) (= (#x-20000001 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) +(= (#x-20000000 #.(MAKE-DOUBLE-FLOAT #x-3E400000 #x0)) T) (= (#x-20000000 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (= (#x-3 #.(MAKE-DOUBLE-FLOAT #x-3FF80000 #x0)) T) (= (#x-2 #.(MAKE-DOUBLE-FLOAT #x-40000000 #x0)) T) @@ -1890,6 +1892,7 @@ (= (#x16 #.(MAKE-DOUBLE-FLOAT #x40360000 #x0)) T) (= (#x19 #.(MAKE-DOUBLE-FLOAT #x40390000 #x0)) T) (= (#x1C #.(MAKE-DOUBLE-FLOAT #x403C0000 #x0)) T) +(= (#x1E #.(MAKE-DOUBLE-FLOAT #x403E0000 #x0)) T) (= (#x1F #.(MAKE-DOUBLE-FLOAT #x403F0000 #x0)) T) (= (#x20 #.(MAKE-DOUBLE-FLOAT #x40400000 #x0)) T) (= (#x23 #.(MAKE-DOUBLE-FLOAT #x40418000 #x0)) T) @@ -1899,15 +1902,21 @@ (= (#x3F #.(MAKE-DOUBLE-FLOAT #x404F8000 #x0)) T) (= (#x40 #.(MAKE-DOUBLE-FLOAT #x40500000 #x0)) T) (= (#x45 #.(MAKE-DOUBLE-FLOAT #x40514000 #x0)) T) +(= (#x4A #.(MAKE-DOUBLE-FLOAT #x40528000 #x0)) T) +(= (#x4E #.(MAKE-DOUBLE-FLOAT #x40538000 #x0)) T) (= (#x51 #.(MAKE-DOUBLE-FLOAT #x40544000 #x0)) T) (= (#x60 #.(MAKE-DOUBLE-FLOAT #x40580000 #x0)) T) (= (#x70 #.(MAKE-DOUBLE-FLOAT #x405C0000 #x0)) T) (= (#x80 #.(MAKE-DOUBLE-FLOAT #x40600000 #x0)) T) (= (#x81 #.(MAKE-DOUBLE-FLOAT #x40602000 #x0)) T) +(= (#x82 #.(MAKE-DOUBLE-FLOAT #x40604000 #x0)) T) (= (#x85 #.(MAKE-DOUBLE-FLOAT #x4060A000 #x0)) T) +(= (#x86 #.(MAKE-DOUBLE-FLOAT #x4060C000 #x0)) T) (= (#x89 #.(MAKE-DOUBLE-FLOAT #x40612000 #x0)) T) +(= (#x8A #.(MAKE-DOUBLE-FLOAT #x40614000 #x0)) T) (= (#xC0 #.(MAKE-DOUBLE-FLOAT #x40680000 #x0)) T) (= (#xD2 #.(MAKE-DOUBLE-FLOAT #x406A4000 #x0)) T) +(= (#xD6 #.(MAKE-DOUBLE-FLOAT #x406AC000 #x0)) T) (= (#xDA #.(MAKE-DOUBLE-FLOAT #x406B4000 #x0)) T) (= (#xE0 #.(MAKE-DOUBLE-FLOAT #x406C0000 #x0)) T) (= (#xE1 #.(MAKE-DOUBLE-FLOAT #x406C2000 #x0)) T) @@ -1927,11 +1936,14 @@ (= (#xFFFF #.(MAKE-DOUBLE-FLOAT #x40EFFFE0 #x0)) T) (= (#x1FFFFFFC #.(MAKE-SINGLE-FLOAT #x3F800000)) NIL) (= (#x1FFFFFFF #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) +(= (#x1FFFFFFF #.(MAKE-DOUBLE-FLOAT #x41BFFFFF #xFF000000)) T) (= (#x20000000 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (= (#x20000001 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) +(= (#x3F800000 #.(MAKE-DOUBLE-FLOAT #x41CFC000 #x0)) T) (= (#x3FF00000 #.(MAKE-DOUBLE-FLOAT #x41CFF800 #x0)) T) (= (#x3FFFFFFB #.(MAKE-SINGLE-FLOAT #x31800000)) NIL) (= (#x7FF00000 #.(MAKE-DOUBLE-FLOAT #x41DFFC00 #x0)) T) +(= (#x80000000 #.(MAKE-DOUBLE-FLOAT #x41E00000 #x0)) T) (= (#xFFFFFFFF #.(MAKE-DOUBLE-FLOAT #x41EFFFFF #xFFE00000)) T) (= (#xFFFFFFFFFFFFFFC #.(MAKE-SINGLE-FLOAT #x3F800000)) NIL) (= (#xFFFFFFFFFFFFFFF #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) @@ -3908,6 +3920,7 @@ (COERCE (#x16 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x40360000 #x0)) (COERCE (#x19 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x40390000 #x0)) (COERCE (#x1C DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x403C0000 #x0)) +(COERCE (#x1E DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x403E0000 #x0)) (COERCE (#x1F DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x403F0000 #x0)) (COERCE (#x20 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x40400000 #x0)) (COERCE (#x23 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x40418000 #x0)) @@ -3917,15 +3930,21 @@ (COERCE (#x3F DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x404F8000 #x0)) (COERCE (#x40 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x40500000 #x0)) (COERCE (#x45 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x40514000 #x0)) +(COERCE (#x4A DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x40528000 #x0)) +(COERCE (#x4E DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x40538000 #x0)) (COERCE (#x51 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x40544000 #x0)) (COERCE (#x60 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x40580000 #x0)) (COERCE (#x70 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x405C0000 #x0)) (COERCE (#x80 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x40600000 #x0)) (COERCE (#x81 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x40602000 #x0)) +(COERCE (#x82 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x40604000 #x0)) (COERCE (#x85 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x4060A000 #x0)) +(COERCE (#x86 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x4060C000 #x0)) (COERCE (#x89 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x40612000 #x0)) +(COERCE (#x8A DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x40614000 #x0)) (COERCE (#xC0 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x40680000 #x0)) (COERCE (#xD2 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x406A4000 #x0)) +(COERCE (#xD6 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x406AC000 #x0)) (COERCE (#xDA DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x406B4000 #x0)) (COERCE (#xE0 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x406C0000 #x0)) (COERCE (#xE1 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x406C2000 #x0)) @@ -3961,6 +3980,7 @@ (COERCE (#x1FFFFFFF SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x4E000000)) (COERCE (#x20000000 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x41C00000 #x0)) (COERCE (#x20000000 SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x4E000000)) +(COERCE (#x3F800000 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x41CFC000 #x0)) (COERCE (#x3FF00000 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x41CFF800 #x0)) (COERCE (#x7FF00000 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x41DFFC00 #x0)) (COERCE (#x7FFFFFFF DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x41DFFFFF #xFFC00000)) diff --git a/src/code/solist.lisp b/src/code/solist.lisp index 39d852480..85dbedd3b 100644 --- a/src/code/solist.lisp +++ b/src/code/solist.lisp @@ -96,16 +96,18 @@ (defun %so-search/addr (head hash key) ;; KEY is any object, which either has to be immobile, or else GC has to repair the table. - (declare (list-node head) (fixnum hash)) - (macrolet ((cast-to-word (x) `(get-lisp-obj-address ,x)) - (compare (x y) - (declare (ignore x y)) - `(let ((x (node-hash (|the| so-node this)))) - (cond ((< x hash) t) - ((= x hash) - (< (cast-to-word (so-key (|the| so-key-node this))) - (cast-to-word key))))))) - (lfl-search-macro compare t))) + (let ((head (truly-the list-node head)) + (hash (truly-the fixnum hash))) + (macrolet ((cast-to-word (x) + `(get-lisp-obj-address ,x)) + (compare (x y) + (declare (ignore x y)) + `(let ((x (node-hash (|the| so-node this)))) + (cond ((< x hash) t) + ((= x hash) + (< (cast-to-word (so-key (|the| so-key-node this))) + (cast-to-word key))))))) + (lfl-search-macro compare t)))) (defun %so-search/string (head hash key) (declare (list-node head) (fixnum hash) (string key)) @@ -188,8 +190,9 @@ ) (declaim (inline masked-hash)) -(defun masked-hash (hash) (mask-field (byte (1- +hash-nbits+) 1) hash)) - +;;(defun masked-hash (hash) (mask-field (byte (1- +hash-nbits+) 1) hash)) +;; HASH *must* be non-negative. We don't mask out the sign bit any more. +(defun masked-hash (hash) (logior hash 1)) (defmacro with-bin ((table-var ; input hash-var node-var &rest rest) ; output hash-expr &body body) @@ -296,6 +299,24 @@ (atomic-decf (so-count table))) deleted))) +(defmacro multiplicative-hash (x) + ;; Use Knuth's hash multiplier of 2^32 * (-1 + sqrt(5)) / 2. + ;; This constant works quite well for our variant of the solist algorithm + ;; which consumes hash bits from most-significant to least-significant. + ;; Note that most descriptions of this require a right-shift, but here it's + ;; exactly the correct answer by itself because the solist algorithm consumes + ;; bits from left-to-right (most-to-least-significant). + #-64-bit + `(ash (logand (* ,x 2654435769) sb-ext:most-positive-word) + ,(- (1+ sb-vm:n-fixnum-tag-bits))) ; Ensure a positive fixnum result + ;; Same thing but with 64 bits of precision. I used MPFR to compute this + ;; (also https://asecuritysite.com/hash/smh_fib gives the same number). + ;; The number 11400714819323198486 is slightly more correct, but an odd multiplier + ;; is better than even, otherwise the rightmost result bit would be always 0. + #+64-bit + `(ash (logand (* ,x 11400714819323198485) sb-ext:most-positive-word) + ,(- (1+ sb-vm:n-fixnum-tag-bits)))) + (macrolet ((guts (key-hash searcher equality-fn) `(with-bin (table hash start-node) ,key-hash (let ((node (,searcher start-node (logior hash 1) key))) @@ -309,7 +330,8 @@ (guts (murmur-hash-word/fixnum key) %so-search/fixnum =)) (defun so-find/addr (table key) (declare (split-ordered-list table)) - (guts (funcall (so-hashfun table) key) %so-search/addr eq)) + (let ((h (multiplicative-hash (get-lisp-obj-address key)))) + (guts h %so-search/addr eq))) (defun so-find/string (table key) (declare (split-ordered-list table)) (declare (string key)) @@ -345,7 +367,7 @@ (setq node next)))))) (flet ((make (valuesp) - (%make-so-list #'murmur-hash-word/fixnum + (%make-so-list #'murmur-hash-word/+fixnum #'%so-insert/fixnum #'%so-delete/fixnum #'so-find/fixnum @@ -363,7 +385,7 @@ (defun make-so-map/string () (make t))) (flet ((make (valuesp) - (%make-so-list (lambda (x) (murmur-hash-word/+fixnum (get-lisp-obj-address x))) + (%make-so-list (lambda (x) (multiplicative-hash (get-lisp-obj-address x))) #'%so-insert/addr #'%so-delete/addr #'so-find/addr #'nofun #'nofun valuesp))) (defun make-so-set/addr () (make nil))