1 (setq *evaluator-mode
* :compile
)
2 (load "src/code/redblack.lisp")
3 (with-compilation-unit () (load "tests/test-util.lisp"))
5 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
6 (import 'sb-int
:dovector
))
8 (in-package "SB-RBTREE.WORD")
10 (sb-int:named-let recurse
((tree tree
))
13 (1+ (max (recurse (left tree
)) (recurse (right tree
)))))))
16 (in-package "SB-BROTHERTREE")
17 (defmacro binary-node-parts
(node)
19 (if (fringe-binary-node-p n
)
20 (values nil
(binary-node-key n
) nil
) ; has only one data slot
22 (values (binary-node-%left n
) (binary-node-key n
) (binary-node-%right n
)))))
23 (defun height (tree &aux
(n 0))
25 (unless tree
(return n
))
27 ;; We're assuming that the brothertree invariant holds-
28 ;; the left and right heights are the same.
30 (binary-node (setq tree
(values (binary-node-parts tree
))))
31 (unary-node (setq tree
(child tree
))))))
34 (in-package "CL-USER")
35 (defvar *brothertree
* nil
)
38 (defvar *hash-table
* nil
)
40 (defvar *lotta-strings
*
42 ;; Collect all pseudostatic symbols and all readonly strings
44 (sb-kernel:%make-lisp-obj
45 (logandc2 (sb-kernel:get-lisp-obj-address x
)
47 (nconc (sb-vm:list-allocated-objects
49 :type sb-vm
:symbol-widetag
50 :test
(lambda (x) (= (sb-kernel:generation-of x
)
51 sb-vm
:+pseudo-static-generation
+)))
52 (sb-vm:list-allocated-objects
54 :type sb-vm
:simple-base-string-widetag
)))
56 (declaim (simple-vector *lotta-strings
*))
58 (defun insert-all-brothertree ()
60 (dovector (str *lotta-strings
*)
61 (setq tree
(sb-brothertree:insert str tree
)))
62 (setq *brothertree
* tree
)))
64 (defun insert-all-redblack ()
66 (dovector (str *lotta-strings
*)
67 ;; because OF COURSE the arg orders are opposite
68 (setq tree
(sb-rbtree.word
:insert tree str
)))
69 (setq *rbtree
* tree
)))
71 (defun insert-all-solist ()
72 (let ((set (let ((sb-lockless::*desired-elts-per-bin
* 2))
73 (sb-lockless:make-so-set
/addr
))))
74 (dovector (str *lotta-strings
*)
75 (sb-lockless:so-insert set str
))
78 (defun insert-all-hash-table ()
79 (let ((set (make-hash-table :test
'eq
:synchronized t
)))
80 (dovector (str *lotta-strings
*)
81 (setf (gethash str set
) t
))
82 (setq *hash-table
* set
)))
84 (dolist (test '(insert-all-redblack insert-all-brothertree insert-all-solist insert-all-hash-table
))
86 (format t
"Running ~S~%" test
)
87 (time (funcall test
)))
89 (let ((n (length *lotta-strings
*)))
90 (format t
"~&Memory:~:{~% ~8a=~8D ~3,1f~}~%"
91 (loop for
(name . val
) in
`(("brother" .
,*brothertree
*)
92 ("redblack" .
,*rbtree
*)
93 ("solist" .
,*solist
*)
94 ("hashtbl " .
,*hash-table
*))
96 (let ((mem (test-util:deep-size val
)))
97 (list name mem
(/ mem n
))))))
99 (format t
"~&Tree heights: redblack=~D brother=~D~2%"
100 (sb-rbtree.word
::height
*rbtree
*)
101 (sb-brothertree::height
*brothertree
*))
103 (macrolet ((exercise (find-it)
105 (:up
(loop for str across
*lotta-strings
*
107 (:down
(let ((v *lotta-strings
*))
108 (loop for i downfrom
(1- (length v
)) to
0
109 count
(let ((str (svref v i
))) ,find-it
)))))))
110 (defun find-all-in-brothertree (&optional
(direction :up
) &aux
(tree *brothertree
*))
111 (exercise (sb-brothertree:find
= str tree
)))
112 (defun find-all-in-redblack-tree (&optional
(direction :up
) &aux
(tree *rbtree
*))
113 (exercise (sb-rbtree.word
:find
= str tree
)))
114 (defun find-all-in-solist (&optional
(direction :up
) &aux
(set *solist
*))
115 (exercise (sb-lockless:so-find set str
)))
116 (defun find-all-in-hash-table (&optional
(direction :up
) &aux
(set *hash-table
*))
117 (exercise (gethash str set
))))
119 ;;; Each test will run *nthreads* threads and each thread will find each item.
120 (defvar *start-sem
* (sb-thread:make-semaphore
))
121 (defvar *completion-sem
* (sb-thread:make-semaphore
))
122 (defvar *function-to-run
* nil
)
123 (defglobal *results
* nil
)
125 (declare (simple-base-string s
))
126 (sb-sys:with-pinned-objects
(s)
127 ;; avoid interleaved output, usually
128 (sb-unix:unix-write
2 s
0 (length s
))))
130 (defmacro with-cycle-counter
(form)
131 `(multiple-value-bind (hi0 lo0
) (sb-vm::%read-cycle-counter
)
133 (multiple-value-bind (hi1 lo1
) (sb-vm::%read-cycle-counter
)
134 (+ (ash (- hi1 hi0
) 32) (- lo1 lo0
))))))
136 (defun workfun (my-index)
137 (let ((direction-to-scan (if (oddp my-index
) :up
:down
)))
138 (loop ; (say (format nil "thread ~d waiting~%" my-index))
139 (sb-thread:wait-on-semaphore
*start-sem
*)
140 ; (say (format nil "thread ~d starting function under test~%" my-index))
141 (let ((test-fun *function-to-run
*))
142 (when (null test-fun
)
143 ;(say (format nil "thread ~d exiting~%" my-index))
145 ;(say (format nil "thread ~d working~%" my-index))
146 (multiple-value-bind (answer cycle-time
)
147 (with-cycle-counter (funcall test-fun direction-to-scan
))
148 (assert (= answer
(length *lotta-strings
*)))
149 (sb-ext:atomic-push cycle-time
*results
*))
150 (sb-thread:signal-semaphore
*completion-sem
*)))))
152 (defun perform-work-in-threads (test nthreads
)
153 (setf *function-to-run
* test
155 (sb-thread:signal-semaphore
*start-sem
* nthreads
)
156 (sb-thread:wait-on-semaphore
*completion-sem
* :n nthreads
))
158 (defvar *find-tests
* '(find-all-in-brothertree find-all-in-redblack-tree
159 find-all-in-solist find-all-in-hash-table
))
161 (defun test-nthreads (&optional
(nthreads 6))
162 (let ((threads (make-array nthreads
)))
163 (dotimes (i nthreads
)
164 (setf (aref threads i
) (sb-thread:make-thread
#'workfun
:arguments
(list i
))))
165 (dolist (test *find-tests
*)
166 (format t
"~&Testing ~S~%" test
)
167 (time (perform-work-in-threads test nthreads
))
168 (let* ((cycle-times *results
*)
169 (min (reduce #'min cycle-times
))
170 (max (reduce #'max cycle-times
))
171 (sum (reduce #'+ cycle-times
)))
172 (format t
" ==> min=~E max=~E avg=~E~2%"
173 min max
(/ sum nthreads
))))
174 (setq *function-to-run
* nil
)
175 (sb-thread:signal-semaphore
*start-sem
* nthreads
)
176 (map nil
#'sb-thread
:join-thread threads
)))
179 * (load"benchmarks/bbtrees")
181 0.012 seconds of real time
182 0.012138 seconds of total run time
(0.012086 user
, 0.000052 system
)
184 29,126,552 processor cycles
185 21,916,768 bytes consed
188 0.007 seconds of real time
189 0.007634 seconds of total run time
(0.007550 user
, 0.000084 system
)
191 18,334,338 processor cycles
192 18,640,080 bytes consed
194 Tree heights
: redblack
=25 brother
=16