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 () ,@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 () ,@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 () ,@body))) - (if ,transaction + (let ((txn-fn (gensym)) + (sc (gensym))) + `(let ((,txn-fn (lambda () ,@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 ,@body)))