-;;; $Id: string-dict-perf-test.lisp,v 1.2 2012/09/24 06:44:24 mmondor Exp $
+;;; $Id: string-dict-perf-test.lisp,v 1.3 2014/07/13 17:12:17 mmondor Exp $
;;; Verify the performance of various sized hash tables, alists, plists
;;; and vectors for key-value storage. Also test versus DO-SXHASH-CASE.
;;; Also verify the time taken to populate the content, not only look it
;;; up. Use random words from a dictionary file for both key and content.
+;;; Does not test sorted set variants.
(declaim (optimize (speed 3) (safety 0) (debug 0)))
key)))
(getf plist the-key)))
+(defun plist-iterate (plist)
+ (loop
+ for (key val) on plist by #'cddr)
+ nil)
+
+(defun plist-copy (plist)
+ (copy-list plist))
+
+(defun plist-remove (plist key)
+ (let ((the-key (if (stringp key)
+ (intern (string-upcase key) :keyword)
+ key)))
+ (remf plist the-key)
+ plist))
+
;;; Old-style AList
(cdr pair)
nil)))
+(defun alist-iterate (alist)
+ (loop
+ for (key . val) in alist)
+ nil)
+
+(defun alist-copy (alist)
+ (copy-alist alist))
+
+(defun alist-remove (alist key)
+ (delete (assoc key alist :test #'string-equal) alist))
+
;;; Vector used instead of a list, holding PAIR objects.
value)
(defun vector-populate (data)
+ (declare (optimize (speed 3) (safety 0) (debug 0)))
(loop
with length = (length (data-vector data))
- with vector = (make-array length)
+ with vector = (make-array length :fill-pointer length)
with alist = (data-alist data)
for (key . val) in alist
for i of-type fixnum from 0
(return-from vector-lookup (pair-value pair)))
nil)
+(defun vector-iterate (vector)
+ (loop
+ for pair across vector)
+ nil)
-;;; Famous hash-table, generally used a lot for this kind of problem.
+(defun vector-copy (vector)
+ (declare (optimize (speed 3) (safety 0) (debug 0)))
+ (let ((length (length vector)))
+ (declare (type fixnum length))
+ (make-array length
+ :fill-pointer length
+ :initial-contents vector)))
+
+(defun vector-remove (vector key)
+ (declare (optimize (speed 3) (safety 0) (debug 0)))
+ (let* ((length (length vector))
+ (last (1- length)))
+ (declare (type fixnum length last))
+ (when (zerop length)
+ (return-from vector-remove vector))
+ (let ((i (loop
+ for i of-type fixnum from 0
+ for pair across vector
+ for match = (string-equal (pair-key pair) key)
+ until match
+ finally (return (if match i -1)))))
+ (declare (type fixnum i))
+ (when (= -1 i)
+ (return-from vector-remove vector))
+ ;; Match, swap last entry with matched index and decrease fill-pointer
+ (unless (= last i)
+ (psetf (aref vector last) (aref vector i)
+ (aref vector i) (aref vector last)))
+ (setf (fill-pointer vector) last)
+ vector)))
+
+
+;;; Hash-table, generally used for this kind of problem.
(defun hashtable-populate (data)
(loop
(defun hashtable-lookup (table key)
(gethash key table))
+(defun hashtable-iterate (table)
+ (loop
+ for key being each hash-key of table using (hash-value value))
+ nil)
+
+(defun hashtable-copy (table)
+ (declare (optimize (speed 3) (safety 0) (debug 0)))
+ (loop
+ with newtable = (make-hash-table :test #'equalp)
+ for key being each hash-key of table using (hash-value value)
+ do
+ (setf (gethash key newtable) value)
+ finally (return newtable)))
+
+(defun hashtable-remove (table key)
+ (remhash key table)
+ table)
+
+
+#|
;;; Special system which creates a compiled-function of inline unrolled
;;; code instead of iteration. Very slow population, faster than usual
;;; iteration but still O(n). Uses SXHASH to compare FIXNUMs instead of
-;;; strings.
+;;; strings. Errors in case a collision happens at compile-time.
(defmacro do-sxhash-case ((var) match-code-pairs)
(let ((var-hash (gensym)))
(defun sxhashcase-lookup (function key)
(funcall function key))
+;;; Just call the lookup function with an unlikely to match string
+(defun sxhashcase-iterate (function)
+ (funcall function "1357198437518"))
+
+;;; Irrelevant, would require recompilation
+(defun sxhashcase-copy (function)
+ function)
+
+;;; Irrelevant, would require recompilation
+(defun sxhashcase-remove (function)
+ function)
+
+|#
+
;;; Similar to the above in that this system uses SXHASH instead of string
;;; comparisons, but O(n) iteration using an AList of fixnum/value pairs.
+;;; XXX Should error if collision
(defun sxhashalist-populate (data)
(loop
(cdr pair)
nil)))
+(defun sxhashalist-iterate (alist)
+ (loop
+ for (key . val) in alist)
+ nil)
+
+(defun sxhashalist-copy (alist)
+ (copy-alist alist))
+
+(defun sxhashalist-remove (alist key)
+ (delete (assoc (sxhash (string-downcase key)) alist :test #'=) alist))
+
;;; Similar to the above in that this system uses SXHASH instead of string
;;; comparisons, but O(n) iteration using a PList of fixnum/value pairs.
+;;; XXX Should error if collision
(defun sxhashplist-populate (data)
(loop
(defun sxhashplist-lookup (plist key)
(getf plist (sxhash (string-downcase key))))
+(defun sxhashplist-iterate (plist)
+ (loop
+ for (key val) on plist by #'cddr)
+ nil)
+
+(defun sxhashplist-copy (plist)
+ (copy-list plist))
+
+(defun sxhashplist-remove (plist key)
+ (remf plist (sxhash (string-downcase key)))
+ plist)
+
;;; Permits to calculate elapsed ticks when executing BODY.
;;; The number of elapsed ticks is in *REAL-TICKS* afterwards.
;;; Directory of above systems to test
-(defstruct (system (:constructor make-system (name populate lookup)))
- name populate lookup)
+(defstruct (system (:constructor make-system
+ (name populate lookup iterate copy remove)))
+ name populate lookup iterate copy remove)
(defparameter *systems*
- (list (make-system "plist" #'plist-populate #'plist-lookup)
- (make-system "alist" #'alist-populate #'alist-lookup)
- (make-system "vector" #'vector-populate #'vector-lookup)
- (make-system "hash-table" #'hashtable-populate #'hashtable-lookup)
+ (list (make-system "plist" #'plist-populate #'plist-lookup #'plist-iterate
+ #'plist-copy #'plist-remove)
+ (make-system "alist" #'alist-populate #'alist-lookup #'alist-iterate
+ #'alist-copy #'alist-remove)
+ (make-system "vector" #'vector-populate #'vector-lookup
+ #'vector-iterate #'vector-copy #'vector-remove)
+ (make-system "hash-table" #'hashtable-populate #'hashtable-lookup
+ #'hashtable-iterate #'hashtable-copy #'hashtable-remove)
; XXX Way too slow to populate COUNT times, also "cheating" compared
; to iteration as it results in inline unrolled comparison code.
; (make-system "sxhash-case" #'sxhashcase-populate
-; #'sxhashcase-lookup)
+; #'sxhashcase-lookup #'sxhashcase-iterate
+; #'sxhashcase-copy #'sxhashcase-remove)
(make-system "sxhash-alist" #'sxhashalist-populate
- #'sxhashalist-lookup)
+ #'sxhashalist-lookup #'sxhashalist-iterate
+ #'sxhashalist-copy #'sxhashalist-remove)
(make-system "sxhash-plist" #'sxhashplist-populate
- #'sxhashplist-lookup)))
+ #'sxhashplist-lookup #'sxhashplist-iterate
+ #'sxhashplist-copy #'sxhashplist-remove)))
;;; Test every system above, iterating COUNT times for every subtest and
(declare (type fixnum size count))
(with-accessors ((name system-name)
(populate system-populate)
- (lookup system-lookup)) system
+ (lookup system-lookup)
+ (iterate system-iterate)
+ (copy system-copy)
+ (remove system-remove)) system
(let* ((data (word-pairs size))
(dict (with-real-ticks
(loop
repeat count
for dict = (funcall populate data)
finally (return dict))))
- (populate-ticks *real-ticks*))
- (with-real-ticks
- (loop
- with vector = (data-vector data)
- repeat count
- for key = (svref vector (random size))
- do
- (funcall lookup dict key)))
- (let ((lookup-match-ticks *real-ticks*))
+ (populate-ticks *real-ticks*)
+ (iterate-ticks (progn
+ (with-real-ticks
+ (loop
+ repeat count
+ do
+ (funcall iterate dict)))
+ *real-ticks*))
+ lookup-match-ticks
+ lookup-miss-ticks
+ copy-ticks
+ remove-ticks)
+ (progn
+ (with-real-ticks
+ (loop
+ with vector = (data-vector data)
+ repeat count
+ for key = (svref vector (random size))
+ do
+ (funcall lookup dict key)))
+ (setf lookup-match-ticks *real-ticks*))
+ (progn
(with-real-ticks
(loop
repeat count
do
(funcall lookup dict "worijworjgowirjgw")))
- (let ((lookup-miss-ticks *real-ticks*))
- (format t
- "~&Type: ~A, Size: ~D, Populate: ~D, Lookup-match: ~D, Lookup-miss: ~D~%"
- name size
- populate-ticks lookup-match-ticks lookup-miss-ticks))))))
+ (setf lookup-miss-ticks *real-ticks*))
+ (let ((copies
+ (prog1
+ (with-real-ticks
+ (loop
+ repeat count
+ collect (funcall copy dict)))
+ (setf copy-ticks *real-ticks*))))
+ (with-real-ticks
+ (loop
+ with vector = (data-vector data)
+ repeat count
+ for key = (svref vector (random size))
+ for dict in copies
+ do
+ (setf dict (funcall remove dict key))))
+ (setf remove-ticks *real-ticks*))
+ (format t
+ "~&Type: ~A, Size: ~D, Populate: ~D, Lookup-match: ~D, ~
+ Lookup-miss: ~D, Iterate: ~D, Copy: ~D, Remove: ~D~%"
+ name size
+ populate-ticks lookup-match-ticks lookup-miss-ticks
+ iterate-ticks copy-ticks remove-ticks))))
Repositories / mmondor.git / commitdiff