[elephant-cvs] CVS elephant/src/elephant
ieslick
ieslick at common-lisp.net
Sat Dec 16 19:35:10 UTC 2006
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) , at body)
- #+cmu `(mp:with-lock-held (,lock) , at body)
- #+sbcl `(sb-thread:with-mutex (,lock) , at body)
- #+lispworks `(mp:with-lock (,lock) , at body)
- #+mcl `(ccl:with-lock-grabbed (,lock) , at body)
- #-(or allegro sbcl cmu lispworks mcl) `(progn , at 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*)))
+ , at body))
;; get rid of spot idx and adjust the arrray
(defun remove-indexed-element-and-adjust (idx array)
More information about the Elephant-cvs
mailing list