diff --git a/benchmarks/bbtrees.lisp b/benchmarks/bbtrees.lisp index ecc5c1891..e716fdf0c 100644 --- a/benchmarks/bbtrees.lisp +++ b/benchmarks/bbtrees.lisp @@ -1,5 +1,6 @@ (setq *evaluator-mode* :compile) (load "src/code/redblack.lisp") +(with-compilation-unit () (load "tests/test-util.lisp")) (in-package "SB-RBTREE.WORD") (defun height (tree) @@ -30,6 +31,7 @@ (in-package "CL-USER") (defvar *brothertree* nil) (defvar *rbtree* nil) +(defvar *solist* nil) (defvar *lotta-strings* (mapcar (lambda (x) @@ -53,14 +55,49 @@ (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)) + (sb-lockless:make-so-set/addr)))) + (dolist (str *lotta-strings*) + (sb-lockless:so-insert set str)) + (setq *solist* set))) + (gc) (time (insert-all-redblack)) (gc) (time (insert-all-brothertree)) -(format t "~&Tree heights: redblack=~D brother=~D~%" +(gc) +(time (insert-all-solist)) +(let ((n (length *lotta-strings*))) + (format t "~&Memory:~:{~% ~8a=~8D ~3,1f~}~%" + (loop for (name . val) in `(("brother" . ,*brothertree*) + ("redblack" . ,*rbtree*) + ("solist" . ,*solist*)) + collect + (let ((mem (test-util:deep-size val))) + (list name mem (/ mem n)))))) + +(format t "~&Tree heights: redblack=~D brother=~D~2%" (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))) + +(find-all-in-brothertree) +(find-all-in-redblack-tree) +(find-all-in-solist) +(time (find-all-in-brothertree)) +(time (find-all-in-redblack-tree)) +(time (find-all-in-solist)) + #| * (load"benchmarks/bbtrees") Evaluation took: diff --git a/src/cold/exports.lisp b/src/cold/exports.lisp index 98657e33f..9c26e960f 100644 --- a/src/cold/exports.lisp +++ b/src/cold/exports.lisp @@ -3591,7 +3591,7 @@ package is deprecated in favour of SB-MOP.") (:use "CL" "SB-EXT" "SB-INT") (:documentation "internal: 1-2-Brother tree") (:shadow "DELETE") - (:export "INSERT" "DELETE")) + (:export "INSERT" "DELETE" "FIND<=" "FIND>=" "FIND=")) (defpackage* "SB-LOCKLESS" (:documentation "internal: lockfree lists") diff --git a/tests/do-refs.impure.lisp b/tests/do-refs.impure.lisp index 9290c76b3..2f1094e9f 100644 --- a/tests/do-refs.impure.lisp +++ b/tests/do-refs.impure.lisp @@ -144,40 +144,9 @@ (typep fin-fun 'closure) (typep d '(and integer (not (eql 0)))))))))) -;;; Compute size of OBJ including descendants. -;;; LEAFP specifies what object types to treat as not reaching -;;; any other object. You pretty much have to treat symbols -;;; as leaves, otherwise you reach a package and then the result -;;; just explodes to beyond the point of being useful. -;;; (It works, but might reach the entire heap) -;;; To turn this into an actual thing, we'd want to reduce the consing. -(defun deep-size (obj &optional (leafp (lambda (x) - (typep x '(or package symbol fdefn - function code-component - wrapper classoid))))) - (let ((worklist (list obj)) - (seen (make-hash-table :test 'eq)) - (tot-bytes 0)) - (setf (gethash obj seen) t) - (flet ((visit (thing) - (when (is-lisp-pointer (get-lisp-obj-address thing)) - (unless (or (funcall leafp thing) - (gethash thing seen)) - (push thing worklist) - (setf (gethash thing seen) t))))) - (loop - (unless worklist (return)) - (let ((x (pop worklist))) - (incf tot-bytes (primitive-object-size x)) - (do-referenced-object (x visit))))) - ;; Secondary values is number of visited objects not incl. original one. - (values tot-bytes - (1- (hash-table-count seen)) - seen))) - (test-util:with-test (:name :deep-sizer) (multiple-value-bind (tot-bytes n-kids) - (deep-size #(a b c d (e f) #*0101)) + (test-util:deep-size #(a b c d (e f) #*0101)) ;; 8 words for the vector ;; 4 words for 2 conses ;; 4 words for a bit-vector: header/length/bits/padding diff --git a/tests/test-util.lisp b/tests/test-util.lisp index bfa0f1025..16bfbbc14 100644 --- a/tests/test-util.lisp +++ b/tests/test-util.lisp @@ -12,6 +12,7 @@ #:type-specifiers-equal #:assert-tri-eq #:random-type + #:deep-size ;; thread tools #:*n-cpus* @@ -1006,3 +1007,34 @@ (defmacro deftest (name form &rest results) ; use SB-RT syntax `(test-util:with-test (:name ,(sb-int:keywordicate name)) (assert (equalp (multiple-value-list ,form) ',results)))) + +;;; Compute size of OBJ including descendants. +;;; LEAFP specifies what object types to treat as not reaching +;;; any other object. You pretty much have to treat symbols +;;; as leaves, otherwise you reach a package and then the result +;;; just explodes to beyond the point of being useful. +;;; (It works, but might reach the entire heap) +;;; To turn this into an actual thing, we'd want to reduce the consing. +(defun deep-size (obj &optional (leafp (lambda (x) + (typep x '(or package symbol sb-kernel:fdefn + function sb-kernel:code-component + sb-kernel:wrapper sb-kernel:classoid))))) + (let ((worklist (list obj)) + (seen (make-hash-table :test 'eq)) + (tot-bytes 0)) + (setf (gethash obj seen) t) + (flet ((visit (thing) + (when (sb-vm:is-lisp-pointer (sb-kernel:get-lisp-obj-address thing)) + (unless (or (funcall leafp thing) + (gethash thing seen)) + (push thing worklist) + (setf (gethash thing seen) t))))) + (loop + (unless worklist (return)) + (let ((x (pop worklist))) + (incf tot-bytes (primitive-object-size x)) + (sb-vm:do-referenced-object (x visit))))) + ;; Secondary values is number of visited objects not incl. original one. + (values tot-bytes + (1- (hash-table-count seen)) + seen)))