From: Matthew Mondor <mmondor@pulsar-zone.net>
Date: Sun, 13 Jul 2014 17:12:17 +0000 (+0000)
Subject: Add iterate, copy and remove operations
X-Git-Url: http://git.pulsar-zone.net/?a=commitdiff_plain;h=6d816a01be69386b738e4d3382c6cabd192df2a4;p=mmondor.git

Add iterate, copy and remove operations
---

diff --git a/mmsoftware/cl/test/string-dict-perf-test.lisp b/mmsoftware/cl/test/string-dict-perf-test.lisp
index 9eca8e2..f6ff24c 100644
--- a/mmsoftware/cl/test/string-dict-perf-test.lisp
+++ b/mmsoftware/cl/test/string-dict-perf-test.lisp
@@ -1,9 +1,10 @@
-;;; $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)))
 
@@ -68,6 +69,21 @@
 		     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
 
@@ -83,6 +99,17 @@
 	(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.
 
@@ -91,9 +118,10 @@
   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
@@ -108,8 +136,44 @@
        (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
@@ -123,11 +187,31 @@
 (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)))
@@ -167,9 +251,24 @@
 (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
@@ -183,9 +282,21 @@
 	(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
@@ -196,6 +307,18 @@
 (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.
@@ -214,22 +337,30 @@
 
 ;;; 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
@@ -255,29 +386,63 @@
   (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))))