benchmarks/bbtrees.lisp

   1 (setq *evaluator-mode* :compile)
   2 (load "src/code/redblack.lisp")
   3 (with-compilation-unit () (load "tests/test-util.lisp"))
   4
   5 (eval-when (:compile-toplevel :load-toplevel :execute)
   6   (import 'sb-int:dovector))
   7
   8 (in-package "SB-RBTREE.WORD")
   9 (defun height (tree)
  10   (sb-int:named-let recurse ((tree tree))
  11     (if (not tree)
  12         0
  13         (1+ (max (recurse (left tree)) (recurse (right tree)))))))
  14 (compile 'height)
  15
  16 (in-package "SB-BROTHERTREE")
  17 (defmacro binary-node-parts (node)
  18   `(let ((n ,node))
  19      (if (fringe-binary-node-p n)
  20          (values nil (binary-node-key n) nil) ; has only one data slot
  21          ;; has left + right
  22          (values (binary-node-%left n) (binary-node-key n) (binary-node-%right n)))))
  23 (defun height (tree &aux (n 0))
  24   (loop
  25      (unless tree (return n))
  26      (incf n)
  27      ;; We're assuming that the brothertree invariant holds-
  28      ;; the left and right heights are the same.
  29      (typecase tree
  30        (binary-node (setq tree (values (binary-node-parts tree))))
  31        (unary-node  (setq tree (child tree))))))
  32 (compile 'height)
  33
  34 (in-package "CL-USER")
  35 (defvar *brothertree* nil)
  36 (defvar *rbtree* nil)
  37 (defvar *solist* nil)
  38 (defvar *hash-table* nil)
  39
  40 (defvar *lotta-strings*
  41   (coerce
  42    ;; Collect all pseudostatic symbols and all readonly strings
  43    (mapcar (lambda (x)
  44              (sb-kernel:%make-lisp-obj
  45               (logandc2 (sb-kernel:get-lisp-obj-address x)
  46                         sb-vm:lowtag-mask)))
  47            (nconc (sb-vm:list-allocated-objects
  48                    :dynamic
  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
  53                    :read-only
  54                    :type sb-vm:simple-base-string-widetag)))
  55    'vector))
  56 (declaim  (simple-vector *lotta-strings*))
  57
  58 (defun insert-all-brothertree ()
  59   (let ((tree nil))
  60     (dovector (str *lotta-strings*)
  61       (setq tree (sb-brothertree:insert str tree)))
  62     (setq *brothertree* tree)))
  63
  64 (defun insert-all-redblack ()
  65   (let ((tree nil))
  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)))
  70
  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))
  76     (setq *solist* set)))
  77
  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)))
  83
  84 (dolist (test '(insert-all-redblack insert-all-brothertree insert-all-solist insert-all-hash-table))
  85   (gc)
  86   (format t "Running ~S~%" test)
  87   (time (funcall test)))
  88
  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*))
  95                 collect
  96                 (let ((mem (test-util:deep-size val)))
  97                   (list name mem (/ mem n))))))
  98
  99 (format t "~&Tree heights: redblack=~D brother=~D~2%"
 100         (sb-rbtree.word::height *rbtree*)
 101         (sb-brothertree::height *brothertree*))
 102
 103 (macrolet ((exercise (find-it)
 104              `(ecase direction
 105                 (:up (loop for str across *lotta-strings*
 106                            count ,find-it))
 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))))
 118
 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)
 124 (defun say (s)
 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))))
 129
 130 (defmacro with-cycle-counter (form)
 131   `(multiple-value-bind (hi0 lo0) (sb-vm::%read-cycle-counter)
 132      (values ,form
 133              (multiple-value-bind (hi1 lo1) (sb-vm::%read-cycle-counter)
 134                (+ (ash (- hi1 hi0) 32) (- lo1 lo0))))))
 135
 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))
 144               (return))
 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*)))))
 151
 152 (defun perform-work-in-threads (test nthreads)
 153   (setf *function-to-run* test
 154         *results* nil)
 155   (sb-thread:signal-semaphore *start-sem* nthreads)
 156   (sb-thread:wait-on-semaphore *completion-sem* :n nthreads))
 157
 158 (defvar *find-tests* '(find-all-in-brothertree find-all-in-redblack-tree
 159                        find-all-in-solist find-all-in-hash-table))
 160
 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)))
 177
 178 #|
 179 * (load"benchmarks/bbtrees")
 180 Evaluation took:
 181   0.012 seconds of real time
 182   0.012138 seconds of total run time (0.012086 user, 0.000052 system)
 183   100.00% CPU
 184   29,126,552 processor cycles
 185   21,916,768 bytes consed
 186
 187 Evaluation took:
 188   0.007 seconds of real time
 189   0.007634 seconds of total run time (0.007550 user, 0.000084 system)
 190   114.29% CPU
 191   18,334,338 processor cycles
 192   18,640,080 bytes consed
 193
 194 Tree heights: redblack=25 brother=16
 195 |#