Update of /project/cl-store/cvsroot/cl-store
In directory clnet:/tmp/cvs-serv13298
Modified Files:
ChangeLog circularities.lisp package.lisp plumbing.lisp
tests.lisp utils.lisp
Log Message:
Changelog 2007-01-22
--- /project/cl-store/cvsroot/cl-store/ChangeLog 2006/12/17 00:11:09 1.45
+++ /project/cl-store/cvsroot/cl-store/ChangeLog 2007/01/22 17:59:20 1.46
@@ -1,3 +1,13 @@
+2007-01-22 Sean Ross <sross(a)common-lisp.net>
+ * utils.lisp, circularities.lisp, tests.lisp
+ * stop store-32-bit from creating an intermediary object
+ which reduces the consing (on at least Lispworks 5.0 and SBCL 'Kitten of Death').
+ * export 4 new symbols which allows more efficient serialization of values.
+ create-serialize-hash, with-grouped-serialization, *grouped-store-hash*
+ and *grouped-restore-hash*.
+ * conditionalize some forms which were preventing ABCL from running the tests.
+ *
+
2006-12-16 Sean Ross <sross(a)common-lisp.net>
* circularities.lisp: Bug fix from Alex Mizrahi. Change *restored-values*
to use eql as the hash test.
--- /project/cl-store/cvsroot/cl-store/circularities.lisp 2006/12/17 00:11:09 1.25
+++ /project/cl-store/cvsroot/cl-store/circularities.lisp 2007/01/22 17:59:20 1.26
@@ -99,13 +99,37 @@
(defvar *store-hash-size* 50)
+(defvar *grouped-store-hash*)
+(defvar *grouped-restore-hash*)
+
+(defun create-serialize-hash ()
+ (make-hash-table :test #'eql :size *store-hash-size*))
+
+(defmacro with-grouped-serialization (() &body body)
+ `(let ((*grouped-store-hash* (create-serialize-hash))
+ (*grouped-restore-hash* (create-serialize-hash)))
+ ,@body))
+
+(defun get-store-hash ()
+ (when *check-for-circs*
+ (if (boundp '*grouped-store-hash*)
+ (clrhash *grouped-store-hash*)
+ (create-serialize-hash))))
+
+(defun get-restore-hash ()
+ (when *check-for-circs*
+ (if (boundp '*grouped-restore-hash*)
+ (clrhash *grouped-restore-hash*)
+ (create-serialize-hash))))
+
+(defmethod backend-store :around ((backend resolving-backend) (place t) (obj t))
+ (call-next-method))
(defmethod backend-store ((backend resolving-backend) (place stream) (obj t))
"Store OBJ into PLACE. Does the setup for counters and seen values."
(declare (optimize speed (safety 1) (debug 0)))
(let ((*stored-counter* 0)
- (*stored-values* (and *check-for-circs*
- (make-hash-table :test #'eq :size *store-hash-size*))))
+ (*stored-values* (get-store-hash)))
(store-backend-code backend place)
(backend-store-object backend obj place)
obj))
@@ -166,9 +190,7 @@
various variables used by resolving-object."
(let ((*restore-counter* 0)
(*need-to-fix* nil)
- (*restored-values* (and *check-for-circs*
- (make-hash-table :test #'eql
- :size *restore-hash-size*))))
+ (*restored-values* (get-restore-hash)))
(check-magic-number backend place)
(prog1
(backend-restore-object backend place)
--- /project/cl-store/cvsroot/cl-store/package.lisp 2006/08/03 19:42:09 1.24
+++ /project/cl-store/cvsroot/cl-store/package.lisp 2007/01/22 17:59:20 1.25
@@ -25,7 +25,12 @@
#:store-32-bit #:read-32-bit #:*check-for-circs*
#:*store-hash-size* #:*restore-hash-size* #:get-slot-details
#:*store-used-packages* #:*nuke-existing-packages*
- #:serializable-slots-using-class)
+ #:serializable-slots-using-class
+
+ ;; Hooks into lower level circularity tracking
+ ;; to reduce consing.
+ #:with-grouped-serialization #:create-serialize-hash
+ #:*grouped-store-hash* #:*grouped-restore-hash*)
#+sbcl (:import-from #:sb-mop
#:generic-function-name
@@ -53,7 +58,7 @@
#:class-direct-superclasses
#:class-slots
#:ensure-class)
-
+
#+cmu (:import-from #:pcl
#:generic-function-name
#:slot-definition-name
--- /project/cl-store/cvsroot/cl-store/plumbing.lisp 2005/11/30 09:49:56 1.19
+++ /project/cl-store/cvsroot/cl-store/plumbing.lisp 2007/01/22 17:59:20 1.20
@@ -102,7 +102,7 @@
(declare (optimize speed))
(when-let (magic (magic-number backend))
(store-32-bit magic stream)))
- (:documentation
+ (:documentation
"Store magic-number of BACKEND, when present, into STREAM."))
(declaim (inline store-object))
--- /project/cl-store/cvsroot/cl-store/tests.lisp 2006/12/14 18:15:41 1.29
+++ /project/cl-store/cvsroot/cl-store/tests.lisp 2007/01/22 17:59:20 1.30
@@ -522,7 +522,7 @@
(foo1-a (foo1-a (foo1-a ret)))))))
t)
-
+#-abcl
(deftest circ.14 (let ((list '#1=(1 2 3 #1# . #1#)))
(store list *test-file*)
(let ((ret (restore *test-file*)))
@@ -533,6 +533,7 @@
+#-abcl
(deftest circ.15 (let ((list '#1=(1 2 3 #2=(#2#) . #1#)))
(store list *test-file*)
(let ((ret (restore *test-file*)))
@@ -546,6 +547,7 @@
;; this had me confused for a while since what was
;; restored #1=(1 (#1#) #1#) looks nothing like this list,
;; but it turns out that it is correct
+#-abcl
(deftest circ.16 (let ((list '#1=(1 #2=(#1#) . #2#)))
(store list *test-file*)
(let ((ret (restore *test-file*)))
@@ -641,6 +643,19 @@
(f-x new-obj) (f-y new-obj) (f-z new-obj)))))
(t t t 3 2 "Z"))
+
+
+(deftest grouped-serialization
+ (with-grouped-serialization ()
+ (with-open-file (outs *test-file* :element-type '(unsigned-byte 8)
+ :if-exists :supersede :direction :output)
+ (dotimes (x 100)
+ (cl-store:store x outs)))
+ (with-open-file (outs *test-file* :element-type '(unsigned-byte 8)
+ :if-exists :supersede)
+ (loop :repeat 100 :collect (cl-store:restore outs))))
+ #.(loop :for x :below 100 :collect x))
+
(defun run-tests (backend)
(with-backend backend
(regression-test:do-tests))
--- /project/cl-store/cvsroot/cl-store/utils.lisp 2006/12/16 13:50:26 1.25
+++ /project/cl-store/cvsroot/cl-store/utils.lisp 2007/01/22 17:59:20 1.26
@@ -12,7 +12,6 @@
`(let ,(mapcar #'(lambda (x) `(,x (gensym))) names)
,@body))
-#-abcl
(defgeneric serializable-slots (object)
(declare (optimize speed))
(:documentation
@@ -29,7 +28,7 @@
; unfortunately the metaclass of conditions in sbcl and cmu
; are not standard-class
-#-abcl
+
(defgeneric serializable-slots-using-class (object class)
(declare (optimize speed))
(:documentation "Return a list of slot-definitions to serialize.
@@ -110,18 +109,15 @@
(deftype array-tot-size ()
"The maximum total size of an array"
`(integer 0 , array-total-size-limit))
-
-
(defun store-32-bit (obj stream)
"Write OBJ down STREAM as a 32 bit integer."
(declare (optimize speed (debug 0) (safety 0))
- (type sb32 obj))
- (let ((obj (logand #XFFFFFFFF obj)))
+ (type ub32 obj))
(write-byte (ldb (byte 8 0) obj) stream)
(write-byte (ldb (byte 8 8) obj) stream)
(write-byte (ldb (byte 8 16) obj) stream)
- (write-byte (+ 0 (ldb (byte 8 24) obj)) stream)))
+ (write-byte (+ 0 (ldb (byte 8 24) obj)) stream))
(defmacro make-ub32 (a b c d)
`(the ub32 (logior (ash ,a 24) (ash ,b 16) (ash ,c 8) ,d)))
