[elephant-cvs] CVS elephant/src/elephant
ieslick
ieslick at common-lisp.net
Fri Feb 16 23:02:53 UTC 2007
Update of /project/elephant/cvsroot/elephant/src/elephant
In directory clnet:/tmp/cvs-serv31505/src/elephant
Modified Files:
backend.lisp controller.lisp migrate.lisp serializer1.lisp
serializer2.lisp transactions.lisp
Log Message:
Changed transaction protocol to better support multiple-stores. Should only effect BDB and not SQL, migration and upgrade fixes, some more debug support; green on Allegro/MacOS BDB and SQlite3
--- /project/elephant/cvsroot/elephant/src/elephant/backend.lisp 2007/02/04 10:08:27 1.10
+++ /project/elephant/cvsroot/elephant/src/elephant/backend.lisp 2007/02/16 23:02:53 1.11
@@ -68,6 +68,9 @@
#:cursor-initialized-p
;; Transactions
#:*current-transaction*
+ #:make-transaction-record
+ #:transaction-store
+ #:transaction-object
#:execute-transaction
#:controller-start-transaction
#:controller-commit-transaction
@@ -127,6 +130,9 @@
#:cursor-initialized-p
;; Transactions
#:*current-transaction*
+ #:make-transaction-record
+ #:transaction-store
+ #:transaction-object
#:execute-transaction
#:controller-start-transaction
#:controller-commit-transaction
--- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/16 07:11:02 1.34
+++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/16 23:02:53 1.35
@@ -349,13 +349,15 @@
"Conveniently open a store controller. Set *store-controller* to the new controller
unless it is already set (opening a second controller means you must keep track of
controllers yourself. *store-controller* is a convenience variable for single-store
- applications or single-store per thread apps"
+ applications or single-store per thread apps. Multi-store apps should either confine
+ their *store-controller* to a given dynamic context or wrap each store-specific op in
+ a transaction using with or ensure transaction"
(assert (consp spec))
(let ((controller (get-controller spec)))
(apply #'open-controller controller args)
(if *store-controller*
(progn
- (warn "Store controller already set so was not updated")
+;; (warn "Store controller already set so was not updated") ;; this was annoying me
controller)
(setq *store-controller* controller))))
--- /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2007/02/08 23:07:18 1.5
+++ /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2007/02/16 23:02:53 1.6
@@ -133,18 +133,19 @@
;; for users breaking the class-index abstraction
(assert (not (object-was-copied-p classidx)))
(let ((newcidx
- (with-transaction (:store-controller dst)
+ (ensure-transaction (:store-controller dst)
(build-indexed-btree dst))))
;; Add inverse indices to new main class index
(map-indices (lambda (name srciidx)
- (with-transaction (:store-controller dst)
- (add-index newcidx
- :index-name name
- :key-form (key-form srciidx)
- :populate nil)))
+ (let ((key-form (key-form srciidx)))
+ (ensure-transaction (:store-controller dst)
+ (add-index newcidx
+ :index-name name
+ :key-form key-form
+ :populate nil))))
classidx)
;; Add the class index to the class root
- (with-transaction (:store-controller dst)
+ (ensure-transaction (:store-controller dst)
(setf (get-value classname (controller-class-root dst)) newcidx))
;; Update the class to point at objects in the new store
(setf (%index-cache (find-class classname)) newcidx)
@@ -158,7 +159,7 @@
(map-btree (lambda (key value)
(let ((newval (migrate dst value)))
(unless (eq key *elephant-properties-label*)
- (with-transaction (:store-controller dst :txn-nosync t)
+ (ensure-transaction (:store-controller dst :txn-nosync t)
(add-to-root key newval :store-controller dst)))))
(controller-root src))
dst)
@@ -168,7 +169,7 @@
(map-btree (lambda (oldoid oldinst)
(declare (ignore oldoid))
(let ((newinst (migrate sc oldinst)))
- (with-transaction (:store-controller sc)
+ (ensure-transaction (:store-controller sc)
;; This isn't redundant in most cases, but we may have
;; indexed objects without slots and without a slot
;; write the new index won't be updated in that case
@@ -245,7 +246,7 @@
(loop for slot-def in (persistent-slot-defs class) do
(when (slot-boundp-using-class class src slot-def)
(let ((value (migrate dstsc (slot-value-using-class class src slot-def))))
- (with-transaction (:store-controller dstsc)
+ (ensure-transaction (:store-controller dstsc)
(setf (slot-value-using-class class dst slot-def) value))))))
@@ -256,7 +257,7 @@
(if (object-was-copied-p src)
(retrieve-copied-object src)
(let ((newbtree (build-btree dst)))
- (with-transaction (:store-controller dst :txn-nosync t)
+ (ensure-transaction (:store-controller dst :txn-nosync t)
(copy-btree-contents dst newbtree src))
(register-copied-object src newbtree)
newbtree)))
@@ -265,19 +266,26 @@
"Also copy the inverse indices for indexed btrees"
(if (object-was-copied-p src)
(retrieve-copied-object src)
- (with-transaction (:store-controller dst :txn-nosync t)
- (let ((newbtree (build-indexed-btree dst)))
- (copy-btree-contents dst newbtree src)
- (map-indices (lambda (name srciidx)
- (add-index newbtree :index-name name :key-form (key-form srciidx) :populate t))
- src)
- (register-copied-object src newbtree)
- newbtree))))
+ (let ((newbtree
+ (ensure-transaction (:store-controller dst :txn-nosync t)
+ (build-indexed-btree dst))))
+ (ensure-transaction (:store-controller dst :txn-nosync t)
+ (copy-btree-contents dst newbtree src))
+ (map-indices (lambda (name srciidx)
+ (format t "Adding index: ~A~%" name)
+ (let ((key-form (key-form srciidx)))
+ (ensure-transaction (:store-controller dst :txn-nosync t)
+ (add-index newbtree :index-name name :key-form key-form :populate t))))
+ src)
+ (register-copied-object src newbtree)
+ newbtree)))
(defmethod copy-btree-contents ((sc store-controller) dst src)
(map-btree (lambda (key value)
- (let ((newval (migrate sc value)))
- (setf (get-value key dst) newval)))
+ (format t "Migrating btree entry: ~A ~A~%" key value)
+ (let ((newval (migrate sc value))
+ (newkey (migrate sc key)))
+ (setf (get-value newkey dst) newval)))
src))
@@ -296,7 +304,9 @@
:rehash-size (hash-table-rehash-size src)
:rehash-threshold (hash-table-rehash-threshold src))))
(maphash (lambda (key value)
- (setf (gethash key newhash) (migrate dst value)))
+ (format t "Migrating hash entry: ~A ~A~%" key value)
+ (setf (gethash key newhash)
+ (migrate dst value)))
src)))
(defmethod migrate ((dst store-controller) (src cons))
--- /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/02/09 09:06:12 1.8
+++ /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/02/16 23:02:53 1.9
@@ -281,6 +281,51 @@
(%serialize frob)
bs))
+(defparameter *trace-serializer* t)
+
+(defparameter *tag-table*
+ `((,+fixnum+ . "fixnum32")
+ (,+char+ . "char")
+ (,+single-float+ . "single-float")
+ (,+double-float+ . "double float")
+ (,+negative-bignum+ . "neg bignum")
+ (,+positive-bignum+ . "pos bignum")
+ (,+rational+ . "rational number")
+ (,+nil+ . "null")
+ (,+ucs1-symbol+ . "8-bit symbol")
+ (,+ucs1-string+ . "8-bit string")
+ (,+ucs1-pathname+ . "8-bit pathname")
+ (,+ucs2-symbol+ . "16-bit symbol")
+ (,+ucs2-string+ . "16-bit string")
+ (,+ucs2-pathname+ . "16-bit pathname")
+ (,+ucs4-symbol+ . "32-bit symbol")
+ (,+ucs4-string+ . "32-bit string")
+ (,+ucs4-pathname+ . "32-bit pathname")
+ (,+persistent+ . "persistent object")
+ (,+cons+ . "cons cell")
+ (,+hash-table+ . "hash table")
+ (,+object+ . "standard object")
+ (,+array+ . "array")))
+
+(defun enable-serializer-tracing ()
+ (setf *trace-serializer* t))
+
+(defun disable-serializer-tracing ()
+ (setf *trace-serializer* nil))
+
+(defun print-pre-deserialize-tag (tag)
+ (when *trace-serializer*
+ (let ((tag-name (assoc tag *tag-table*)))
+ (if tag-name
+ (format t "Deserializing type: ~A~%" tag-name)
+ (progn
+ (format t "Unrecognized tag: ~A~%" tag)
+ (break))))))
+
+(defun print-post-deserialize-tag (value)
+ (when *trace-serializer*
+ (format t "Returned: ~A~%" value)))
+
(defun deserialize (buf-str sc)
"Deserialize a lisp value from a buffer-stream."
(declare #-elephant-without-optimize (optimize (speed 3) (safety 0))
@@ -291,6 +336,8 @@
(type buffer-stream bs))
(let ((tag (buffer-read-byte bs)))
(declare (type foreign-char tag))
+;; (print-pre-deserialize-tag tag)
+;; (let ((value
(cond
((= tag +fixnum+)
(buffer-read-fixnum bs))
@@ -429,7 +476,10 @@
do
(setf (row-major-aref a i) (%deserialize bs)))
a))))
- (t (error "deserialize fubar!"))))))
+ (t (error "deserialize fubar!")))
+;; (print-post-deserialize-tag value)
+;; value)
+ )))
(etypecase buf-str
(null (return-from deserialize nil))
(buffer-stream
--- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/13 16:50:40 1.23
+++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/16 23:02:53 1.24
@@ -341,6 +341,50 @@
;;; DESERIALIZER
;;;
+(defparameter *trace-deserializer* t)
+
+(defparameter *tag-table*
+ `((,+fixnum32+ . "fixnum32")
+ (,+fixnum64+ . "fixnum32")
+ (,+char+ . "char")
+ (,+single-float+ . "single-float")
+ (,+double-float+ . "double float")
+ (,+negative-bignum+ . "neg bignum")
+ (,+positive-bignum+ . "pos bignum")
+ (,+rational+ . "rational number")
+ (,+nil+ . "null")
+ (,+utf8-string+ . "UTF8 string")
+ (,+utf16-string+ . "UTF16le string")
+ (,+uft32-string+ . "UTF32le string")
+ (,+symbol+ . "symbol")
+ (,+pathname+ . "pathname")
+ (,+persistent+ . "persistent object")
+ (,+cons+ . "cons cell")
+ (,+hash-table+ . "hash table")
+ (,+object+ . "standard object")
+ (,+array+ . "array")
+ (,+struct+ . "struct")
+ (,+class+ . "class")))
+
+(defun enable-deserializer-tracing ()
+ (setf *trace-deserializer* t))
+
+(defun disable-deserializer-tracing ()
+ (setf *trace-deserializer* nil))
+
+(defun print-pre-deserialize-tag (tag)
+ (when *trace-deserializer*
+ (let ((tag-name (assoc tag *tag-table*)))
+ (if tag-name
+ (format t "Deserializing type: ~A~%" tag-name)
+ (progn
+ (format t "Unrecognized tag: ~A~%" tag)
+ (break))))))
+
+(defun print-post-deserialize-tag (value)
+ (when *trace-deserializer*
+ (format t "Returned: ~A~%" value)))
+
(defun deserialize (buf-str sc)
"Deserialize a lisp value from a buffer-stream."
(declare (type (or null buffer-stream) buf-str))
@@ -357,6 +401,8 @@
(let ((tag (buffer-read-byte bs)))
(declare (type foreign-char tag)
(dynamic-extent tag))
+;; (print-pre-deserialize-tag tag)
+;; (let ((value
(cond
((= tag +fixnum32+)
(buffer-read-fixnum32 bs))
@@ -479,7 +525,10 @@
do
(setf (row-major-aref a i) (%deserialize bs)))
a))))
- (t (error "deserialize fubar!"))))))
+ (t (error "deserialize fubar!")))
+;; (print-post-deserialize-tag value)
+;; value)
+ )))
(etypecase buf-str
(null (return-from deserialize nil))
(buffer-stream
--- /project/elephant/cvsroot/elephant/src/elephant/transactions.lisp 2007/02/14 04:36:10 1.6
+++ /project/elephant/cvsroot/elephant/src/elephant/transactions.lisp 2007/02/16 23:02:53 1.7
@@ -58,6 +58,37 @@
;; - A typical design approach is to make sure that the most primitive interfaces to the backend
;; database look at *current-transaction* to determine whether a transaction is active. Users code can also
;; access this parameter to check whether a transaction is active.
+;;
+;; Multiple store considerations:
+;; - When operating with multiple stores, nested transactions and BDB there are some subtle issues to
+;; work around: how to avoid writing one store with a transaction created in the context of another.
+;; - For many leaf functions: *store-controller* and *current-transaction* have to both be correct;
+;; this requirement may relax in the future
+;; - The following macros accomodate multiple stores by requiring that execute-transaction return a
+;; pair of (store-controller . txn-obj) where txn-obj is owned by the backend and the store-controller
+;; is the store instance it is associated with. A nested or ensured transaction is only indicated
+;; in the call to execute transaction if the store controllers match, otherwise a new transaction
+;; for that store is created
+
+(defun make-transaction-record (sc txn)
+ "Backends must use this to assign values to *current-transaction* binding"
+ (cons sc txn))
+
+(defun transaction-store (txnrec)
+ "Get the store that owns the transaction from a transaction record"
+ (car txnrec))
+
+(defun transaction-object (txnrec)
+ "Get the backend-specific transaction object"
+ (cdr txnrec))
+
+(defun transaction-object-p (txnrec)
+ (consp txnrec))
+
+(defun owned-txn-p (sc parent-txn-rec)
+ (and parent-txn-rec
+ (transaction-object-p parent-txn-rec)
+ (eq sc (transaction-store parent-txn-rec))))
(defmacro with-transaction ((&rest keyargs &key
(store-controller '*store-controller*)
@@ -70,12 +101,16 @@
aborted. If the body deadlocks, the body is re-executed in
a new transaction, retrying a fixed number of iterations.
If nested, the backend must support nested transactions."
- `(funcall #'execute-transaction ,store-controller
- (lambda () , at body)
- :parent ,parent
- :retries ,retries
- ,@(remove-keywords '(:store-controller :parent :retries)
- keyargs)))
+ (let ((sc (gensym)))
+ `(let ((,sc ,store-controller))
+ (funcall #'execute-transaction ,store-controller
+ (lambda () , at body)
+ :parent (if (owned-txn-p ,sc ,parent)
+ (transaction-object ,parent)
+ nil)
+ :retries ,retries
+ ,@(remove-keywords '(:store-controller :parent :retries)
+ keyargs)))))
(defmacro ensure-transaction ((&rest keyargs &key
(store-controller '*store-controller*)
@@ -88,9 +123,11 @@
be run atomically whether there is or is not an existing transaction
(rather than relying on auto-commit). with-transaction nests transactions
where as ensure-transaction can be part of an enclosing, flat transaction"
- (let ((txn-fn (gensym)))
- `(let ((,txn-fn (lambda () , at body)))
- (if ,transaction
+ (let ((txn-fn (gensym))
+ (sc (gensym)))
+ `(let ((,txn-fn (lambda () , at body))
+ (,sc ,store-controller))
+ (if (owned-txn-p ,sc ,transaction)
(funcall ,txn-fn)
(funcall #'execute-transaction ,store-controller
,txn-fn
@@ -103,7 +140,7 @@
(defmacro with-batched-transaction ((batch size list &rest txn-options) &body body)
"Perform a set of DB operations over a list of elements in batches of size 'size'.
Pass specific transaction options after the list reference."
- `(loop for ,batch in (subsets ,subset-size ,list) do
+ `(loop for ,batch in (subsets ,size ,list) do
(with-transaction ,txn-options
, at body)))
More information about the Elephant-cvs
mailing list