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