[bknr-cvs] hans changed branches/anon-transaction-fixes-2/bknr/datastore/src/data/object

[BKNR Commits]

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)))))))