common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Put DEEP-SIZE into test-util and use it in a benchmark

Browse source 
This shows a few things:
* S-O lists are terribly wasteful of memory, using about 8 words per key
  though producing very little garbage during construction.
* Balanced trees need about 3 words per key in the final tree,
  but produce lots of intermediate garbage.
* Red/Black can be faster at lookup than brother trees, probably because
  the latter requires a test of each node type before descending.
This commit is contained in:
Douglas Katzman 2023-02-07 23:33:27 -05:00
parent d8d11b9e8b
commit 916b4d346b
4 changed files with 72 additions and 34 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

39
benchmarks/bbtrees.lisp
View file

@ -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:

2
src/cold/exports.lisp
View file

@ -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")

33
tests/do-refs.impure.lisp
View file

@ -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

32
tests/test-util.lisp
View file

@ -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)))