[bknr-cvs] hans changed branches/anon-transaction-fixes-2/bknr/datastore/src/data/object
BKNR Commits
bknr at bknr.net
Sun Sep 21 16:51:58 UTC 2008
Revision: 3933
Author: hans
URL: http://bknr.net/trac/changeset/3933
Serialize make-instance transaction before calling initialize-instance in
order to make sure that the object exists early enough during restore.
Stress test with two threads.
Change defdstest macro so that after each test has run, it is verified that
the "same" set of objects exists when restoring from the tx log and a snapshot.
U branches/anon-transaction-fixes-2/bknr/datastore/src/data/object-tests.lisp
U branches/anon-transaction-fixes-2/bknr/datastore/src/data/object.lisp
Modified: branches/anon-transaction-fixes-2/bknr/datastore/src/data/object-tests.lisp
===================================================================
--- branches/anon-transaction-fixes-2/bknr/datastore/src/data/object-tests.lisp 2008-09-21 12:51:48 UTC (rev 3932)
+++ branches/anon-transaction-fixes-2/bknr/datastore/src/data/object-tests.lisp 2008-09-21 16:51:58 UTC (rev 3933)
@@ -52,6 +52,17 @@
(delete-directory directory))))
(defvar *tests* (make-hash-table))
+
+(defun do-run-test (thunk)
+ (let ((bknr.datastore::*store-verbose* nil)
+ initial-objects)
+ (funcall thunk)
+ (setf initial-objects (object-classes-and-ids))
+ (restore)
+ (test-equal initial-objects (object-classes-and-ids))
+ (snapshot)
+ (restore)
+ (test-equal initial-objects (object-classes-and-ids))))
(defmacro defdstest (name args &body body)
(when args
@@ -60,9 +71,7 @@
(make-instance 'datastore-test-class
:unit :datastore
:name ',name
- :body (lambda ()
- (let ((bknr.datastore::*store-verbose* nil))
- , at body)))))
+ :body (lambda () (do-run-test (lambda () , at body))))))
(defdstest store-setup ()
(test-assert *store*))
@@ -121,16 +130,26 @@
(defconstant +stress-size+ 10000)
(defdstest stress-test ()
- (format t "Creating ~a objects~%" +stress-size+)
+ (format t "Creating ~A objects in two threads~%" +stress-size+)
(time (bknr.datastore::without-sync ()
- (dotimes (i +stress-size+)
- (make-instance 'store-object))))
- (test-equal (length (all-store-objects)) +stress-size+)
- (format t "Delete ~A objects~%" +stress-size+)
- (time (bknr.datastore::without-sync ()
- (map-store-objects #'delete-object)))
- (test-equal (all-store-objects) nil))
+ (labels ((stress ()
+ (dotimes (i +stress-size+)
+ (make-instance 'store-object))))
+ (let ((threads (list (bt:make-thread #'stress)
+ (bt:make-thread #'stress))))
+ (loop while (some #'bt:thread-alive-p threads)
+ do (sleep 1))))))
+ (test-equal (length (all-store-objects)) (* 2 +stress-size+)))
+(defdstest stress-test-2 ()
+ (bknr.datastore::without-sync ()
+ (format t "Creating ~A objects~%" +stress-size+)
+ (dotimes (i +stress-size+)
+ (make-instance 'store-object))
+ (format t "Deleting ~A objects~%" (length (all-store-objects)))
+ (time (map-store-objects #'delete-object))
+ (test-equal (all-store-objects) nil)))
+
(defdstest make-instance-in-anon-txn ()
(with-transaction ()
(make-instance 'store-object))
@@ -142,11 +161,23 @@
(test-assert (make-instance 'store-object))))
(define-persistent-class parent ()
- ((child :update :initform nil)))
+ ((child :update :initform nil :initarg nil)))
(define-persistent-class child ()
())
+(defun object-classes-and-ids ()
+ "Return a list of conses with the car being a class name and the cdr
+ being the object id for all persistent objects in the store"
+ (mapcar (lambda (object)
+ (cons (class-name (class-of object))
+ (store-object-id object)))
+ (all-store-objects)))
+
+(defdstest make-referenced-object-in-anon-tx ()
+ (with-transaction (:make)
+ (make-instance 'parent :child (make-instance 'child))))
+
(defdstest serialize-circular-in-anon-txn ()
(let ((parent (make-instance 'parent)))
(with-transaction (:circular)
@@ -227,7 +258,19 @@
(test-equal 0 (class-with-transient-slot-slot (find-store-object object-id)))
(snapshot)
(restore)
- (test-equal 0 (class-with-transient-slot-slot (find-store-object object-id)))))
+ (test-equal 0 (class-with-transient-slot-slot (find-store-object object-id)))))
+(define-persistent-class persistent-mixin ()
+ ((mixin-slot :update
+ :initform 2)))
+
+(define-persistent-class inherit-multiple (persistent-mixin parent)
+ ())
+
+(defdstest multiple-inheritance-test ()
+ (let* ((o1 (make-instance 'inherit-multiple :child (make-instance 'child)))
+ (o2 (make-instance 'inherit-multiple :child o1)))
+ (test-equal o1 (parent-child o2))))
+
(defun run-datastore-test (name)
- (unit-test:run-test (gethash name *tests*)))
\ No newline at end of file
+ (unit-test:run-test (gethash name *tests*)))
Modified: branches/anon-transaction-fixes-2/bknr/datastore/src/data/object.lisp
===================================================================
--- branches/anon-transaction-fixes-2/bknr/datastore/src/data/object.lisp 2008-09-21 12:51:48 UTC (rev 3932)
+++ branches/anon-transaction-fixes-2/bknr/datastore/src/data/object.lisp 2008-09-21 16:51:58 UTC (rev 3933)
@@ -39,7 +39,7 @@
(defun store-object-subsystem ()
(let ((subsystem (find-if (alexandria:rcurry #'typep 'store-object-subsystem)
- (store-subsystems *store*))))
+ (store-subsystems *store*))))
(unless subsystem
(error 'object-subsystem-not-found-in-store :store *store*))
subsystem))
@@ -47,17 +47,8 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(finalize-inheritance
(defclass persistent-class (indexed-class)
- ((transient-slot-initargs :initform nil
- :accessor persistent-class-transient-slot-initargs)))))
+ ())))
-(defmethod determine-transient-slot-initargs ((class persistent-class))
- (with-slots (transient-slot-initargs) class
- (setf transient-slot-initargs nil)
- (dolist (slotd (class-slots class))
- (when (and (transient-slot-p slotd)
- (slot-definition-initargs slotd))
- (pushnew (car (slot-definition-initargs slotd)) transient-slot-initargs)))))
-
(defmethod validate-superclass ((sub persistent-class) (super indexed-class))
t)
@@ -68,22 +59,16 @@
(when (plusp instance-count)
(unless *suppress-schema-warnings*
(report-progress "~&; updating ~A instances of ~A for class changes~%"
- instance-count class))
+ instance-count class))
(mapc #'reinitialize-instance (class-instances class)))))
-(defmethod instance :after ((class persistent-class) &rest args)
- (declare (ignore args))
- (determine-transient-slot-initargs class))
-
-(defmethod reinitialize-instance :after ((class persistent-class) &rest args)
- (declare (ignore args))
- (determine-transient-slot-initargs class)
+(defmethod reinitialize-instance :after ((class persistent-class) &key)
(when (and (boundp '*store*) *store*)
(update-instances-for-changed-class (class-name class))
(unless *suppress-schema-warnings*
(report-progress "~&; class ~A has been changed. To ensure correct schema ~
evolution, please snapshot your datastore.~%"
- (class-name class)))))
+ (class-name class)))))
(defclass persistent-direct-slot-definition (index-direct-slot-definition)
((relaxed-object-reference :initarg :relaxed-object-reference
@@ -194,7 +179,7 @@
:slots (id))))
(defun class-instances (class)
- (find-class class) ; make sure that the class exists
+ (find-class class) ; make sure that the class exists
(store-objects-with-class class))
(deftransaction store-object-touch (object)
@@ -237,21 +222,23 @@
(defmethod initialize-instance :around ((object store-object) &rest initargs &key)
(cond
((not (in-transaction-p))
- (let ((transaction (make-instance 'transaction
- :function-symbol 'make-instance
- :timestamp (get-universal-time)
- :args (cons (class-name (class-of object)) initargs))))
- (with-statistics-log (*transaction-statistics* (transaction-function-symbol transaction))
- (with-transaction-log (transaction)
- (call-next-method)))))
+ (with-store-guard ()
+ (let ((transaction (make-instance 'transaction
+ :function-symbol 'make-instance
+ :timestamp (get-universal-time)
+ :args (cons (class-name (class-of object))
+ (append (list :id (slot-value object 'id))
+ initargs)))))
+ (with-statistics-log (*transaction-statistics* (transaction-function-symbol transaction))
+ (with-transaction-log (transaction)
+ (call-next-method))))))
((in-anonymous-transaction-p)
- (prog1
- (call-next-method)
- (encode (make-instance 'transaction
- :function-symbol 'make-instance
- :timestamp (transaction-timestamp *current-transaction*)
- :args (cons (class-name (class-of object)) initargs))
- (anonymous-transaction-log-buffer *current-transaction*))))
+ (encode (make-instance 'transaction
+ :function-symbol 'make-instance
+ :timestamp (transaction-timestamp *current-transaction*)
+ :args (cons (class-name (class-of object)) initargs))
+ (anonymous-transaction-log-buffer *current-transaction*))
+ (call-next-method))
(t
(call-next-method))))
@@ -272,12 +259,12 @@
(funcall (slot-definition-initfunction slotd))))))
(defmethod initialize-instance :after ((object store-object) &key)
- ;; This is called only when initially creating the (persistent)
- ;; instance, not during restore. During restore, the
- ;; INITIALIZE-TRANSIENT-INSTANCE function is called for all
- ;; persistent objects after the snapshot has been read, but before
- ;; running the transaction log.
- (initialize-transient-instance object))
+ ;; This is called only when initially creating the (persistent)
+ ;; instance, not during restore. During restore, the
+ ;; INITIALIZE-TRANSIENT-INSTANCE function is called for all
+ ;; persistent objects after the snapshot has been read, but before
+ ;; running the transaction log.
+ (initialize-transient-instance object))
(defmethod print-object ((object store-object) stream)
(print-unreadable-object (object stream :type t)
@@ -345,22 +332,6 @@
,@(unless metaclass '((:metaclass persistent-class)))
, at class-options))))
-#+nil
-(define-persistent-class foo ()
- ((a :read)))
-#+nil
-(let ((foo (make-object 'foo :a 2)))
- (foo-a foo))
-
-;;; test fuer multiple inheritance
-#+nil
-(progn
- (define-persistent-class bar ()
- ((b :read)))
- (define-persistent-class blorg (foo bar)
- ((c :read)))
- (make-object 'blorg :a 2 :b 3 :c 4))
-
;;; binary snapshot
(defvar *current-object-slot* nil)
@@ -580,6 +551,12 @@
(let ((*current-object-slot* nil))
(%decode-store-object stream)))
+(define-condition invalid-reference (warning)
+ ((id :initarg :id))
+ (:report (lambda (e stream)
+ (format stream "internal inconsistency during restore - store object with ID ~A could not be found"
+ (slot-value e 'id)))))
+
(defun %decode-store-object (stream)
;; This is actually called in two contexts, when a slot-value is to
;; be filled with a reference to a store object and when a list of
@@ -595,8 +572,7 @@
;; lists in slots).
(let* ((id (%decode-integer stream))
(object (or (store-object-with-id id)
- (warn "internal inconsistency during restore: can't find store object ~A in loaded store"
- id)))
+ (warn 'invalid-reference :id id)))
(container (first *current-object-slot*))
(slot-name (second *current-object-slot*)))
(cond (object object)
@@ -689,13 +665,6 @@
(clear-class-indices class-name)))
class-layouts))))))))
-(defun make-object (class-name &rest initargs)
- "Make a persistent object of class named CLASS-NAME. Calls MAKE-INSTANCE with INITARGS."
- (if (in-transaction-p)
- (apply #'make-instance class-name initargs)
- (with-store-guard ()
- (apply #'make-instance class-name initargs))))
-
(defun tx-delete-object (id)
(destroy-object (store-object-with-id id)))
More information about the Bknr-cvs
mailing list