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)
