From sross at common-lisp.net Mon Jan 22 17:59:21 2007 From: sross at common-lisp.net (sross) Date: Mon, 22 Jan 2007 12:59:21 -0500 (EST) Subject: [cl-store-cvs] CVS cl-store Message-ID: <20070122175921.1F84C1A09B@common-lisp.net> 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 + * 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 * 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))) + , at 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) , at 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))) From sross at common-lisp.net Tue Jan 23 15:37:17 2007 From: sross at common-lisp.net (sross) Date: Tue, 23 Jan 2007 10:37:17 -0500 (EST) Subject: [cl-store-cvs] CVS cl-store Message-ID: <20070123153717.5567324053@common-lisp.net> Update of /project/cl-store/cvsroot/cl-store In directory clnet:/tmp/cvs-serv5685 Modified Files: ChangeLog circularities.lisp cl-store.asd default-backend.lisp package.lisp tests.lisp Log Message: Changelog 2007-01-23 --- /project/cl-store/cvsroot/cl-store/ChangeLog 2007/01/22 17:59:20 1.46 +++ /project/cl-store/cvsroot/cl-store/ChangeLog 2007/01/23 15:37:17 1.47 @@ -1,3 +1,9 @@ +2007-01-23 Sean Ross + * circularities.lisp: Renamed with-grouped-serialization to with-serialization-unit + and added two keyword args to allow removal of *grouped-restore-hash* and + *grouped-store-hash* special vars as exported symbols. + * default-backend.lisp: Changed defvars of register-types to defparameters. + 2007-01-22 Sean Ross * utils.lisp, circularities.lisp, tests.lisp * stop store-32-bit from creating an intermediary object @@ -6,7 +12,7 @@ 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 * circularities.lisp: Bug fix from Alex Mizrahi. Change *restored-values* --- /project/cl-store/cvsroot/cl-store/circularities.lisp 2007/01/22 17:59:20 1.26 +++ /project/cl-store/cvsroot/cl-store/circularities.lisp 2007/01/23 15:37:17 1.27 @@ -105,9 +105,14 @@ (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))) +(defmacro with-serialization-unit ((&key store-hash restore-hash) + &body body) + "Executes body in a single serialization unit allowing various internal data +structures to be reused. +The keys store-hash and restore-hash are expected to be either nil or +hash-tables as produced by the function create-serialize-hash." + `(let ((*grouped-store-hash* (or ,store-hash (create-serialize-hash))) + (*grouped-restore-hash* (or ,restore-hash (create-serialize-hash)))) , at body)) (defun get-store-hash () --- /project/cl-store/cvsroot/cl-store/cl-store.asd 2006/12/16 13:55:00 1.42 +++ /project/cl-store/cvsroot/cl-store/cl-store.asd 2007/01/23 15:37:17 1.43 @@ -45,7 +45,7 @@ :name "CL-STORE" :author "Sean Ross " :maintainer "Sean Ross " - :version "0.7.6" + :version "0.7.9" :description "Serialization package" :long-description "Portable CL Package to serialize data" :licence "MIT" --- /project/cl-store/cvsroot/cl-store/default-backend.lisp 2006/12/14 18:15:41 1.37 +++ /project/cl-store/cvsroot/cl-store/default-backend.lisp 2007/01/23 15:37:17 1.38 @@ -22,42 +22,42 @@ ;; Type code constants -(defvar +referrer-code+ (register-code 1 'referrer)) -(defvar +special-float-code+ (register-code 2 'special-float)) -(defvar +unicode-string-code+ (register-code 3 'unicode-string)) -(defvar +integer-code+ (register-code 4 'integer)) -(defvar +simple-string-code+ (register-code 5 'simple-string)) -(defvar +float-code+ (register-code 6 'float)) -(defvar +ratio-code+ (register-code 7 'ratio)) -(defvar +character-code+ (register-code 8 'character)) -(defvar +complex-code+ (register-code 9 'complex)) -(defvar +symbol-code+ (register-code 10 'symbol)) -(defvar +cons-code+ (register-code 11 'cons)) -(defvar +pathname-code+ (register-code 12 'pathname)) -(defvar +hash-table-code+ (register-code 13 'hash-table)) -(defvar +standard-object-code+ (register-code 14 'standard-object)) -(defvar +condition-code+ (register-code 15 'condition)) -(defvar +structure-object-code+ (register-code 16 'structure-object)) -(defvar +standard-class-code+ (register-code 17 'standard-class)) -(defvar +built-in-class-code+ (register-code 18 'built-in-class)) -(defvar +array-code+ (register-code 19 'array)) -(defvar +simple-vector-code+ (register-code 20 'simple-vector)) -(defvar +package-code+ (register-code 21 'package)) +(defparameter +referrer-code+ (register-code 1 'referrer)) +(defparameter +special-float-code+ (register-code 2 'special-float)) +(defparameter +unicode-string-code+ (register-code 3 'unicode-string)) +(defparameter +integer-code+ (register-code 4 'integer)) +(defparameter +simple-string-code+ (register-code 5 'simple-string)) +(defparameter +float-code+ (register-code 6 'float)) +(defparameter +ratio-code+ (register-code 7 'ratio)) +(defparameter +character-code+ (register-code 8 'character)) +(defparameter +complex-code+ (register-code 9 'complex)) +(defparameter +symbol-code+ (register-code 10 'symbol)) +(defparameter +cons-code+ (register-code 11 'cons)) +(defparameter +pathname-code+ (register-code 12 'pathname)) +(defparameter +hash-table-code+ (register-code 13 'hash-table)) +(defparameter +standard-object-code+ (register-code 14 'standard-object)) +(defparameter +condition-code+ (register-code 15 'condition)) +(defparameter +structure-object-code+ (register-code 16 'structure-object)) +(defparameter +standard-class-code+ (register-code 17 'standard-class)) +(defparameter +built-in-class-code+ (register-code 18 'built-in-class)) +(defparameter +array-code+ (register-code 19 'array)) +(defparameter +simple-vector-code+ (register-code 20 'simple-vector)) +(defparameter +package-code+ (register-code 21 'package)) ;; fast storing for 32 bit ints -(defvar +32-bit-integer-code+ (register-code 24 '32-bit-integer nil)) +(defparameter +32-bit-integer-code+ (register-code 24 '32-bit-integer)) -(defvar +function-code+ (register-code 26 'function nil)) -(defvar +gf-code+ (register-code 27 'generic-function nil)) +(defparameter +function-code+ (register-code 26 'function nil)) +(defparameter +gf-code+ (register-code 27 'generic-function nil)) ;; Used by SBCL and CMUCL. -(defvar +structure-class-code+ (register-code 28 'structure-class nil)) -(defvar +struct-def-code+ (register-code 29 'struct-def nil)) +(defparameter +structure-class-code+ (register-code 28 'structure-class nil)) +(defparameter +struct-def-code+ (register-code 29 'struct-def nil)) -(defvar +gensym-code+ (register-code 30 'gensym nil)) +(defparameter +gensym-code+ (register-code 30 'gensym nil)) -(defvar +unicode-base-string-code+ (register-code 34 'unicode-base-string nil)) -(defvar +simple-base-string-code+ (register-code 35 'simple-base-string nil)) +(defparameter +unicode-base-string-code+ (register-code 34 'unicode-base-string nil)) +(defparameter +simple-base-string-code+ (register-code 35 'simple-base-string nil)) ;; setups for type code mapping (defun output-type-code (code stream) @@ -216,7 +216,7 @@ (write-byte type stream) (return-from body))))) (multiple-value-setq (significand exponent sign) - (integer-decode-float obj)) + (integer-decode-float obj)) (output-type-code +float-code+ stream) (write-byte (float-type obj) stream) (store-object significand stream) --- /project/cl-store/cvsroot/cl-store/package.lisp 2007/01/22 17:59:20 1.25 +++ /project/cl-store/cvsroot/cl-store/package.lisp 2007/01/23 15:37:17 1.26 @@ -29,8 +29,7 @@ ;; Hooks into lower level circularity tracking ;; to reduce consing. - #:with-grouped-serialization #:create-serialize-hash - #:*grouped-store-hash* #:*grouped-restore-hash*) + #:with-serialization-unit #:create-serialize-hash) #+sbcl (:import-from #:sb-mop #:generic-function-name --- /project/cl-store/cvsroot/cl-store/tests.lisp 2007/01/22 17:59:20 1.30 +++ /project/cl-store/cvsroot/cl-store/tests.lisp 2007/01/23 15:37:17 1.31 @@ -573,7 +573,7 @@ ;; custom storing (defclass random-obj () ((size :accessor size :initarg :size))) -(defvar *random-obj-code* (register-code 100 'random-obj)) +(defparameter *random-obj-code* (register-code 100 'random-obj)) (defstore-cl-store (obj random-obj buff) (output-type-code *random-obj-code* buff) @@ -645,8 +645,8 @@ -(deftest grouped-serialization - (with-grouped-serialization () +(deftest serialization-unit.1 + (with-serialization-unit () (with-open-file (outs *test-file* :element-type '(unsigned-byte 8) :if-exists :supersede :direction :output) (dotimes (x 100) From sross at common-lisp.net Fri Jan 26 15:02:25 2007 From: sross at common-lisp.net (sross) Date: Fri, 26 Jan 2007 10:02:25 -0500 (EST) Subject: [cl-store-cvs] CVS cl-store Message-ID: <20070126150225.4ACC63C017@common-lisp.net> Update of /project/cl-store/cvsroot/cl-store In directory clnet:/tmp/cvs-serv25979 Modified Files: ChangeLog backends.lisp default-backend.lisp package.lisp tests.lisp Log Message: Changelog 2007-01-26 : Bug fix and alias-backend --- /project/cl-store/cvsroot/cl-store/ChangeLog 2007/01/23 15:37:17 1.47 +++ /project/cl-store/cvsroot/cl-store/ChangeLog 2007/01/26 15:02:24 1.48 @@ -1,3 +1,11 @@ +2007-01-26 Sean Ross + * default-backend.lisp : Checked in a fix for non sb32 integers, certain + large number numbers where incorrectly serialize. + Reported by Cyrus Harmon. + * plumbing.lisp: Added a new function alias-backend and alias the backend + 'cl-store:cl-store as :cl-store + + 2007-01-23 Sean Ross * circularities.lisp: Renamed with-grouped-serialization to with-serialization-unit and added two keyword args to allow removal of *grouped-restore-hash* and --- /project/cl-store/cvsroot/cl-store/backends.lisp 2006/12/14 18:15:41 1.14 +++ /project/cl-store/cvsroot/cl-store/backends.lisp 2007/01/26 15:02:24 1.15 @@ -111,6 +111,12 @@ (push (cons name instance) *registered-backends*)) instance)) +(defun alias-backend (old alias) + (let ((backend (find-backend old t))) + (pushnew (cons alias backend) *registered-backends* + :test #'equalp) + t)) + (defun get-class-form (name fields extends) `(defclass ,name ,extends ,fields --- /project/cl-store/cvsroot/cl-store/default-backend.lisp 2007/01/23 15:37:17 1.38 +++ /project/cl-store/cvsroot/cl-store/default-backend.lisp 2007/01/26 15:02:24 1.39 @@ -1,4 +1,4 @@ -;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +7;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;; See the file LICENCE for licence information. ;; The cl-store backend. @@ -117,9 +117,9 @@ (defun dump-int (obj stream) (declare (optimize speed (safety 0) (debug 0))) - (typecase obj + (etypecase obj ((unsigned-byte 8) (write-byte 1 stream) (write-byte obj stream)) - (t (write-byte 2 stream) (store-32-bit obj stream)))) + ((unsigned-byte 32) (write-byte 2 stream) (store-32-bit obj stream)))) (defun undump-int (stream) (declare (optimize speed (safety 0) (debug 0))) @@ -138,34 +138,45 @@ (funcall (if (zerop (the fixnum (read-byte stream))) #'+ #'-) (undump-int stream))) + +(defun num->bits (num ) + (loop for val = (abs num) then (ash val -8 ) + for count from 0 + until (zerop val) + collect (logand val #XFF) into bits + finally (return (values bits count)))) + (defun store-arbitrary-integer (obj stream) (declare (type integer obj) (stream stream) (optimize speed)) (output-type-code +integer-code+ stream) - (loop for n = (abs obj) then (ash n -32) - for counter from 0 - with collect = nil - until (zerop n) - do (push n collect) - finally (progn - (store-object (if (minusp obj) - (- counter) - counter) - stream) - (dolist (num collect) - (dump-int num stream))))) + (multiple-value-bind (bits count) (num->bits obj) + (store-object (if (minusp obj) (- count) count) + stream) + (dolist (x bits) (store-32-bit x stream)))) + (defrestore-cl-store (integer buff) (declare (optimize speed)) - (let ((count (restore-object buff)) - (result 0)) - (declare (type integer result count)) - (loop repeat (abs count) do - (setf result (the integer (+ (ash result 32) - (the ub32 (undump-int buff)))))) - (if (minusp count) - (- result) - result))) + (let ((count (restore-object buff))) + (loop repeat (abs count) + with sum = 0 + for pos from 0 by 8 + for bit = (read-32-bit buff nil) + finally (return (if (minusp count) (- sum) sum)) + :do + (incf sum (* bit (expt 2 pos)))))) + + + +(defun bits->num (bits) + (loop with sum = 0 + for pos from 0 by 8 + for bit in bits + finally (return sum) + :do (incf sum (* bit (expt 2 pos))))) + + ;; Floats (*special-floats* are setup in the custom.lisp files) @@ -191,6 +202,7 @@ ;; function (defun create-float-values (value &rest codes) "Returns a alist of special float to float code mappings." + (declare (ignore value codes)) nil) (defun setup-special-floats () --- /project/cl-store/cvsroot/cl-store/package.lisp 2007/01/23 15:37:17 1.26 +++ /project/cl-store/cvsroot/cl-store/package.lisp 2007/01/26 15:02:24 1.27 @@ -29,7 +29,9 @@ ;; Hooks into lower level circularity tracking ;; to reduce consing. - #:with-serialization-unit #:create-serialize-hash) + #:with-serialization-unit #:create-serialize-hash + + #:alias-backend) #+sbcl (:import-from #:sb-mop #:generic-function-name --- /project/cl-store/cvsroot/cl-store/tests.lisp 2007/01/23 15:37:17 1.31 +++ /project/cl-store/cvsroot/cl-store/tests.lisp 2007/01/26 15:02:25 1.32 @@ -28,6 +28,7 @@ (deftestit integer.4 -2322993) (deftestit integer.5 most-positive-fixnum) (deftestit integer.6 most-negative-fixnum) +(deftestit integer.7 #x100000000) ;; ratios (deftestit ratio.1 1/2) @@ -44,8 +45,8 @@ (deftestit complex.5 #C(-111 -1123)) (deftestit complex.6 #C(-11.2 -34.5)) -;; short floats +;; short floats ;; single-float (deftestit single-float.1 3244.32) @@ -664,4 +665,3 @@ ;; EOF -