Revision: 3936 Author: hans URL: http://bknr.net/trac/changeset/3936

Stop using allocate-instance method for ID allocation again. SBCL allocates an instance of every class as an optimization for object creation, and this prototype object was then made part of the class extent. Instead, the ID is now allocated in initialize-instance.

Lock ID allocation against concurrent access.

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-22 08:06:08 UTC (rev 3935) +++ branches/anon-transaction-fixes-2/bknr/datastore/src/data/object-tests.lisp 2008-09-22 10:40:42 UTC (rev 3936) @@ -144,8 +144,8 @@ (defdstest stress-test-2 () (bknr.datastore::without-sync () (format t "Creating ~A objects~%" +stress-size+) - (dotimes (i +stress-size+) - (make-instance 'store-object)) + (time (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))) @@ -169,10 +169,11 @@ (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))) + (sort (mapcar (lambda (object) + (cons (class-name (class-of object)) + (store-object-id object))) + (all-store-objects)) + #'< :key #'cdr))

(defdstest make-referenced-object-in-anon-tx () (with-transaction (:make)

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-22 08:06:08 UTC (rev 3935) +++ branches/anon-transaction-fixes-2/bknr/datastore/src/data/object.lisp 2008-09-22 10:40:42 UTC (rev 3936) @@ -163,7 +163,9 @@ (remove-if #'transient-slot-p (class-slots class)))

(defclass store-object () - ((id :initarg :id :reader store-object-id + ((id :initarg :id + :reader store-object-id + :type integer :index-type unique-index :index-initargs (:test #'eql) :index-reader store-object-with-id :index-values all-store-objects @@ -220,6 +222,7 @@ (aclmop::finalize-inheritance (find-class 'store-object))

(defmethod initialize-instance :around ((object store-object) &rest initargs &key) + (setf (slot-value object 'id) (allocate-next-object-id)) (cond ((not (in-transaction-p)) (with-store-guard () @@ -242,14 +245,14 @@ (t (call-next-method))))

-(defmethod allocate-instance :around ((class persistent-class) &key) - (let* ((object (call-next-method)) - (subsystem (store-object-subsystem)) - (id (next-object-id subsystem))) - (setf (slot-value object 'id) id) - (incf (next-object-id subsystem)) - object)) +(defvar *allocate-object-id-lock* (bt:make-lock "Persistent Object ID Creation"))

+(defun allocate-next-object-id () + (mp-with-lock-held (*allocate-object-id-lock*) + (let ((id (next-object-id (store-object-subsystem)))) + (incf (next-object-id (store-object-subsystem))) + id))) + (defun initialize-transient-slots (object) (dolist (slotd (class-slots (class-of object))) (when (and (typep slotd 'persistent-effective-slot-definition) @@ -493,15 +496,9 @@ ;; If the class is NIL, it was not found in the currently ;; running Lisp image and objects of this class will be ignored. (when class - ;; We set the next object ID to allocate in the store to the - ;; object ID read from the snapshot file. ALLOCATE-INSTANCE - ;; will assign this object ID to the object and increment the - ;; counter. This way, we correctly deserialze store snapshots - ;; which have holes in their ID space (because objects have - ;; been deleted). - (setf (next-object-id (store-object-subsystem)) object-id) (let ((object (allocate-instance class))) - (assert (= object-id (slot-value object 'id))) + (setf (slot-value object 'id) object-id + (next-object-id (store-object-subsystem)) (1+ object-id)) (dolist (index (class-slot-indices class 'id)) (index-add index object)))))))