Revision: 3682 Author: hans URL: http://bknr.net/trac/changeset/3682
Fix anonymous transactions: Instead of storing the subtransactions and then serializing them at the end of the transaction, they are now serialized immediately to an in-memory buffer and written to the transaction log at the end of the transaction in one fell swoop.
Add condition classes for most errors that are signaled from txn.lisp
U trunk/bknr/datastore/src/data/object-tests.lisp U trunk/bknr/datastore/src/data/object.lisp U trunk/bknr/datastore/src/data/txn.lisp
Modified: trunk/bknr/datastore/src/data/object-tests.lisp =================================================================== --- trunk/bknr/datastore/src/data/object-tests.lisp 2008-07-29 15:07:40 UTC (rev 3681) +++ trunk/bknr/datastore/src/data/object-tests.lisp 2008-07-29 20:25:57 UTC (rev 3682) @@ -45,22 +45,25 @@ (call-next-method) (close-store)))
+(defvar *tests* (make-hash-table)) + (defmacro define-datastore-test (name &rest body) - `(make-instance 'datastore-test-class - :unit :datastore - :name ,name - :body (lambda () - ,@body))) + `(setf (gethash ,name *tests*) + (make-instance 'datastore-test-class + :unit :datastore + :name ,name + :body (lambda () + ,@body))))
-(define-datastore-test "Datastore setup" +(define-datastore-test :store-setup (test-assert *test-datastore*))
-(define-datastore-test "Create object" +(define-datastore-test :create-object (let ((obj (make-object 'store-object))) (test-assert obj) (test-equal (list obj) (all-store-objects))))
-(define-datastore-test "Create multiple objects" +(define-datastore-test :create-multiple-objects (let ((o1 (make-object 'store-object)) (o2 (make-object 'store-object))) (test-assert o1) @@ -68,7 +71,7 @@ (test-equal (length (all-store-objects)) 2) (test-assert (subsetp (list o1 o2) (all-store-objects)))))
-(define-datastore-test "Delete multiple objects" +(define-datastore-test :delete-multiple-objects (let ((o1 (make-object 'store-object)) (o2 (make-object 'store-object))) (test-assert o1) @@ -80,23 +83,23 @@ (delete-object o2) (test-equal (all-store-objects) nil)))
-(define-datastore-test "Restore" +(define-datastore-test :restore (make-object 'store-object) (restore) (test-equal (length (all-store-objects)) 1))
-(define-datastore-test "Snapshot and Restore" +(define-datastore-test :snapshot-and-restore (make-object 'store-object) (snapshot) (restore) (test-equal (length (all-store-objects)) 1))
-(define-datastore-test "Restore multiple objects" +(define-datastore-test :restore-multiple-objects (dotimes (i 10) (make-object 'store-object)) (restore) (test-equal (length (all-store-objects)) 10))
-(define-datastore-test "Snapshot and Restore multiple objects" +(define-datastore-test :snapshot-restore-multiple-objects (dotimes (i 10) (make-object 'store-object)) (snapshot) (restore) @@ -104,7 +107,7 @@
(defconstant +stress-size+ 10000)
-(define-datastore-test "Stress test object creation" +(define-datastore-test :stress-test (format t "Creating ~a objects~%" +stress-size+) (time (bknr.datastore::without-sync () (dotimes (i +stress-size+) @@ -121,10 +124,19 @@ (define-persistent-class child () ())
-(define-datastore-test "Serialize circular dependency in anonymous txn" +(define-datastore-test :serialize-circular-in-anon-txn (let ((parent (make-object 'parent))) (with-transaction (:circular) (setf (parent-child parent) (make-object 'child)))) (restore) (test-equal (find-class 'child) - (class-of (parent-child (first (class-instances 'parent)))))) \ No newline at end of file + (class-of (parent-child (first (class-instances 'parent)))))) + +(define-datastore-test :delete-object-in-anon-txn + (let (object) + (with-transaction (:make) + (setf object (make-object 'child))) + (with-transaction (:delete) + (delete-object object)) + (restore) + (test-assert (object-destroyed-p object)))) \ No newline at end of file
Modified: trunk/bknr/datastore/src/data/object.lisp =================================================================== --- trunk/bknr/datastore/src/data/object.lisp 2008-07-29 15:07:40 UTC (rev 3681) +++ trunk/bknr/datastore/src/data/object.lisp 2008-07-29 20:25:57 UTC (rev 3682) @@ -96,11 +96,11 @@
(defmethod (setf slot-value-using-class) :after (newval (class persistent-class) object slotd) (when (in-anonymous-transaction-p) - (push (make-instance 'transaction - :timestamp (get-universal-time) - :function-symbol 'tx-change-slot-values - :args (list object (slot-definition-name slotd) newval)) - (anonymous-transaction-transactions *current-transaction*)))) + (encode (make-instance 'transaction + :timestamp (get-universal-time) + :function-symbol 'tx-change-slot-values + :args (list object (slot-definition-name slotd) newval)) + (anonymous-transaction-log-buffer *current-transaction*))))
(defmethod direct-slot-definition-class ((class persistent-class) &key &allow-other-keys) 'persistent-direct-slot-definition) @@ -195,17 +195,17 @@ (if (in-anonymous-transaction-p) (prog1 (call-next-method) - (push (make-instance 'transaction - :function-symbol 'make-instance - :timestamp (get-universal-time) - :args (cons (class-name (class-of object)) - (loop for slotd in (class-slots (class-of object)) - for slot-name = (slot-definition-name slotd) - for slot-initarg = (first (slot-definition-initargs slotd)) - when (and slot-initarg - (slot-boundp object slot-name)) - appending (list slot-initarg (slot-value object slot-name))))) - (anonymous-transaction-transactions *current-transaction*))) + (encode (make-instance 'transaction + :function-symbol 'make-instance + :timestamp (get-universal-time) + :args (cons (class-name (class-of object)) + (loop for slotd in (class-slots (class-of object)) + for slot-name = (slot-definition-name slotd) + for slot-initarg = (first (slot-definition-initargs slotd)) + when (and slot-initarg + (slot-boundp object slot-name)) + appending (list slot-initarg (slot-value object slot-name))))) + (anonymous-transaction-log-buffer *current-transaction*))) (call-next-method)))
(defmethod initialize-instance :after ((object store-object) &key id &allow-other-keys) @@ -661,7 +661,8 @@ (destroy-object (store-object-with-id id)))
(defun delete-object (object) - (if (in-transaction-p) + (if (and (in-transaction-p) + (not (in-anonymous-transaction-p))) (destroy-object object) (execute (make-instance 'transaction :function-symbol 'tx-delete-object :timestamp (get-universal-time)
Modified: trunk/bknr/datastore/src/data/txn.lisp =================================================================== --- trunk/bknr/datastore/src/data/txn.lisp 2008-07-29 15:07:40 UTC (rev 3681) +++ trunk/bknr/datastore/src/data/txn.lisp 2008-07-29 20:25:57 UTC (rev 3682) @@ -10,13 +10,67 @@ (define-condition not-in-transaction (error) () (:documentation - "Thrown when an operation on persistent slots is executed outside a transaction context")) + "Signaled when an operation on persistent slots is executed outside + a transaction context"))
(define-condition store-not-open (error) () (:documentation - "Thrown when a transaction is executed on a store that is not opened")) + "Signaled when a transaction is executed on a store that is not + opened"))
+(define-condition store-already-open (error) + () + (:documentation + "Signaled when an attempt is made to open a store with another + store being open")) + +(define-condition invalid-store-random-state (error) + () + (:documentation + "Signaled when the on-disk store random state cannot be read, + typically because it has been written with another Lisp")) + +(define-condition unsupported-lambda-list-option (error) + ((option :initarg :option :reader option)) + (:documentation + "Signaled when DEFTRANSACTION is used with an unsupported option in + its lambda list")) + +(define-condition default-arguments-unsupported (error) + ((tx-name :initarg :tx-name :reader tx-name) + (argument :initarg :argument :reader argument)) + (:report (lambda (c stream) + (format stream "argument ~A defaulted in DEFTRANSACTION ~S" + (argument c) (tx-name c)))) + (:documentation + "Signaled when an argument in a DEFTRANSACTION definition has a + default declaration")) + +(define-condition undefined-transaction (error) + ((tx-name :initarg :tx-name :reader tx-name)) + (:report (lambda (c stream) + (format stream "undefined transaction ~A in transaction log, please ensure that all the necessary code is loaded." + (tx-name c)))) + (:documentation + "Signaled when a named transaction is loaded from the transaction + log and no matching function definition could be found")) + +(define-condition invalid-transaction-nesting (error) + () + (:documentation + "Signaled when WITH-TRANSACTION forms are nested.")) + +(define-condition anonymous-transaction-in-named-transaction (error) + () + (:documentation + "Signaled when an anonymous transaction is started from within a named transaction.")) + +(define-condition no-subsystems (error) + () + (:documentation + "Signaled when an attempt is made to snapshot a store without subsystems")) + ;;; store
(defvar *store*) @@ -74,7 +128,7 @@ (restart-case (when (and (boundp '*store*) *store*) - (error "A store is already opened.")) + (error 'store-already-open)) (close-store () :report "Close the opened store." (close-store))))) @@ -153,7 +207,7 @@ (read f) (error (e) (declare (ignore e)) - (error "Invalid store random state")))) + (error 'invalid-store-random-state)))) (initialize-store-random-state () :report "Initialize the random state of the store. Use this to reinitialize the random state of the store when porting over a @@ -245,7 +299,7 @@ (defun store-current-transaction () (if (in-transaction-p) *current-transaction* - (error "store-current-transaction called outside of a transaction"))) + (error 'not-in-transaction)))
;;; All transactions are executed by an 'executor', which is the store ;;; itself or, in the case of a nested transaction, the parent @@ -262,7 +316,7 @@
(defmethod execute-transaction :before (executor transaction) (unless (store-open-p) - (error (make-condition 'store-not-open)))) + (error 'store-not-open)))
(defmethod execute-transaction ((executor transaction) transaction) (execute-unlogged transaction)) @@ -317,7 +371,7 @@ (&optional) (&rest (setf args (cdr args))) ; skip argument, too (&key (setf in-keywords-p t)) - (otherwise (error "unsupported lambda list option ~A in DEFTRANSACTION" arg)))) + (otherwise (error 'unsupported-lambda-list-option :option arg)))) (t (when in-keywords-p (push (intern (symbol-name arg) :keyword) result)) @@ -335,7 +389,7 @@ (body body)) (dolist (arg args) (when (listp arg) - (error "can't have argument defaults in transaction declaration for transaction ~A, please implement a wrapper" name))) + (error 'default-arguments-unsupported :tx-name name :argument (car arg)))) (let ((tx-name (intern (format nil "TX-~A" name) (symbol-package name)))) `(progn @@ -408,8 +462,8 @@ (with-store-guard () (let ((*current-transaction* transaction)) (apply (or (symbol-function (transaction-function-symbol transaction)) - (error "Undefined transaction function ~A, please ensure that all the necessary code is loaded." - (transaction-function-symbol transaction))) + (error 'undefined-transaction + :tx-name (transaction-function-symbol transaction))) (transaction-args transaction)))))
(defun fsync (stream) @@ -436,7 +490,7 @@ (check-type transaction symbol) ; otherwise care for multiple evaluation `(with-store-guard () (when (in-transaction-p) - (error "can't open nested with-transaction-log blocks")) + (error 'invalid-transaction-nesting)) (with-store-state (:transaction) (prog1 (let ((*current-transaction* ,transaction)) @@ -472,61 +526,54 @@ ;;; The actual writing to the transaction log is performed by the ;;; with-transaction macro.
-;;; An anonymous transaction has an optional label which is stored in -;;; the transaction log in order to make the source code location where +;;; An anonymous transaction has a label which is stored in the +;;; transaction log in order to make the source code location where ;;; the actual transaction code lives identifieable.
(defclass anonymous-transaction (transaction) - ((label :initarg :label :accessor anonymous-transaction-label) - (transactions :initarg :transactions :accessor anonymous-transaction-transactions)) - (:default-initargs :transactions nil :label nil)) + ((label :initarg :label + :accessor anonymous-transaction-label + :initform (error "missing label in anonymous transaction definition")) + (log-buffer :initarg :log-buffer + :accessor anonymous-transaction-log-buffer + :initform (flex:make-in-memory-output-stream))))
(defmethod print-object ((transaction anonymous-transaction) stream) (print-unreadable-object (transaction stream :type t) - (format stream "~A ~A ~A" + (format stream "~A ~A (~A)" (format-date-time (transaction-timestamp transaction)) (anonymous-transaction-label transaction) - (anonymous-transaction-transactions transaction)))) + (class-name (class-of (anonymous-transaction-log-buffer transaction))))))
(defmethod in-anonymous-transaction-p () (subtypep (type-of *current-transaction*) 'anonymous-transaction))
(defmethod encode-object ((transaction anonymous-transaction) stream) - (cond - ((anonymous-transaction-label transaction) - (%write-tag #\N stream) - (%encode-string (anonymous-transaction-label transaction) stream)) - (t - (%write-tag #\G stream))) - (%encode-list (reverse (anonymous-transaction-transactions transaction)) stream)) + (%write-tag #\N stream) + (%encode-string (anonymous-transaction-label transaction) stream) + (let ((subtxns (flex:get-output-stream-sequence (anonymous-transaction-log-buffer transaction)))) + (%encode-integer (length subtxns) stream) + (write-sequence subtxns stream)))
-(defmethod decode-object ((tag (eql #\G)) stream) - (make-instance 'anonymous-transaction - :transactions (%decode-list stream))) - (defvar *txn-log-stream* nil "This variable is bound to the transaction log stream while loading the transaction log. It is used by anonymous transactions to read the subtransactions from the log.")
(defmethod decode-object ((tag (eql #\N)) stream) - ;; When decoding an anonymous transaction from the transaction log, - ;; we only read its name. The subtransaction are not read here, but - ;; rather in EXECUTE-UNLOGGED below. The reason for this is that we - ;; need to execute the subtransactions while reading them, as we'd - ;; otherwise not be able to properly deserialize references to - ;; objects that have been created within this anonymous transaction. + (let* ((label (%decode-string stream)) + (length (%decode-integer stream)) + (buffer (make-array length :element-type '(unsigned-byte 8)))) + (read-sequence buffer stream) + (make-instance 'anonymous-transaction + :label label + :log-buffer (flex:make-in-memory-input-stream buffer))))
- ;; Thus, while restoring, the TRANSACTIONS slot of the anonymous - ;; transaction object is not used. - (make-instance 'anonymous-transaction - :label (%decode-string stream))) - (defmacro with-transaction ((&optional label) &body body) (let ((txn (gensym))) `(progn (when (in-transaction-p) - (error "tried to start anonymous transaction while in a transaction")) + (error 'anonymous-transaction-in-named-transaction)) (let ((,txn (make-instance 'anonymous-transaction :label ,(if (symbolp label) (symbol-name label) label)))) (with-transaction-log (,txn) ,@body))))) @@ -537,15 +584,14 @@ ;; subtransactions from the transaction log. (assert (eq :restore (store-state *store*)) () "Unexpected store state ~A for EXECUTE-UNLOGGED on an anonymous transaction" (store-state *store*)) - (let ((subtxns (%decode-integer *txn-log-stream*))) - (dotimes (i subtxns) - (execute-unlogged (decode *txn-log-stream*))) - (when (plusp subtxns) - ;; In order to maintain the previous on-disk format, we read the last cdr of the list - (assert (eq nil (decode *txn-log-stream*)))))) + (let ((stream (anonymous-transaction-log-buffer transaction))) + (handler-case + (loop + (execute-unlogged (decode stream))) + (end-of-file ()))))
-(defmethod execute-transaction :after ((executor anonymous-transaction) transaction) - (push transaction (anonymous-transaction-transactions executor))) +(defmethod execute-transaction :before ((executor anonymous-transaction) transaction) + (encode transaction (anonymous-transaction-log-buffer executor)))
;;; Subsystems
@@ -571,9 +617,9 @@
(defmethod snapshot-store ((store store)) (unless (store-open-p) - (error (make-condition 'store-not-open))) + (error 'store-not-open)) (when (null (store-subsystems store)) - (error "Cannot snapshot store without subsystems...")) + (error 'no-subsystems)) (ensure-store-current-directory store) (with-store-state (:read-only store) (with-store-guard ()