Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv6314
Modified Files: controller.lisp serializer.lisp Log Message: Bugfix in with-open-store
--- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/04/26 17:53:44 1.9 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/05/06 19:19:26 1.10 @@ -134,7 +134,7 @@ unconditionally closing the controller on exit." `(let ((*store-controller* nil)) (declare (special *store-controller*)) - (open-store spec) + (open-store ,spec) (unwind-protect (progn ,@body) (close-store *store-controller*)))) --- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2006/04/26 21:41:24 1.4 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2006/05/06 19:19:26 1.5 @@ -59,12 +59,22 @@ (defconstant +fill-pointer-p+ #x40) (defconstant +adjustable-p+ #x80)
+(defun clear-circularity-hash () + "This handles the case where we store an object with lots + of object references. CLRHASH then starts to dominate + performance as it has to visit ever spot in the table so + we're better off GCing the old table than clearing it" + (declare (optimize (speed 3) (safety 0))) + (if (> (hash-table-size *circularity-hash*) 100) + (setf *circularity-hash* (make-hash-table :test 'eq :size 50)) + (clrhash *circularity-hash*))) + (defun serialize (frob bs) "Serialize a lisp value into a buffer-stream." (declare (optimize (speed 3) (safety 0)) (type buffer-stream bs)) (setq *lisp-obj-id* 0) - (clrhash *circularity-hash*) + (clear-circularity-hash) (labels ((%serialize (frob) (declare (optimize (speed 3) (safety 0))) @@ -80,7 +90,7 @@ (buffer-write-byte #+(and allegro ics) (etypecase s - (base-string +ucs2-symbol+) ;; +ucs1-symbol+ + (base-string +ucs1-symbol+) ;; +ucs1-symbol+ (string +ucs2-symbol+)) #+(or (and sbcl sb-unicode) lispworks) (etypecase s @@ -100,7 +110,7 @@ (buffer-write-byte #+(and allegro ics) (etypecase frob - (base-string +ucs2-string+) ;; +ucs1-string+ + (base-string +ucs1-string+) ;; +ucs1-string+ (string +ucs2-string+)) #+(or (and sbcl sb-unicode) lispworks) (etypecase frob @@ -142,7 +152,7 @@ (buffer-write-byte #+(and allegro ics) (etypecase s - (base-string +ucs2-pathname+) ;; +ucs1-pathname+ + (base-string +ucs1-pathname+) ;; +ucs1-pathname+ (string +ucs2-pathname+)) #+(or (and sbcl sb-unicode) lispworks) (etypecase s @@ -302,9 +312,9 @@ (get-cached-instance sc (buffer-read-fixnum bs) (%deserialize bs))) - ((= tag +single-float+) + ((= tag +single-float+) (buffer-read-float bs)) - ((= tag +double-float+) + ((= tag +double-float+) (buffer-read-double bs)) ((= tag +char+) (code-char (buffer-read-uint bs))) @@ -407,7 +417,7 @@ (null (return-from deserialize nil)) (buffer-stream (setq *lisp-obj-id* 0) - (clrhash *circularity-hash*) + (clear-circularity-hash) (%deserialize buf-str)))))
(defun deserialize-bignum (bs length positive)