[elephant-cvs] CVS elephant/src/elephant

[ieslick]

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 , at 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)