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@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@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)))