Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv14802/src/elephant
Modified Files: controller.lisp package.lisp serializer.lisp variables.lisp Log Message: Berkeley DB Backend upgrade & compact API fn, bug fixes
--- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/06/19 01:03:30 1.11 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/09/04 00:09:15 1.12 @@ -323,12 +323,19 @@ (:documentation "Provides a persistent source of unique id's"))
+(defgeneric optimize-storage ((sc store-controller) &allow-other-keys) + (:documentation + "Tell the backend to reclaim any storage caused by key deletion, if possible. + This should default to return space to the filesystem rather than just to the free list.")) + ;; Handling dbconnection specs
(defmethod close-controller :after ((sc store-controller)) "Delete connection spec so object ops on cached db info fail" (remhash (controller-spec sc) *dbconnection-spec*))
+ + ;; Low-level support for metaclass protocol
(defgeneric persistent-slot-reader (sc instance name) --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2006/04/26 17:53:44 1.1 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2006/09/04 00:09:15 1.2 @@ -31,7 +31,7 @@ #:store-controller #:open-store #:close-store #:with-open-store #:add-to-root #:get-from-root #:remove-from-root #:root-existsp - #:flush-instance-cache + #:flush-instance-cache #:optimize-storage
#:with-transaction #:start-ele-transaction #:commit-transaction #:abort-transaction --- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2006/07/21 16:32:45 1.9 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2006/09/04 00:09:15 1.10 @@ -14,7 +14,7 @@ ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;
-(in-package "ELEPHANT") +(in-package :elephant)
(declaim (inline int-byte-spec ;serialize deserialize @@ -55,6 +55,7 @@ (defconstant +hash-table+ 17) (defconstant +object+ 18) (defconstant +array+ 19) +(defconstant +struct+ 20)
(defconstant +fill-pointer-p+ #x40) (defconstant +adjustable-p+ #x80) @@ -62,21 +63,41 @@ (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 + performance as it has to visit every 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*)))
+(defvar *circularity-hash-queue* nil + "Circularity ids for the serializer.") + +(defvar *circularity-lock* + #+allegro (mp::make-process-lock)) + +(defun get-circularity-hash () + (if *circularity-hash-queue* + (#+allegro + mp::with-process-lock (*circularity-lock*) + (pop *circularity-hash-queue*)) + (make-hash-table :test 'eq :size 50))) + +(defun release-circularity-hash (hash) + (unless (> (hash-table-size hash) 100) + (clrhash hash) + (#+allegro + mp::with-process-lock (*circularity-lock*) + (push hash *circularity-hash-queue*)))) + (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) - (clear-circularity-hash) - (labels - ((%serialize (frob) + (let ((*lisp-obj-id* 0) + (*circularity-hash* (get-circularity-hash))) + (labels + ((%serialize (frob) (declare (optimize (speed 3) (safety 0))) (etypecase frob (fixnum @@ -89,6 +110,7 @@ (declare (type string s) (dynamic-extent s)) (buffer-write-byte #+(and allegro ics) +;; +ucs2-symbol+ (etypecase s (base-string +ucs1-symbol+) ;; +ucs1-symbol+ (string +ucs2-symbol+)) @@ -223,6 +245,19 @@ (%serialize (/ (length svs) 2)) (loop for item in svs do (%serialize item))))))) +;; (structure-object +;; (buffer-write-byte +struct+ bs) +;; (let ((idp (gethash frob *circularity-hash*))) +;; (if idp (buffer-write-int idp bs) +;; (progn +;; (buffer-write-int (incf *lisp-obj-id*) bs) +;; (setf (gethash frbo *circularity-hash*) *lisp-obj-id*) +;; (%serialize (type-of frob)) +;; (let ((svs (slots-and-values frob))) +;; (declare (dynamic-extent svs)) +;; (%serialize (/ (length svs) 2)) +;; (loop for item in svs +;; do (%serialize item))))))) (array (buffer-write-byte +array+ bs) (let ((idp (gethash frob *circularity-hash*))) @@ -249,7 +284,8 @@ (%serialize (row-major-aref frob i))))))) ))) (%serialize frob) - bs)) + (release-circularity-hash *circularity-hash*) + bs)))
(defun slots-and-values (o) (declare (optimize (speed 3) (safety 0))) @@ -268,12 +304,14 @@ "Deserialize a lisp value from a buffer-stream." (declare (optimize (speed 3) (safety 0)) (type (or null buffer-stream) buf-str)) - (labels + (let ((*circularity-hash* (get-circularity-hash))) + (labels ((%deserialize (bs) (declare (optimize (speed 3) (safety 0)) (type buffer-stream bs)) (let ((tag (buffer-read-byte bs))) (declare (type foreign-char tag)) +;; (format t "Tag: ~A~%" tag) (cond ((= tag +fixnum+) (buffer-read-fixnum bs)) @@ -416,9 +454,9 @@ (etypecase buf-str (null (return-from deserialize nil)) (buffer-stream - (setq *lisp-obj-id* 0) - (clear-circularity-hash) - (%deserialize buf-str))))) + (let ((result (%deserialize buf-str))) + (release-circularity-hash *circularity-hash*) + result))))))
(defun deserialize-bignum (bs length positive) (declare (optimize (speed 3) (safety 0)) --- /project/elephant/cvsroot/elephant/src/elephant/variables.lisp 2006/04/26 17:53:44 1.2 +++ /project/elephant/cvsroot/elephant/src/elephant/variables.lisp 2006/09/04 00:09:15 1.3 @@ -59,13 +59,6 @@ (defvar *current-transaction* +NULL-VOID+ "The transaction which is currently in effect.")
-;; Stuff the serializer uses -(defvar *lisp-obj-id* 0 - "Circularity ids for the serializer.") - -(defvar *circularity-hash* (make-hash-table :test 'eq) - "Circularity hash for the serializer.") - #+(or cmu sbcl allegro) (defvar *resourced-byte-spec* (byte 32 0) "Byte specs on CMUCL, SBCL and Allegro are conses.") @@ -89,14 +82,11 @@ ;; (*auto-commit* *auto-commit*) ;; (*transaction-stack* ;; (make-array 0 :adjustable t :fill-pointer t)) -;; (*lisp-obj-id* 0) -;; (*circularity-hash* (make-hash-table :test 'eq)) ;; #+(or cmu sbcl allegro) ;; (*resourced-byte-spec* (byte 32 0))) ;; (declare (special *current-transaction* sleepycat::*errno-buffer* ;; sleepycat::*buffer-streams* ;; *store-controller* *auto-commit* *transaction-stack* -;; *lisp-obj-id* *circularity-hash* ;; #+(or cmu sbcl allegro) *resourced-byte-spec*)) ;; (funcall thunk)))