Permalink
Browse files

Reduced overhead by 30% on 1mil exercise by eliminating unnecessary h…

…ashing; updated deterministic profile function and report
  • Loading branch information...
1 parent 7044c2f commit aca3b70d5c8ac44270c2787e283e68300772fad1 @danlentz committed Sep 5, 2012
Showing with 208 additions and 108 deletions.
  1. +1 −1 ctrie-doc.lisp
  2. +84 −7 ctrie-test.lisp
  3. +61 −49 ctrie.lisp
  4. +62 −51 readme.md
View
@@ -41,7 +41,7 @@
(setf (get 'readme :internal-marker) "* * * * * * *")
(setf (get 'readme :internal-ref)
- '(*ctrie* *retries* *timeout*
+ '(*ctrie* *retries* *timeout* *hash-code*
multi-catch catch-case
ctrie ctrie-p ctrie-hash ctrie-test ctrie-readonly-p cthash ctequal
with-ctrie flag flag-present-p flag-arc-position flag-vector
View
@@ -8,7 +8,11 @@
`(defpackage ,name
(:documentation ,docs)
(:use :closer-common-lisp :closer-mop :lisp-unit #+():lparallel ,@packages)
- (:export :run-ctrie-tests)
+ (:export
+ :run-ctrie-tests
+ :run-ctrie-benchmarks
+ :run-ctrie-deterministic-profile
+ :run-ctrie-statistical-profile)
,@(loop :for pkg :in packages :collect
`(:import-from ,pkg ,@(loop :for sym :being :the :symbols :in pkg
:collect (make-symbol (string sym))))))))
@@ -34,14 +38,31 @@
(values))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Table Abstraction Scaffolding
+;; Fixtures
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defvar *test-ctrie* (make-ctrie))
+(defvar *input* (shuffle (coerce (iota (expt 2 20)) 'vector)))
+(defvar *input-256k* (shuffle (coerce (iota (expt 2 18)) 'vector)))
+(defvar *kernels* (loop for i from 0 to 3
+ collect (lparallel:make-kernel (expt 2 i))))
+(defvar *table*)
+(defvar *table-type*)
+(defvar *table-test*)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Table Abstraction Scaffolding
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
(defmacro with-skiplist-tables (&body body)
`(flet ((make-table (&key (test #'eql))
- (cl-skip-list:make-skip-list :key-equal test :value-equal test))
+ (cl-skip-list:make-skip-list
+ :duplicates-allowed? t
+ :key-equal test
+ :value-equal test))
(table-clear (tbl)
(cl-skip-list:map-skip-list (lambda (k v)
(declare (ignore v))
@@ -576,20 +597,38 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Profiling
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(defun run-ctrie-deterministic-profile ()
+ (ctrie-clear *test-ctrie*)
+ (swank:profile-reset)
+ (swank:unprofile-all)
+ (swank:profile-package (find-package :cl-ctrie) t t)
+ (loop for i across *input* do (ctrie-put *test-ctrie* i i))
+ (assert (eql (ctrie-size *test-ctrie*) (length *input*)))
+ (loop for i across *input* do (ctrie-get *test-ctrie* i))
+ (loop for i across *input* do (ctrie-drop *test-ctrie* i))
+ (assert (ctrie-empty-p *test-ctrie*))
+ (swank:profile-report)
+ (swank:unprofile-all))
+
+
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Parallel Operation Tests
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defvar *test-ctrie* (make-ctrie))
-(defvar *input* (shuffle (coerce (iota (expt 2 20)) 'vector)))
-(defvar *kernels* (loop for i from 0 to 3
- collect (lparallel:make-kernel (expt 2 i))))
(defun end-kernels ()
(loop for kernel in *kernels*
do (let1 lparallel:*kernel* kernel
(lparallel:end-kernel :wait t))))
+
(define-test check-parallel-insert-parallel-lookup ()
(loop for kernel in *kernels* do
(let1 lparallel:*kernel* kernel
@@ -710,3 +749,41 @@
#'ctrie-lambda-ctrie)
(list c0 c1 c2)))))
(doit)))
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Benchmarking
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;(table-clear *table*)
+
+(defmacro try-bench-insert ()
+ `(progn
+; (defparameter *table* (make-table))
+; (defparameter *table-type* (type-of *table*))
+; (defparameter *table-test* :insert)
+ (loop for kernel in *kernels* do
+ (setf *table* (make-table))
+ (setf *table-type* (type-of *table*))
+ (setf *table-test* :insert)
+ collect (let1 lparallel:*kernel* kernel
+ (list*
+ :bench *table-test*
+ :type *table-type*
+ :threads (lparallel:kernel-worker-count)
+ (collate-timing
+ (with-timing-collected-runs (3)
+ (lparallel:pmap nil (lambda (i)
+ (table-put *table* i i))
+ *input*))))))))
+
+
+(defun benchmark-insert ()
+ ;; (declare (optimize (speed 3)))
+ ;; (sb-ext:gc)
+ (append
+ (print (with-hash-tables (try-bench-insert))) (terpri)
+ (print (with-ctrie-tables (try-bench-insert))) (terpri)
+ (print (with-skiplist-tables (try-bench-insert))) (terpri)))
+
View
@@ -14,6 +14,14 @@
binding, which is properly established by wrapping the operation in
an appropriate WITH-CTRIE form.")
+(defvar *hash-code* nil
+ "Special variable used to store the hash-code that corresponds to the
+ current operation. Used as a means of improving efficiency by eliminating
+ needless recomputation of the hash function, which is the most expensive
+ part of most user-level ctrie operations. If this value is not set, then
+ the hash will simply be computed on demand and processing will continue
+ unaffected. Use of this variable is simply an optional performace
+ optimization techniqie.")
(defparameter *retries* 16
"Establishes the number of restarts permitted to a CTRIE operation
@@ -156,15 +164,15 @@
- TAG is NIl if evaluation of the FORMS completed normally
or the tag thrown and cought.
* EXAMPLE:
- ```
- ;;; (multiple-value-bind (result tag)
- ;;; (multi-catch (:a :b)
- ;;; ...FORMS...)
- ;;; (case tag
- ;;; (:a ...)
- ;;; (:b ...)
- ;;; (t ...)))
- ```"
+ ```
+ ;;; (multiple-value-bind (result tag)
+ ;;; (multi-catch (:a :b)
+ ;;; ...FORMS...)
+ ;;; (case tag
+ ;;; (:a ...)
+ ;;; (:b ...)
+ ;;; (t ...)))
+ ```"
(let ((block-name (gensym)))
`(block ,block-name
,(multi-catch-1 block-name tag-list forms))))
@@ -220,14 +228,15 @@
(local-time:now))))
-(defun flag (key level)
+(defun flag (key level &optional use-cached-p)
"For a given depth, LEVEL, within a CTRIE, extract the correspondant
sequence of bits from the computed hash of KEY that indicate the
logical index of the arc on the path to which that key may be found.
Note that the logical index of the arc is most likely not the same
as the physical index where it is actually located -- for that see
`FLAG-ARC-POSITION`"
- (ash 1 (logand (ash (cthash key) (- level)) #x1f)))
+ (ash 1 (logand (ash (or (when use-cached-p *hash-code*) (cthash key))
+ (- level)) #x1f)))
(defun flag-present-p (flag bitmap)
@@ -840,7 +849,7 @@
(target-ref (inode-read target-inode)))
(when (cnode-p parent-ref)
(let* ((bmp (cnode-bitmap parent-ref))
- (flag (flag key level))
+ (flag (flag key level t))
(pos (flag-arc-position flag bmp)))
(when (and (flag-present-p flag bmp)
(tnode-p target-ref)
@@ -1391,7 +1400,7 @@
(CNODE (let* ((cnode it)
(bmp (cnode-bitmap cnode))
- (flag (flag key level))
+ (flag (flag key level t))
(pos (flag-arc-position flag bmp)))
;;;;;;;;;;;;;;;;;;;;;;;;
@@ -1474,18 +1483,19 @@
equality predicate defined by `CTRIE-TEST` then the priorbmapping
will be replaced by VALUE. Returns `VALUE` representing the
mapping in the resulting CTRIE"
- (with-ctrie ctrie
- (loop with d = 0 and p = nil and result
- for root = (root-node-access *ctrie*)
- when (catch-case (%insert root key value d p (inode-gen root))
- (:restart (prog1 nil
- (when *debug*
- (format *TRACE-OUTPUT* "~8A timeout insert (~A . ~A)~%"
- it key value))))
- (t (prog1 (setf result it)
- (when *debug*
- (format *TRACE-OUTPUT* "~8S done .~%~S~%" it *ctrie*)))))
- return result)))
+ (with-ctrie ctrie
+ (let1 *hash-code* (cthash key)
+ (loop with d = 0 and p = nil and result
+ for root = (root-node-access *ctrie*)
+ when (catch-case (%insert root key value d p (inode-gen root))
+ (:restart (prog1 nil
+ (when *debug*
+ (format *TRACE-OUTPUT* "~8A timeout insert (~A . ~A)~%"
+ it key value))))
+ (t (prog1 (setf result it)
+ (when *debug*
+ (format *TRACE-OUTPUT* "~8S done .~%~S~%" it *ctrie*)))))
+ return result))))
@@ -1519,7 +1529,7 @@
(throw :notfound node)))
(cnode (let* ((cnode node)
(bmp (cnode-bitmap cnode))
- (flag (flag key level))
+ (flag (flag key level t))
(pos (flag-arc-position flag bmp)))
(if (not (flag-present-p flag bmp))
(throw :notfound cnode)
@@ -1541,21 +1551,22 @@
associated value and T as multiple values, or returns NIL and NIL
if there is no such entry. Entries can be added using SETF."
(with-ctrie ctrie
- (flet ((attempt-get (root key level parent gen try)
- (declare (ignorable try))
- (catch-case (%lookup root key level parent gen)
- (:notfound (return-from ctrie-get (values nil nil)))
- (:restart (multiple-value-prog1 (values it nil)
- #+()(when *debug* (format t "~8s restarting after try ~d.~%"
- it try))))
- (t (multiple-value-prog1 (values it t)
- #+()(when *debug* (format t "~8s done on try ~d.~%"
- it try)))))))
- (loop with vals with d = 0 and p = nil
- for r = (root-node-access *ctrie*) for try from 1
- do (setf vals (multiple-value-list (attempt-get r key d p (inode-gen r) try)))
- when (> try 1000) do (error "try ~d" try)
- when (second vals) do (return-from ctrie-get (values (first vals) t))))))
+ (let1 *hash-code* (cthash key)
+ (flet ((attempt-get (root key level parent gen try)
+ (declare (ignorable try))
+ (catch-case (%lookup root key level parent gen)
+ (:notfound (return-from ctrie-get (values nil nil)))
+ (:restart (multiple-value-prog1 (values it nil)
+ #+()(when *debug* (format t "~8s restarting after try ~d.~%"
+ it try))))
+ (t (multiple-value-prog1 (values it t)
+ #+()(when *debug* (format t "~8s done on try ~d.~%"
+ it try)))))))
+ (loop with vals with d = 0 and p = nil
+ for r = (root-node-access *ctrie*) for try from 1
+ do (setf vals (multiple-value-list (attempt-get r key d p (inode-gen r) try)))
+ when (> try 1000) do (error "try ~d" try)
+ when (second vals) do (return-from ctrie-get (values (first vals) t)))))))
(defun (setf ctrie-get) (value ctrie key)
@@ -1580,7 +1591,7 @@
(values leaf-value t)
(values it :restart))))
(cnode (let* ((bmp (cnode-bitmap it))
- (flag (flag key level))
+ (flag (flag key level t))
(pos (flag-arc-position flag bmp)))
(if (not (flag-present-p flag bmp))
(values key :notfound)
@@ -1612,13 +1623,14 @@
"Remove KEY and it's associated value from CTRIE. Returns as multiple
values the value associated with KEY and T if there was such an entry,
otherewise NIL and NIL"
- (with-ctrie ctrie
- (let1 r (root-node-access *ctrie*)
- (multiple-value-bind (val kind) (%remove r key 0 nil (inode-gen r))
- (case kind
- (:restart (return-from ctrie-drop (ctrie-drop *ctrie* key)))
- (:notfound (values val nil))
- (t (values val t)))))))
+ (with-ctrie ctrie
+ (let ((r (root-node-access *ctrie*))
+ (*hash-code* (cthash key)))
+ (multiple-value-bind (val kind) (%remove r key 0 nil (inode-gen r))
+ (case kind
+ (:restart (return-from ctrie-drop (ctrie-drop *ctrie* key)))
+ (:notfound (values val nil))
+ (t (values val t)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Oops, something went wrong.

0 comments on commit aca3b70

Please sign in to comment.