Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv4494/src/elephant
Modified Files: backend.lisp controller.lisp package.lisp serializer.lisp transactions.lisp variables.lisp Log Message: Checkpoint for 0.6.1 feature set - BROKEN
--- /project/elephant/cvsroot/elephant/src/elephant/backend.lisp 2006/02/20 15:45:37 1.4 +++ /project/elephant/cvsroot/elephant/src/elephant/backend.lisp 2006/12/16 19:35:10 1.5 @@ -36,14 +36,19 @@ #:persistent-slot-boundp #:persistent-slot-makunbound ;; Controllers + #:*elephant-code-version* #:store-controller #:open-controller #:close-controller + #:controller-serialize + #:controller-deserialize #:controller-spec #:controller-root + #:controller-version #:controller-class-root #:root #:spec #:class-root #:flush-instance-cache + #:controller-symbol-cache #:controller-symbol-id-cache ;; Collection generic functions #:btree #:btree-index #:indexed-btree #:build-indexed-btree #:build-btree #:existsp @@ -52,12 +57,18 @@ #:deserialize #:serialize #:deserialize-from-base64-string #:serialize-to-base64-string + ;; Serialization callbacks + #:lookup-persistent-symbol + #:lookup-persistent-symbol-id ;; Cursor accessors #:cursor #:cursor-btree #:cursor-oid #:cursor-initialized-p ;; Transactions + #:*transaction-stack* + #:*current-transaction* + #:*auto-commit* #:execute-transaction #:controller-start-transaction #:controller-commit-transaction @@ -68,6 +79,9 @@ #:register-backend-con-init #:lookup-backend-con-init ) + (:import-from :elephant-serializer2 + #:serialize-symbol-complete + ) (:export ;; Variables #:*cachesize* @@ -81,28 +95,40 @@ #:persistent-slot-boundp #:persistent-slot-makunbound ;; Controllers + #:*elephant-code-version* #:store-controller #:open-controller #:close-controller + #:controller-serialize + #:controller-deserialize #:controller-spec #:controller-root #:controller-class-root + #:controller-version #:root #:spec #:class-root #:flush-instance-cache + #:controller-symbol-cache #:controller-symbol-id-cache ;; Collection generic functions #:btree #:btree-index #:indexed-btree #:build-indexed-btree #:build-btree #:existsp #:map-indices ;; Serialization #:deserialize #:serialize + #:serialize-symbol-complete #:deserialize-from-base64-string #:serialize-to-base64-string + ;; Serialization callbacks + #:lookup-persistent-symbol + #:lookup-persistent-symbol-id ;; Cursor accessors #:cursor #:cursor-btree #:cursor-oid #:cursor-initialized-p ;; Transactions + #:*transaction-stack* + #:*auto-commit* + #:*current-transaction* #:execute-transaction #:controller-start-transaction #:controller-commit-transaction --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/11/11 15:30:26 1.16 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/12/16 19:35:10 1.17 @@ -105,10 +105,11 @@ ;; ;; Callback hooks for persistent variables ;; +;; NOTE: Design sketch; not sure I'll include this...
-(defvar *variable-hooks* nil - "An alist (specs -> varlist) where varlist is tuple of - lisp name, store name (auto) and policy") +;;(defvar *variable-hooks* nil +;; "An alist (specs -> varlist) where varlist is tuple of +;; lisp name, store name (auto) and policy")
;;(defun add-hook (name spec) ;; (if (assoc spec *variable-hooks* :test #'equal) @@ -147,8 +148,7 @@
;; (defmethod clear-agents (agent) ;; (setf *agencies* nil)) - - +
;; ;; Open a Store @@ -158,7 +158,8 @@ "Conveniently open a store controller." (assert (consp spec)) (setq *store-controller* (get-controller spec)) - (ensure-marked-version + (initialize-serializer *store-controller*) + (ensure-properties (apply #'open-controller *store-controller* args)))
(defun close-store (&optional sc) @@ -196,45 +197,57 @@ :documentation "This should be a persistent btree instantiated by the backend") (class-root :reader controller-class-root :documentation "This should be a persistent indexed btree instantiated by the backend") - ;; NOTE: This is backend specific and should get moved... + ;; Upgradable serializer strategy + (version :accessor controller-version :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)) ) (:documentation "Class of objects responsible for the book-keeping of holding DB handles, the cache, table creation, counters, locks, the root (for garbage collection,) et cetera."))
+(defun initialize-serializer (sc) + "Establish serializer version on controller startup" + (cond ((equal (controller-version sc) '(0 6 1)) + (setf (controller-serializer-version sc) 2) + (setf (controller-serialize sc) 'elephant-serializer2::serialize) + (setf (controller-deserialize sc) 'elephant-serializer2::deserialize)) + ((prior-version-p (controller-version sc) '(0 6 0)) + (setf (controller-serializer-version sc) 1) + (setf (controller-serialize sc) 'elephant-serializer1::serialize) + (setf (controller-deserialize sc) 'elephant-serializer1::deserialize)) + (t (error "Unsupported Elephant database version")))) + ;; -;; VERSIONING AND UPGRADES +;; VERSIONING ;;
-;; Need to tag databases -;; Need to handle untagged db's -;; Need to provide upgrade hooks - (defvar *restricted-properties* '(:version) "Properties that are not user manipulable")
-(defmethod controller-properties ((sc store-controller)) - (get-from-root *elephant-properties-label* :store-controller sc)) - -(defmethod set-ele-property (property value &key (sc *store-controller*)) - (assert (and (symbolp property) (not (member property *restricted-properties*)))) - (let ((props (get-from-root *elephant-properties-label* :store-controller sc))) - (setf (get-value *elephant-properties-label* (controller-root sc)) - (if (assoc property props) - (progn (setf (cdr (assoc property props)) value) - props) - (acons property value props))))) +(defgeneric controller-version ((sc store-controller)) + (:documentation "Return the elephant version of this controller - should not + require the serializer to operate as it may be used to determine + the serializer version used to read the DB. This has to be valid + prior to the DB being opened."))
-(defmethod get-ele-property (property &key (sc *store-controller*)) - (assert (symbolp property)) - (let ((entry (assoc property - (get-from-root *elephant-properties-label* - :store-controller sc)))) - (when entry - (cdr entry)))) +(defun prior-version-p (v1 v2) + "Is v1 an equal or earlier version than v2" + (cond ((and (null v1) (null v2)) t) + ((and (null v1) (not (null v2))) t) + ((and (not (null v1)) (null v2)) nil) + ((< (car v1) (car v2)) t) + ((> (car v1) (car v2)) nil) + ((= (car v1) (car v2)) + (prior-version-p (cdr v1) (cdr v2))) + (t (error "Version problem!"))))
-(defmethod ensure-marked-version ((sc store-controller)) +(defmethod ensure-properties ((sc store-controller)) "Not sure this test is right (empty root)" (let ((props (controller-properties sc)) (empty? (and (empty-btree-p (controller-root sc)) @@ -250,31 +263,33 @@ (acons :version *elephant-unmarked-code-version* props))))) sc)
-(defmethod controller-version ((sc store-controller)) - (let ((alist (controller-properties sc))) - (let ((result (assoc :version alist))) - (if result - (cdr result) - nil)))) + +;; +;; Upgrade paths +;;
(defmethod up-to-date-p ((sc store-controller)) (equal (controller-version sc) *elephant-code-version*))
+(defmethod upgrade ((sc store-controller) target-spec) + (unless (upgradable-p sc) + (error "Cannot upgrade ~A from version ~A to version ~A~%Valid upgrades are:~%~A" + (controller-spec sc) + (controller-version sc) + *elephant-code-version* + *elephant-upgrade-table*)) + (warn "Please read the current limitations on migrate-based upgrade in migrate.lisp to ensure your + data does not require any unsupported features") + (let ((source sc) + (target (open-store target-spec))) + (migrate target source) + (close-store target))) + (defparameter *elephant-upgrade-table* '( ((0 6 0) (0 5 0)) + ((0 6 1) (0 6 0)) ))
-(defun prior-version-p (v1 v2) - "Is v1 an equal or earlier version than v2" - (cond ((and (null v1) (null v2)) t) - ((and (null v1) (not (null v2))) t) - ((and (not (null v1)) (null v2)) nil) - ((< (car v1) (car v2)) t) - ((> (car v1) (car v2)) nil) - ((= (car v1) (car v2)) - (prior-version-p (cdr v1) (cdr v2))) - (t (error "Version problem!")))) - (defmethod upgradable-p ((sc store-controller)) "Determine if this store can be brought up to date using the upgrade function" (unwind-protect @@ -283,15 +298,30 @@ (when (member ver (rest row) :test #'equal)) t) nil))
-(defmethod upgrade ((sc store-controller)) - (unless (upgradable-p sc) - (error "Cannot upgrade ~A from version ~A to version ~A~%Valid upgrades are:~%~A" - (controller-spec sc) - (controller-version sc) - *elephant-code-version* - *elephant-upgrade-table*)) - (warn "Upgrade by migrating your old repository to a clean repository created using the current code base. i.e. (migrate new old)")) - + +;; +;; PROPERTIES +;; + +(defmethod controller-properties ((sc store-controller)) + (get-from-root *elephant-properties-label* :store-controller sc)) + +(defmethod set-ele-property (property value &key (sc *store-controller*)) + (assert (and (symbolp property) (not (member property *restricted-properties*)))) + (let ((props (get-from-root *elephant-properties-label* :store-controller sc))) + (setf (get-value *elephant-properties-label* (controller-root sc)) + (if (assoc property props) + (progn (setf (cdr (assoc property props)) value) + props) + (acons property value props))))) + +(defmethod get-ele-property (property &key (sc *store-controller*)) + (assert (symbolp property)) + (let ((entry (assoc property + (get-from-root *elephant-properties-label* + :store-controller sc)))) + (when entry + (cdr entry))))
;; ;; OBJECT CACHE @@ -322,7 +352,11 @@ (defparameter *legacy-conversions-db* '((("elephant" . "bdb-btree") . ("sleepycat" . "bdb-btree")) (("elephant" . "bdb-indexed-btree") . ("sleepycat" . "bdb-indexed-btree")) - (("elephant" . "bdb-btree-index") . ("sleepycat" . "bdb-btree-index")))) + (("elephant" . "bdb-btree-index") . ("sleepycat" . "bdb-btree-index")) + (("sleepycat" . "bdb-btree") . ("db-bdb" . "bdb-btree")) + (("sleepycat" . "bdb-indexed-btree") . ("db-bdb" . "bdb-indexed-btree")) + (("sleepycat" . "bdb-btree-index") . ("db-bdb" . "bdb-btree-index")))) +
(defun handle-legacy-classes (name version) (declare (ignore version)) @@ -353,12 +387,15 @@ "Close the db handles and environment. Tries to wipe out references to the db handles."))
-(defgeneric connection-is-indeed-open (controller) - (:documentation "Validate the controller and the db that it is connected to")) +(defgeneric database-version ((sc store-controller)) + (:documentation "A version determination for a given store + controller that is independant of the serializer as the + serializer is dispatched based on the code version which is a + list of the form '(0 6 0)"))
-(defmethod connection-is-indeed-open ((controller t)) - "Default implementation is dumb..." - t) +(defgeneric connection-is-indeed-open (controller) + (:documentation "Validate the controller and the db that it is connected to") + (:method ((controller t)) t))
(defgeneric next-oid (sc) (:documentation @@ -369,32 +406,6 @@ "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) - (:documentation - "Backend specific slot reader function")) - -(defgeneric persistent-slot-writer (sc new-value instance name) - (:documentation - "Backend specific slot writer function")) - -(defgeneric persistent-slot-boundp (sc instance name) - (:documentation - "Backend specific slot bound test function")) - -(defgeneric persistent-slot-makunbound (sc instance name) - (:documentation - "Backend specific slot makunbound handler")) - ;; ;; Object Root Operations ;; @@ -429,6 +440,47 @@ (map-btree fn (controller-root store-controller)))
;; +;; 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*)) + +;; +;; 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 +;; + +(defgeneric persistent-slot-reader (sc instance name) + (:documentation + "Backend specific slot reader function")) + +(defgeneric persistent-slot-writer (sc new-value instance name) + (:documentation + "Backend specific slot writer function")) + +(defgeneric persistent-slot-boundp (sc instance name) + (:documentation + "Backend specific slot bound test function")) + +(defgeneric persistent-slot-makunbound (sc instance name) + (:documentation + "Backend specific slot makunbound handler")) + +;; ;; Explicit storage reclamation ;;
--- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2006/11/11 06:27:38 1.3 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2006/12/16 19:35:10 1.4 @@ -26,12 +26,15 @@ "Elephant: an object-oriented database for Common Lisp with multiple backends for Berkeley DB, SQL and others.") (:export #:*store-controller* #:*current-transaction* #:*auto-commit* - #:*elephant-lib-path* + #:*elephant-lib-path* #:*elephant-code-version*
#:store-controller #:controller-root #:controller-class-root + #:controller-version #:controller-serialize #:controller-deserialize #:open-store #:close-store #:with-open-store #:add-to-root #:get-from-root #:remove-from-root #:root-existsp - #:flush-instance-cache #:optimize-storage + #:get-cached-instance #:flush-instance-cache + #:controller-symbol-cache #:controller-symbol-id-cache + #:optimize-storage
#:with-transaction #:start-ele-transaction #:commit-transaction #:abort-transaction @@ -48,6 +51,9 @@ #:btree-differ #:migrate #:*inhibit-slot-copy*
+ #:lookup-persistent-symbol + #:lookup-persistent-symbol-id + #:cursor #:secondary-cursor #:make-cursor #:with-btree-cursor #:cursor-close #:cursor-init #:cursor-duplicate #:cursor-current #:cursor-first @@ -83,6 +89,11 @@ #:get-instances-by-value #:get-instances-by-range #:drop-instances + + ;; Utilities + #:ele-make-lock + #:ele-with-lock + #:ele-without-interrupts ) #+cmu (:import-from :pcl --- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2006/11/11 22:53:13 1.14 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2006/12/16 19:35:10 1.15 @@ -16,581 +16,48 @@
(in-package :elephant)
-(declaim (inline int-byte-spec - ;serialize deserialize - slots-and-values - deserialize-bignum)) - -(uffi:def-type foreign-char :char) - -;; Constants - -(defconstant +fixnum+ 1) -(defconstant +char+ 2) -(defconstant +single-float+ 3) -(defconstant +double-float+ 4) -(defconstant +negative-bignum+ 5) -(defconstant +positive-bignum+ 6) -(defconstant +rational+ 7) - -(defconstant +nil+ 8) - -;; 8-bit -(defconstant +ucs1-symbol+ 9) -(defconstant +ucs1-string+ 10) -(defconstant +ucs1-pathname+ 11) - -;; 16-bit -(defconstant +ucs2-symbol+ 12) -(defconstant +ucs2-string+ 13) -(defconstant +ucs2-pathname+ 14) - -;; 32-bit -(defconstant +ucs4-symbol+ 20) -(defconstant +ucs4-string+ 21) -(defconstant +ucs4-pathname+ 22) - -(defconstant +persistent+ 15) ;; stored by id+classname -(defconstant +cons+ 16) -(defconstant +hash-table+ 17) -(defconstant +object+ 18) -(defconstant +array+ 19) -(defconstant +struct+ 20) - -(defconstant +fill-pointer-p+ #x40) -(defconstant +adjustable-p+ #x80) +(defun serialize (frob bs sc) + "Generic interface to serialization that dispatches based on the + current Elephant version" + (funcall (symbol-function (controller-serialize sc)) frob bs sc)) + +(defun deserialize (bs sc) + "Generic interface to serialization that dispatches based on the + current Elephant version" + (funcall (symbol-function (controller-deserialize sc)) bs sc))
;; -;; This may be overkill, but is intended to avoid continually allocating -;; hashes each time we serialize an object. I added some adaptation -;; to keep it from dropping and re-allocating if the user continually saves -;; large collections of objects. However the defaults should handle most -;; apps just fine. The queue is useful because a system with 10 threads -;; will need 10 circularity queues if it is storing large objects +;; SQL encoding support ;;
-(defvar *circularity-hash-queue* nil - "Circularity ids for the serializer.") - -;; quick portability hack, do we need to import 'port' or some -;; other thread layer to the elephant dependency list? - -(defun ele-make-lock () - #+allegro (mp::make-process-lock) - #+cmu (mp:make-lock) - #+sbcl (sb-thread:make-mutex) - #+mcl (ccl:make-lock) - #+lispworks (mp:make-lock) - #-(or allegro sbcl cmu lispworks mcl) nil ) - -(defmacro ele-with-lock ((lock) &body body) - #+allegro `(mp:with-process-lock (,lock) ,@body) - #+cmu `(mp:with-lock-held (,lock) ,@body) - #+sbcl `(sb-thread:with-mutex (,lock) ,@body) - #+lispworks `(mp:with-lock (,lock) ,@body) - #+mcl `(ccl:with-lock-grabbed (,lock) ,@body) - #-(or allegro sbcl cmu lispworks mcl) `(progn ,@body) ) - -(defvar *circularity-lock* - (ele-make-lock)) - -(defun drop-circularity-hash-p (hash) - "This allows us to tune our memory usage to the application. - If grow-ceiling-p is enabled then we'll slowly adapt to - a growing demand so we balance GC load and reserved memory" - (if (> (hash-table-size hash) *circularity-max-hash-size*) - (if (and *circularity-grow-ceiling-p* - (>= (incf *circularity-adapt-count*) - *circularity-adapt-step-size*)) - (progn - (setf *circularity-max-hash-size* - (ceiling (* *circularity-growth-factor* - *circularity-max-hash-size*))) - nil) - t) - (progn - (decf *circularity-adapt-count* 0.5) - nil))) - -(defun get-circularity-hash () - (if (not *circularity-hash-queue*) - (make-hash-table :test 'eq :size 50) - (if *circularity-lock* - (ele-with-lock (*circularity-lock*) - (pop *circularity-hash-queue*)) - (pop *circularity-hash-queue*)))) - -(defun release-circularity-hash (hash) - (unless (drop-circularity-hash-p hash) - (clrhash hash) - (if *circularity-lock* - (ele-with-lock (*circularity-lock*) - (push hash *circularity-hash-queue*)) - (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)) - (let ((*lisp-obj-id* 0) - (*circularity-hash* (get-circularity-hash))) - (labels - ((%serialize (frob) - (declare (optimize (speed 3) (safety 0))) - (etypecase frob - ((integer #.(- 1 (expt 2 31)) #.(1- (expt 2 31))) ;; fixnum - (buffer-write-byte +fixnum+ bs) - (buffer-write-int frob bs)) - (null - (buffer-write-byte +nil+ bs)) - (symbol - (let ((s (symbol-name frob))) - (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+)) - #+(or (and sbcl sb-unicode) lispworks) - (etypecase s - (base-string +ucs1-symbol+) - (string #+sbcl +ucs4-symbol+ #+lispworks +ucs2-symbol+)) - #-(or lispworks (and allegro ics) (and sbcl sb-unicode)) - +ucs1-symbol+ - bs) - (buffer-write-int (byte-length s) bs) - (buffer-write-string s bs) - (let ((package (symbol-package frob))) - (if package - (%serialize (package-name package)) - (%serialize nil))))) - (string - (progn - (buffer-write-byte - #+(and allegro ics) - (etypecase frob - (base-string +ucs1-string+) ;; +ucs1-string+ - (string +ucs2-string+)) - #+(or (and sbcl sb-unicode) lispworks) - (etypecase frob - (base-string +ucs1-string+) - (string #+sbcl +ucs4-string+ #+lispworks +ucs2-string+)) - #-(or lispworks (and allegro ics) (and sbcl sb-unicode)) - +ucs1-string+ - bs) - (buffer-write-int (byte-length frob) bs) - (buffer-write-string frob bs))) - (persistent - (buffer-write-byte +persistent+ bs) - (buffer-write-int (oid frob) bs) - ;; This circumlocution is necessitated by - ;; an apparent bug in SBCL 9.9 --- type-of sometimes - ;; does NOT return the "proper name" of the class as the - ;; CLHS says it should, but gives the class object itself, - ;; which cannot be directly serialized.... - (let ((tp (type-of frob))) - #+(or sbcl) - (if (not (symbolp tp)) - (setf tp (class-name (class-of frob)))) - (%serialize tp)) - ) - #-(and :lispworks (or :win32 :linux)) - (single-float - (buffer-write-byte +single-float+ bs) - (buffer-write-float frob bs)) - (double-float - (buffer-write-byte +double-float+ bs) - (buffer-write-double frob bs)) - (character - (buffer-write-byte +char+ bs) - ;; might be wide! - (buffer-write-uint (char-code frob) bs)) - (pathname - (let ((s (namestring frob))) - (declare (type string s) (dynamic-extent s)) - (buffer-write-byte - #+(and allegro ics) - (etypecase s - (base-string +ucs1-pathname+) ;; +ucs1-pathname+ - (string +ucs2-pathname+)) - #+(or (and sbcl sb-unicode) lispworks) - (etypecase s - (base-string +ucs1-pathname+) - (string #+sbcl +ucs4-pathname+ #+lispwoks +ucs2-pathname+)) - #-(or lispworks (and allegro ics) (and sbcl sb-unicode)) - +ucs1-pathname+ - bs) - (buffer-write-int (byte-length s) bs) - (buffer-write-string s bs))) - (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)))) - (rational - (buffer-write-byte +rational+ bs) - (%serialize (numerator frob)) - (%serialize (denominator frob))) - (cons - (buffer-write-byte +cons+ 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 frob *circularity-hash*) *lisp-obj-id*) - (%serialize (car frob)) - (%serialize (cdr frob)))))) - (hash-table - (buffer-write-byte +hash-table+ 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 frob *circularity-hash*) *lisp-obj-id*) - (%serialize (hash-table-test frob)) - (%serialize (hash-table-rehash-size frob)) - (%serialize (hash-table-rehash-threshold frob)) - (%serialize (hash-table-count frob)) - (loop for key being the hash-key of frob - using (hash-value value) - do - (%serialize key) - (%serialize value)))))) - (standard-object - (buffer-write-byte +object+ 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 frob *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))))))) -;; (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*))) - (if idp (buffer-write-int idp bs) - (progn - (buffer-write-int (incf *lisp-obj-id*) bs) - (setf (gethash frob *circularity-hash*) *lisp-obj-id*) - (buffer-write-byte - (logior (byte-from-array-type (array-element-type frob)) - (if (array-has-fill-pointer-p frob) - +fill-pointer-p+ 0) - (if (adjustable-array-p frob) - +adjustable-p+ 0)) - bs) - (let ((rank (array-rank frob))) - (buffer-write-int rank bs) - (loop for i fixnum from 0 below rank - do (buffer-write-int (array-dimension frob i) - bs))) - (when (array-has-fill-pointer-p frob) - (buffer-write-int (fill-pointer frob) bs)) - (loop for i fixnum from 0 below (array-total-size frob) - do - (%serialize (row-major-aref frob i))))))) - ))) - (%serialize frob) - (release-circularity-hash *circularity-hash*) - bs))) - -(defun slots-and-values (o) - (declare (optimize (speed 3) (safety 0))) - (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 deserialize (buf-str &key sc) - "Deserialize a lisp value from a buffer-stream." - (declare (optimize (speed 3) (safety 0)) - (type (or null buffer-stream) buf-str)) - (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)) - ((= tag +nil+) nil) - ((= tag +ucs1-symbol+) - (let ((name (buffer-read-ucs1-string bs (buffer-read-fixnum bs))) - (maybe-package-name (%deserialize bs))) - (if maybe-package-name - (intern name (find-package maybe-package-name)) - (make-symbol name)))) - ((= tag +ucs2-symbol+) - (let ((name (buffer-read-ucs2-string bs (buffer-read-fixnum bs))) - (maybe-package-name (%deserialize bs))) - (if maybe-package-name - (intern name (find-package maybe-package-name)) - (make-symbol name)))) - #+(and sbcl sb-unicode) - ((= tag +ucs4-symbol+) - (let ((name (buffer-read-ucs4-string bs (buffer-read-fixnum bs))) - (maybe-package-name (%deserialize bs))) -;; (format t "ouput name = ~A~%" name) - (if maybe-package-name - (intern name (find-package maybe-package-name)) - (make-symbol name)))) - ((= tag +ucs1-string+) - (buffer-read-ucs1-string bs (buffer-read-fixnum bs))) - ((= tag +ucs2-string+) - (buffer-read-ucs2-string bs (buffer-read-fixnum bs))) - #+(and sbcl sb-unicode) - ((= tag +ucs4-string+) - (buffer-read-ucs4-string bs (buffer-read-fixnum bs))) - ((= tag +persistent+) -;; (get-cached-instance *store-controller* - (get-cached-instance sc - (buffer-read-fixnum bs) - (%deserialize bs))) - ((= tag +single-float+) - (buffer-read-float bs)) - ((= tag +double-float+) - (buffer-read-double bs)) - ((= tag +char+) - (code-char (buffer-read-uint bs))) - ((= tag +ucs1-pathname+) - (parse-namestring - (or (buffer-read-ucs1-string bs (buffer-read-fixnum bs)) ""))) - ((= tag +ucs2-pathname+) - (parse-namestring - (or (buffer-read-ucs2-string bs (buffer-read-fixnum bs)) "")))
[242 lines skipped] --- /project/elephant/cvsroot/elephant/src/elephant/transactions.lisp 2006/06/19 01:03:30 1.3 +++ /project/elephant/cvsroot/elephant/src/elephant/transactions.lisp 2006/12/16 19:35:10 1.4 @@ -52,7 +52,6 @@ :txn-nowait ,txn-nowait :txn-sync ,txn-sync))
- ;; ;; An interface to manage transactions explicitely ;; @@ -68,8 +67,9 @@ (defgeneric controller-abort-transaction (store-controller &key &allow-other-keys) (:documentation "Abort an elephant transaction"))
- +;; ;; User Interface +;;
(defun start-ele-transaction (&key (store-controller *store-controller*) (parent *current-transaction*) --- /project/elephant/cvsroot/elephant/src/elephant/variables.lisp 2006/11/10 01:48:49 1.5 +++ /project/elephant/cvsroot/elephant/src/elephant/variables.lisp 2006/12/16 19:35:10 1.6 @@ -30,12 +30,12 @@ ;;;;;;;;;;;;;;;; ;;;; Versioning Support
-(defvar *elephant-code-version* '(0 6 0) +(defvar *elephant-code-version* '(0 6 1) "The current database version supported by the code base")
-(defvar *elephant-unmarked-code-version* '(0 5 0) +(defvar *elephant-unmarked-code-version* '(0 6 0) "If a database is opened with existing data but no version then - we assume it's version 0.5.0") + we assume it's version 0.6.0")
(defvar *elephant-properties-label* 'elephant::*database-properties* "This is the symbol used to store properties associated with the @@ -48,22 +48,6 @@
(defvar *circularity-initial-hash-size* 50 "This is the default size of the circularity cache used in the serializer") -(defvar *circularity-max-hash-size* 100 - "This is the largest hash table that is maintained by the serializer. Larger - hash tables are dropped from the has queue assuming that it was a one of - transaction or an error.") -(defparameter *circularity-grow-ceiling-p* t - "This enables the system to slowly adapt to larger-than-average lists or other - collections of objects (like large trees) to avoid continually GC'ing large - data structures and reducing total copying over time") -(defparameter *circularity-adapt-step-size* 4 - "How many times we see something over the max in succession before we adapt - to a larger maximum size") -(defparameter *circularity-growth-factor* 0.5 - "How much to increase the max size after each adaptation step") -(defvar *circularity-adapt-count* 0 - "Maintains a count of how many times we've seen a hash table over the appropriate - size. This is reduced by 1/2 each time we don't have one that is oversized.")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -86,32 +70,21 @@ (defvar *resourced-byte-spec* (byte 32 0) "Byte specs on CMUCL, SBCL and Allegro are conses.")
-;; TODO: make this for real! -;; NOTE: ISE - We have to special case backend variable refs -;; to pull this off so we'll need to do what we did with -;; transactions so bear with me - I'll add this back as soon -;; as someone screams! - -;; (defun run-elephant-thread (thunk) -;; "Sets the specials (which hopefully are thread-local) to -;; make the Elephant thread-safe." -;; (let ((*current-transaction* +NULL-VOID+) -;; (sleepycat::*errno-buffer* (allocate-foreign-object :int 1)) -;; ;; if vector-push-extend et al are thread-safe, this -;; ;; doesn't need to be thread-local. -;; (sleepycat::*buffer-streams* -;; (make-array 0 :adjustable t :fill-pointer t)) -;; (*store-controller* *store-controller*) -;; (*auto-commit* *auto-commit*) -;; (*transaction-stack* -;; (make-array 0 :adjustable t :fill-pointer t)) -;; #+(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* -;; #+(or cmu sbcl allegro) *resourced-byte-spec*)) -;; (funcall thunk))) +;; +;; Thread-specific specials +;; + +;; NOTE: how to handle (*errno-buffer* (allocate-foreign-object :int 1)) +(defparameter *elephant-thread-local-vars* + '((*store-controller* *store-controller*) + (*current-transaction* +NULL-VOID+) + (*transaction-stack* (make-array 0 :adjustable t :fill-pointer t)) + #+(or cmu sbcl allegro) (*resourced-byte-spec* (byte 32 0)))) + +(defmacro with-elephant-variables (&body body) + `(let ,*elephant-thread-local-vars* + (declare (special ,(mapcar #'car *elephant-thread-local-vars*))) + ,@body))
;; get rid of spot idx and adjust the arrray (defun remove-indexed-element-and-adjust (idx array)