[elephant-cvs] CVS elephant/src/elephant
ieslick
ieslick at common-lisp.net
Mon Sep 4 00:09:16 UTC 2006
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)))
More information about the Elephant-cvs
mailing list