Update of /project/elephant/cvsroot/elephant/src/elephant
In directory clnet:/tmp/cvs-serv27212/src/elephant
Modified Files:
controller.lisp serializer2.lisp unicode2.lisp
Log Message:
Symbol ID hack removed from BDB; Allegro/MacOS/x86 passes
--- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/01/22 23:11:08 1.22
+++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/01/25 18:18:00 1.23
@@ -151,14 +151,10 @@
(class-root :reader controller-class-root
:documentation "This should be a persistent indexed btree instantiated by the backend")
;; Upgradable serializer strategy
- (version :accessor controller-version-cached :initform nil)
+ (database-version :accessor controller-version-cached :initform nil)
(serializer-version :accessor controller-serializer-version :initform nil)
(serialize :accessor controller-serialize :initform nil)
(deserialize :accessor controller-deserialize :initform nil)
- ;; Symbol ID caches
- (symbol-cache :accessor controller-symbol-cache :initform (make-hash-table :size 2000))
- (symbol-id-cache :accessor controller-symbol-id-cache :initform (make-hash-table :size 2000))
- (fast-symbols :accessor controller-fast-symbols-p :initform nil)
)
(:documentation
"Class of objects responsible for the book-keeping of holding DB
@@ -443,21 +439,6 @@
;; (defmethod clear-agents (agent)
;; (setf *agencies* nil))
-
-;;
-;; Support for serialization efficiency
-;;
-
-(defgeneric lookup-persistent-symbol-id (sc symbol)
- (:documentation "Return an ID for the provided symbol. This function is
- a callback for the serializer that the backends share in
- most cases."))
-
-(defgeneric lookup-persistent-symbol (sc id)
- (:documentation "Return a symbol for the ID. This should always succeed.
- The database should not use the existing serializer to perform
- this function; but memutils and unicode are available"))
-
;;
;; Low-level support for metaclass protocol
;;
--- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/01/22 23:11:08 1.5
+++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/01/25 18:18:00 1.6
@@ -64,7 +64,7 @@
(defconstant +symbol+ 13)
;; Cached symbol references
-(defconstant +symbol-id+ 14)
+;; (defconstant +reserved+ 14)
;; stored by id+classname
(defconstant +persistent+ 15)
@@ -115,7 +115,7 @@
(vector-push-extend hash *circularity-hash-queue*)))
;;
-;; Circularity Hash for Serializer
+;; Circularity Hash for Deserializer
;;
(defparameter *circularity-vector-queue* (make-array 20 :fill-pointer 0 :adjustable t)
@@ -146,7 +146,8 @@
(defun serialize (frob bs sc)
"Serialize a lisp value into a buffer-stream."
- (declare (type buffer-stream bs))
+ (declare (type buffer-stream bs)
+ (ignorable sc))
(let ((*lisp-obj-id* -1)
(*circularity-hash* (get-circularity-hash)))
(labels
@@ -154,15 +155,23 @@
(incf *lisp-obj-id*))
(%serialize (frob)
(etypecase frob
- (symbol
- (serialize-symbol frob bs sc))
- (string
- (serialize-string frob bs))
((integer #.most-negative-fixnum #.most-positive-fixnum)
(buffer-write-byte +fixnum32+ bs)
(buffer-write-int frob bs))
(null
(buffer-write-byte +nil+ bs))
+ (symbol
+ (let ((sym-name (symbol-name frob)))
+ (declare (type string sym-name)
+ (dynamic-extent sym-name))
+ (buffer-write-byte +symbol+ bs)
+ (serialize-string sym-name bs)
+ (let ((package (symbol-package frob)))
+ (if package
+ (serialize-string (package-name package) bs)
+ (buffer-write-byte +nil+ bs)))))
+ (string
+ (serialize-string frob bs))
(persistent
(buffer-write-byte +persistent+ bs)
(buffer-write-int (oid frob) bs)
@@ -199,23 +208,7 @@
(loop for item in svs
do (%serialize item)))))))
(integer
- (let* ((num (abs frob))
- (word-size (ceiling (/ (integer-length num) 32)))
- (needed (* word-size 4)))
- (declare (type fixnum word-size needed))
- (if (< frob 0)
- (buffer-write-byte +negative-bignum+ bs)
- (buffer-write-byte +positive-bignum+ bs))
- (buffer-write-int needed bs)
- (loop for i fixnum from 0 below word-size
- ;; this ldb is consing on CMUCL!
- ;; there is an OpenMCL function which should work
- ;; and non-cons
- do
- #+(or cmu sbcl)
- (buffer-write-uint (ldb (int-byte-spec i) num) bs) ;; (%bignum-ref num i) bs)
- #+(or allegro lispworks openmcl)
- (buffer-write-uint (ldb (int-byte-spec i) num) bs))))
+ (serialize-bignum frob bs))
(rational
(buffer-write-byte +rational+ bs)
(%serialize (numerator frob))
@@ -298,17 +291,31 @@
(release-circularity-hash *circularity-hash*)
bs)))
-(defun slots-and-values (o)
- (loop for sd in (compute-slots (class-of o))
- for slot-name = (slot-definition-name sd)
- with ret = ()
- do
- (when (and (slot-boundp o slot-name)
- (eq :instance
- (slot-definition-allocation sd)))
- (push (slot-value o slot-name) ret)
- (push slot-name ret))
- finally (return ret)))
+(defun serialize-bignum (frob bs)
+ "Serialize bignum to buffer stream"
+ (declare (type integer frob)
+ (type buffer-stream bs))
+ (let* ((num (abs frob))
+ (word-size (ceiling (/ (integer-length num) 32)))
+ (needed (* word-size 4)))
+ (declare (type fixnum word-size needed))
+ (if (< frob 0)
+ (buffer-write-byte +negative-bignum+ bs)
+ (buffer-write-byte +positive-bignum+ bs))
+ (buffer-write-int needed bs)
+ (loop for i fixnum from 0 below word-size
+ ;; this ldb is consing on CMUCL!
+ ;; there is an OpenMCL function which should work
+ ;; and non-cons
+ do
+ #+(or cmu sbcl)
+ (buffer-write-uint (ldb (int-byte-spec i) num) bs) ;; (%bignum-ref num i) bs)
+ #+(or allegro lispworks openmcl)
+ (buffer-write-uint (ldb (int-byte-spec i) num) bs))))
+
+;;;
+;;; DESERIALIZER
+;;;
(defun deserialize (buf-str sc)
"Deserialize a lisp value from a buffer-stream."
@@ -343,8 +350,6 @@
(if package
(intern name (find-package package))
(make-symbol name))))
- ((= tag +symbol-id+)
- (deserialize-symbol-id (buffer-read-int bs) sc))
((= tag +persistent+)
(get-cached-instance sc
(buffer-read-fixnum bs)
@@ -462,61 +467,4 @@
with num integer = 0
do
(setq num (dpb (buffer-read-uint bs) byte-spec num))
- finally (return (if positive num (- num)))))
-
-;;
-;; Symbol cache
-;;
-
-(defun serialize-symbol (symbol bs sc)
- "Serialize a symbol by recording its ID"
- (declare (type buffer-stream bs)
- (type symbol symbol)
- (type store-controller sc))
- (if (controller-fast-symbols-p sc)
- (let ((id (lookup-id symbol sc)))
- (declare (type fixnum id))
- (buffer-write-byte +symbol-id+ bs)
- (buffer-write-int id bs))
- (serialize-symbol-complete symbol bs)))
-
-(defun lookup-id (symbol sc)
- "Find an id for a symbol or create a new one"
- (declare (type symbol symbol))
- (let ((id (gethash symbol (controller-symbol-id-cache sc))))
- (declare (type fixnum id))
- (if id id
- (let ((pid (lookup-persistent-symbol-id sc symbol)))
- (setf (gethash symbol (controller-symbol-id-cache sc)) pid)
- (setf (gethash pid (controller-symbol-cache sc)) symbol)
- pid))))
-
-(defun serialize-symbol-complete (symbol bs)
- "To be called by backends to serialize the string
- instead of the ID as they implement the
- persistent symbol table"
- (declare (type symbol symbol)
- (type buffer-stream bs))
- (let ((sym-name (symbol-name symbol)))
- (declare (type string sym-name)
- (dynamic-extent sym-name))
- (buffer-write-byte +symbol+ bs)
- (serialize-string sym-name bs)
- (let ((package (symbol-package symbol)))
- (if package
- (serialize-string (package-name package) bs)
- (buffer-write-byte +nil+ bs)))))
-
-(defun deserialize-symbol-id (id sc)
- "Deserialize a symbol ID by finding it in the cache"
- (declare (type fixnum id))
- (let ((symbol (gethash id (controller-symbol-cache sc))))
- (if symbol symbol
- (let ((symbol (lookup-persistent-symbol sc id)))
- (if symbol
- (progn
- (setf (gethash id (controller-symbol-cache sc)) symbol)
- (setf (gethash symbol (controller-symbol-id-cache sc)) id)
- symbol)
- (error "Symbol lookup foobar! ID referred to does not exist in database"))))))
-
+ finally (return (if positive num (- num)))))
\ No newline at end of file
--- /project/elephant/cvsroot/elephant/src/elephant/unicode2.lisp 2007/01/16 00:51:25 1.1
+++ /project/elephant/cvsroot/elephant/src/elephant/unicode2.lisp 2007/01/25 18:18:00 1.2
@@ -39,7 +39,7 @@
;; Accelerate the common case where a character set is not Latin-1
((and (not (equal "" string)) (< (char-code (char string 0)) #xFFFF))
(serialize-to-utf16le string bstream))
- ;; Actualy code pages > 0 are rare; so we can pay an extra cost
+ ;; Actually code pages > 0 are rare; so we can pay an extra cost
(t (or (serialize-to-utf8 string bstream)
(serialize-to-utf16le string bstream)
(serialize-to-utf32le string bstream)))))
