From alemmens at common-lisp.net Fri Sep 1 13:57:08 2006 From: alemmens at common-lisp.net (alemmens) Date: Fri, 1 Sep 2006 09:57:08 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060901135708.EBBF91300B@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv5855 Modified Files: cache.lisp do.txt done.txt mop.lisp notes.txt objects.lisp test-index-1a.lisp test-index-1b.lisp test-schema-update-1a.lisp test-schema-update-1b.lisp test-schema-update-1c.lisp Log Message: Get rid of the Lispworks specific PROCESS-A-SLOT-OPTION stuff and handle the slot options in a way that's compatible with AMOP. Remove INITARGS argument for UPDATE-PERSISTENT-INSTANCE-FOR-REDEFINED-CLASS, because it turns out to be unnecessary (see details in notes.txt) Add explanation to test-index-1a.lisp about the use of (eval-when (:compile-toplevel :load-toplevel :execute) ...) Replace *RUCKSACK* by RS in the test-*.lisp files. --- /project/rucksack/cvsroot/rucksack/cache.lisp 2006/08/24 15:21:25 1.10 +++ /project/rucksack/cvsroot/rucksack/cache.lisp 2006/09/01 13:57:06 1.11 @@ -1,4 +1,4 @@ -;; $Id: cache.lisp,v 1.10 2006/08/24 15:21:25 alemmens Exp $ +;; $Id: cache.lisp,v 1.11 2006/09/01 13:57:06 alemmens Exp $ (in-package :rucksack) @@ -249,8 +249,8 @@ "Checks for transaction conflicts and signals a transaction conflict if necessary. Change the object's status to dirty. If the object is already dirty, nothing happens." - ;; This function is called by (setf slot-value-using-class), - ;; slot-makunbound-using-class and p-data-write. + ;; This function is called by (SETF SLOT-VALUE-USING-CLASS), + ;; SLOT-MAKUNBOUND-USING-CLASS and P-DATA-WRITE. (let ((object-id (object-id object)) (transaction (current-transaction))) ;; Check for transaction conflict. --- /project/rucksack/cvsroot/rucksack/do.txt 2006/08/31 20:09:17 1.2 +++ /project/rucksack/cvsroot/rucksack/do.txt 2006/09/01 13:57:07 1.3 @@ -1,20 +1,8 @@ DO: -- Handle initargs in LOAD-OBJECT and UPDATE-PERSISTENT-... - -- Initialize non-persistent slots during LOAD-OBJECT. - -- Figure out if there's a better way than - (eval-when (:compile-toplevel :load-toplevel :execute) ...) - to make sure that class definitions within a WITH-RUCKSACK are treated - as top level definitions. - -- Maybe signal a continuable error when the in-memory class definition does - not correspond to the most recent schema. If the user decides to - continue, UPDATE-PERSISTENT-INSTANCE-... will be called when necessary. - - What about in-memory persistent instances when the class definition - changes? We should make sure that those are updated too. There seem + changes? We should make sure that those are updated too. Some possible + strategies: to be three strategies: 1. Rely on Lisp's normal UPDATE-INSTANCE-FOR-REDEFINED-CLASS mechanism. Then the programmer must write methods for both UPDATE-INSTANCE-... @@ -22,16 +10,17 @@ 2. Remove all instances of the redefined class from the cache. Then the objects will be loaded from disk again, and U-P-I-F-R-C will be called automatically. This has the disadvantage that all values - of transient slots will be gone. + of transient slots will be gone; then again, I'm not sure if transient + slots make much sense anyway for persistent objects. + CLHS says: + "Updating such an instance occurs at an implementation-dependent time, + but no later than the next time a slot of that instance is read or + written." + Maybe we can also hook into SLOT-VALUE-USING-CLASS and (SETF S-V-U-C) + to automatically reload the object. Or maybe write an after method on + Lisp's UPDATE-INSTANCE-FOR-REDEFINED-CLASS that calls UPDATE-PERSISTENT-... 3. Forbid it and signal some kind of error. -- I'm not sure that :INCLUDE-SUBCLASSES NIL makes sense for - RUCKSACK-MAP-SLOT. Think about this. - -- Does indexing in example-1 work correctly if we don't use - *RUCKSACK* in WITH-RUCKSACK? Maybe WITH-RUCKSACK should always - bind *RUCKSACK*? - - There's still a btree bug that's uncovered by the stress test. Fix it. @@ -47,7 +36,20 @@ from the transaction id). That's one step towards avoiding locks on transaction commit. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +* MAYBE LATER +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +- Maybe signal a continuable error when the in-memory class definition does + not correspond to the most recent schema. If the user decides to + continue, UPDATE-PERSISTENT-INSTANCE-... will be called when necessary. + +- Think about non-persistent slots. Should we initialize them during + LOAD-OBJECT? + +- I'm not sure that :INCLUDE-SUBCLASSES NIL makes sense for + RUCKSACK-MAP-SLOT. Think about this. + - Deal with CHANGE-CLASS: call UPDATE-PERSISTENT-INSTANCE-FOR-DIFFERENT-CLASS when necessary. (Maybe it's never necessary and we can just use the existing UPDATE-INSTANCE-FOR-DIFFERENT-CLASS mechanism?) - --- /project/rucksack/cvsroot/rucksack/done.txt 2006/08/31 20:09:17 1.2 +++ /project/rucksack/cvsroot/rucksack/done.txt 2006/09/01 13:57:07 1.3 @@ -1,3 +1,17 @@ +* 2006-09-01 + +- Get rid of the Lispworks-specific PROCESS-A-SLOT-OPTION stuff and handle + the slot options in a way that's compatible with AMOP. + +- Removed INITARGS argument for UPDATE-PERSISTENT-INSTANCE-FOR-REDEFINED-CLASS, + because it turns out not to be necessary (see details in notes.txt). + +- Add explanation to test-index-1a.lisp about the use of + (eval-when (:compile-toplevel :load-toplevel :execute) ...) + +- Replace *RUCKSACK* by RS in test-*.lisp. + + * 2006-08-31 - Get rid of the Lispworks-specific PROCESS-A-CLASS-OPTION stuff and handle --- /project/rucksack/cvsroot/rucksack/mop.lisp 2006/08/31 20:09:17 1.9 +++ /project/rucksack/cvsroot/rucksack/mop.lisp 2006/09/01 13:57:07 1.10 @@ -1,4 +1,4 @@ -;; $Id: mop.lisp,v 1.9 2006/08/31 20:09:17 alemmens Exp $ +;; $Id: mop.lisp,v 1.10 2006/09/01 13:57:07 alemmens Exp $ (in-package :rucksack) @@ -110,20 +110,6 @@ (superclass standard-class)) t) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Processing class and slot options for objects of metaclass -;;; PERSISTENT-CLASS. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -#+lispworks -(defmethod clos:process-a-slot-option ((class persistent-class) - option - value - already-processed-options - slot) - (if (member option '(:index :persistence :unique)) - (list* option value already-processed-options) - (call-next-method))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Initializing the persistent-class metaobjects --- /project/rucksack/cvsroot/rucksack/notes.txt 2006/08/31 15:53:57 1.1 +++ /project/rucksack/cvsroot/rucksack/notes.txt 2006/09/01 13:57:07 1.2 @@ -1,9 +1,10 @@ -;; $Id: notes.txt,v 1.1 2006/08/31 15:53:57 alemmens Exp $ +;; $Id: notes.txt,v 1.2 2006/09/01 13:57:07 alemmens Exp $ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Some random notes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + * UPDATE-PERSISTENT-INSTANCE-FOR-REDEFINED-CLASS & friends. What should we do when the class has been redefined more than once @@ -36,3 +37,23 @@ the names of the slots that were added and the slots that were discarded (by the most recent version, compared to this version). + +* Handling initargs in LOAD-OBJECT and UPDATE-PERSISTENT-INSTANCE-... + +Actually, initargs are only relevant for slots that have been added by +a class redefinition, so they're only relevant for +UPDATE-PERSISTENT-INSTANCE-... (This is because objects created by +LOAD-OBJECT are disk versions of object that have once been +initialized by Lisp's normal INITIALIZE-INSTANCE methods, which +already took care of the initargs when the object was created for the +first time.) + +Looking at the CLHS description of +UPDATE-INSTANCE-FOR-REDEFINED-CLASS, I think that +UPDATE-PERSISTENT-INSTANCE-... doesn't need to handle initargs at all: + + "The generic function update-instance-for-redefined-class also takes + any number of initialization arguments. When it is called by the system + to update an instance whose class has been redefined, no initialization + arguments are provided." + --- /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/31 15:47:58 1.14 +++ /project/rucksack/cvsroot/rucksack/objects.lisp 2006/09/01 13:57:07 1.15 @@ -1,4 +1,4 @@ -;; $Id: objects.lisp,v 1.14 2006/08/31 15:47:58 alemmens Exp $ +;; $Id: objects.lisp,v 1.15 2006/09/01 13:57:07 alemmens Exp $ (in-package :rucksack) @@ -771,18 +771,21 @@ ;; the slot names and values for slots that were discarded and had values. (defgeneric update-persistent-instance-for-redefined-class - (instance added-slots discarded-slots property-list - &rest initargs &key &allow-other-keys) + (instance added-slots discarded-slots property-list &key) (:method ((instance persistent-object) added-slots discarded-slots property-list - &rest initargs &key &allow-other-keys) + &key) ;; Default method: ignore the discarded slots and initialize added slots - ;; according to their initargs or initforms. + ;; according to their initfunctions. (let ((slots (class-slots (class-of instance)))) (loop for slot-name in added-slots for slot = (find slot-name slots :key #'slot-definition-name) for initfunction = (and slot (slot-definition-initfunction slot)) when initfunction - ;; DO: Handle initargs! + ;; NOTE: We don't handle initargs, and I think we don't need to. + ;; We follow the CLHS description of UPDATE-INSTANCE-FOR-REDEFINED-CLASS, + ;; which says: "When it is called by the system to update an + ;; instance whose class has been redefined, no initialization + ;; arguments are provided." do (setf (slot-value instance slot-name) (funcall initfunction)))))) --- /project/rucksack/cvsroot/rucksack/test-index-1a.lisp 2006/08/31 20:09:18 1.2 +++ /project/rucksack/cvsroot/rucksack/test-index-1a.lisp 2006/09/01 13:57:07 1.3 @@ -1,4 +1,4 @@ -;; $Id: test-index-1a.lisp,v 1.2 2006/08/31 20:09:18 alemmens Exp $ +;; $Id: test-index-1a.lisp,v 1.3 2006/09/01 13:57:07 alemmens Exp $ (in-package :rucksack-test) @@ -20,10 +20,16 @@ (eval-when (:compile-toplevel :load-toplevel :execute) + ;; NOTE: The EVAL-WHEN above is necessary to ensure that the compiler + ;; 'knows about' the HACKER class when it compiles the PRINT-OBJECT method + ;; for HACKER. We could avoid this by splitting this file into two: + ;; the first one would contain the class definitions, and the second + ;; would contain everything else (especially methods that specialize on one + ;; of the classes defined in the first one). (defparameter *hacker-rucksack* #p"/tmp/rucksack/hackers/") - (with-rucksack (*rucksack* *hacker-rucksack* :if-exists :supersede) + (with-rucksack (rs *hacker-rucksack* :if-exists :supersede) (with-transaction () ;; We define some persistent classes with indexed slots. @@ -54,31 +60,31 @@ (name hacker)))) (defun create-hackers () - (with-rucksack (*rucksack* *hacker-rucksack*) + (with-rucksack (rs *hacker-rucksack*) ;; Fill the rucksack with some hackers. (with-transaction () (loop repeat 20 do (make-instance 'hacker)) (loop repeat 10 do (make-instance 'lisp-hacker)) - (rucksack-map-class *rucksack* 'hacker #'print)))) + (rucksack-map-class rs 'hacker #'print)))) (defun show-hackers () - (with-rucksack (*rucksack* *hacker-rucksack*) + (with-rucksack (rs *hacker-rucksack*) (with-transaction () (print "Hackers indexed by object id.") - (rucksack-map-class *rucksack* 'hacker #'print) + (rucksack-map-class rs 'hacker #'print) (print "Hackers indexed by name.") - (rucksack-map-slot *rucksack* 'hacker 'name #'print) + (rucksack-map-slot rs 'hacker 'name #'print) (print "Hackers indexed by hacker-id.") - (rucksack-map-slot *rucksack* 'hacker 'id #'print) + (rucksack-map-slot rs 'hacker 'id #'print) (print "Lisp hackers.") - (rucksack-map-class *rucksack* 'lisp-hacker #'print) + (rucksack-map-class rs 'lisp-hacker #'print) (print "Non-lisp hackers.") - (rucksack-map-class *rucksack* 'hacker #'print + (rucksack-map-class rs 'hacker #'print :include-subclasses nil) (print "Hacker object ids.") - (rucksack-map-class *rucksack* 'hacker #'print + (rucksack-map-class rs 'hacker #'print :id-only t)))) --- /project/rucksack/cvsroot/rucksack/test-index-1b.lisp 2006/08/31 15:50:27 1.1 +++ /project/rucksack/cvsroot/rucksack/test-index-1b.lisp 2006/09/01 13:57:07 1.2 @@ -1,4 +1,4 @@ -;; $Id: test-index-1b.lisp,v 1.1 2006/08/31 15:50:27 alemmens Exp $ +;; $Id: test-index-1b.lisp,v 1.2 2006/09/01 13:57:07 alemmens Exp $ (in-package :rs-test) @@ -23,7 +23,7 @@ ;;; (3) the index has been filled with the new values for the age slot. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(with-rucksack (*rucksack* *hacker-rucksack*) +(with-rucksack (rs *hacker-rucksack*) (with-transaction () ;; For classes that may change during program development, you should @@ -46,10 +46,10 @@ (:index t)))) (defun show-hackers-by-age () - (with-rucksack (*rucksack* *hacker-rucksack*) + (with-rucksack (rs *hacker-rucksack*) (with-transaction () (print "Hackers by age.") - (rucksack-map-slot *rucksack* 'hacker 'age + (rucksack-map-slot rs 'hacker 'age (lambda (hacker) (format t "~&~A has age ~D.~%" (name hacker) --- /project/rucksack/cvsroot/rucksack/test-schema-update-1a.lisp 2006/08/31 15:47:58 1.1 +++ /project/rucksack/cvsroot/rucksack/test-schema-update-1a.lisp 2006/09/01 13:57:07 1.2 @@ -1,4 +1,4 @@ -;; $Id: test-schema-update-1a.lisp,v 1.1 2006/08/31 15:47:58 alemmens Exp $ +;; $Id: test-schema-update-1a.lisp,v 1.2 2006/09/01 13:57:07 alemmens Exp $ (in-package :rucksack-test-schema-update) @@ -19,7 +19,7 @@ (defparameter *dir* #P"/tmp/rucksack/schema-update/") - (with-rucksack (*rucksack* *dir* :if-exists :supersede) + (with-rucksack (rs *dir* :if-exists :supersede) (with-transaction () (defclass person () @@ -41,16 +41,16 @@ (age person)))) ;; Create some persons. -(with-rucksack (*rucksack* *dir*) +(with-rucksack (rs *dir*) (with-transaction () (loop repeat 10 do (make-instance 'person)))) ;; Show them. -(with-rucksack (*rucksack* *dir*) +(with-rucksack (rs *dir*) (with-transaction () - (rucksack-map-class *rucksack* 'person #'print))) + (rucksack-map-class rs 'person #'print))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Sample output --- /project/rucksack/cvsroot/rucksack/test-schema-update-1b.lisp 2006/08/31 15:47:58 1.1 +++ /project/rucksack/cvsroot/rucksack/test-schema-update-1b.lisp 2006/09/01 13:57:07 1.2 @@ -1,4 +1,4 @@ -;; $Id: test-schema-update-1b.lisp,v 1.1 2006/08/31 15:47:58 alemmens Exp $ +;; $Id: test-schema-update-1b.lisp,v 1.2 2006/09/01 13:57:07 alemmens Exp $ (in-package :rucksack-test-schema-update) @@ -15,7 +15,7 @@ ;; (eval-when (:compile-toplevel :load-toplevel :execute) - (with-rucksack (*rucksack* *dir*) + (with-rucksack (rs *dir*) (with-transaction () (defclass person () @@ -50,7 +50,7 @@ ;; Create some persons with the new class definition. -(with-rucksack (*rucksack* *dir*) +(with-rucksack (rs *dir*) (with-transaction () (loop repeat 10 do (make-instance 'person)))) @@ -60,11 +60,11 @@ ;; update them and we want to keep a few old instances for the next ;; part of the test). -(with-rucksack (*rucksack* *dir*) +(with-rucksack (rs *dir*) (with-transaction () - (let ((cache (rucksack-cache *rucksack*)) + (let ((cache (rucksack-cache rs)) (count 0)) - (rucksack-map-class *rucksack* 'person + (rucksack-map-class rs 'person (lambda (id) (when (evenp count) (print (cache-get-object id cache))) --- /project/rucksack/cvsroot/rucksack/test-schema-update-1c.lisp 2006/08/31 15:47:58 1.1 +++ /project/rucksack/cvsroot/rucksack/test-schema-update-1c.lisp 2006/09/01 13:57:07 1.2 @@ -1,4 +1,4 @@ -;; $Id: test-schema-update-1c.lisp,v 1.1 2006/08/31 15:47:58 alemmens Exp $ +;; $Id: test-schema-update-1c.lisp,v 1.2 2006/09/01 13:57:07 alemmens Exp $ (in-package :rucksack-test-schema-update) @@ -14,7 +14,7 @@ ;; (eval-when (:compile-toplevel :load-toplevel :execute) - (with-rucksack (*rucksack* *dir*) + (with-rucksack (rs *dir*) (with-transaction () (defclass person () @@ -73,15 +73,15 @@ ;; Create some persons with the second version of the class definition. -(with-rucksack (*rucksack* *dir*) +(with-rucksack (rs *dir*) (with-transaction () (loop repeat 10 do (make-instance 'person)))) ;; Show all persons (for three versions of the class definition). -(with-rucksack (*rucksack* *dir*) +(with-rucksack (rs *dir*) (with-transaction () - (rucksack-map-class *rucksack* 'person #'print))) + (rucksack-map-class rs 'person #'print))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Sample output From alemmens at common-lisp.net Sun Sep 3 14:40:51 2006 From: alemmens at common-lisp.net (alemmens) Date: Sun, 3 Sep 2006 10:40:51 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060903144051.B6DEF2D052@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv23707 Modified Files: do.txt done.txt notes.txt objects.lisp test-index-1a.lisp Log Message: Handle updates of in-memory persistent objects by writing a method for Lisp?? UPDATE-INSTANCE-FOR-REDEFINED-CLASS that marks the object as dirty and calls Rucksack's UPDATE-PERSISTENT-INSTANCE-FOR-REDEFINED-CLASS. --- /project/rucksack/cvsroot/rucksack/do.txt 2006/09/01 13:57:07 1.3 +++ /project/rucksack/cvsroot/rucksack/do.txt 2006/09/03 14:40:50 1.4 @@ -1,28 +1,9 @@ DO: -- What about in-memory persistent instances when the class definition - changes? We should make sure that those are updated too. Some possible - strategies: - to be three strategies: - 1. Rely on Lisp's normal UPDATE-INSTANCE-FOR-REDEFINED-CLASS mechanism. - Then the programmer must write methods for both UPDATE-INSTANCE-... - and UPDATE-PERSISTENT-INSTANCE-... . That seems error prone. - 2. Remove all instances of the redefined class from the cache. - Then the objects will be loaded from disk again, and U-P-I-F-R-C will - be called automatically. This has the disadvantage that all values - of transient slots will be gone; then again, I'm not sure if transient - slots make much sense anyway for persistent objects. - CLHS says: - "Updating such an instance occurs at an implementation-dependent time, - but no later than the next time a slot of that instance is read or - written." - Maybe we can also hook into SLOT-VALUE-USING-CLASS and (SETF S-V-U-C) - to automatically reload the object. Or maybe write an after method on - Lisp's UPDATE-INSTANCE-FOR-REDEFINED-CLASS that calls UPDATE-PERSISTENT-... - 3. Forbid it and signal some kind of error. +- Make Rucksack crash proof. (Use a copying GC?) -- There's still a btree bug that's uncovered by the stress test. - Fix it. +- There's still a btree bug that's detected (very rarely) by the + stress test. Fix it. - Check that btrees actually signal an error for duplicate keys. Handle those errors correctly for slot indexes. @@ -45,7 +26,7 @@ continue, UPDATE-PERSISTENT-INSTANCE-... will be called when necessary. - Think about non-persistent slots. Should we initialize them during - LOAD-OBJECT? + LOAD-OBJECT? Do we need them at all? - I'm not sure that :INCLUDE-SUBCLASSES NIL makes sense for RUCKSACK-MAP-SLOT. Think about this. --- /project/rucksack/cvsroot/rucksack/done.txt 2006/09/01 13:57:07 1.3 +++ /project/rucksack/cvsroot/rucksack/done.txt 2006/09/03 14:40:51 1.4 @@ -1,3 +1,11 @@ +* 2006-09-03 + +- Handle updates of in-memory persistent objects by writing a method + for Lisp's UPDATE-INSTANCE-FOR-REDEFINED-CLASS that marks the object + as dirty and calls Rucksack's + UPDATE-PERSISTENT-INSTANCE-FOR-REDEFINED-CLASS. + + * 2006-09-01 - Get rid of the Lispworks-specific PROCESS-A-SLOT-OPTION stuff and handle --- /project/rucksack/cvsroot/rucksack/notes.txt 2006/09/01 13:57:07 1.2 +++ /project/rucksack/cvsroot/rucksack/notes.txt 2006/09/03 14:40:51 1.3 @@ -1,4 +1,4 @@ -;; $Id: notes.txt,v 1.2 2006/09/01 13:57:07 alemmens Exp $ +;; $Id: notes.txt,v 1.3 2006/09/03 14:40:51 alemmens Exp $ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Some random notes @@ -39,6 +39,7 @@ * Handling initargs in LOAD-OBJECT and UPDATE-PERSISTENT-INSTANCE-... + [2006-09-01] Actually, initargs are only relevant for slots that have been added by a class redefinition, so they're only relevant for @@ -57,3 +58,36 @@ to update an instance whose class has been redefined, no initialization arguments are provided." + +* Updating in-memory persistent instances when the class definition changes + [2006-09-02] + +We should make sure that those are updated too. Some possible strategies: + +1. Don't do anything special but rely on Lisp's normal + UPDATE-INSTANCE-FOR-REDEFINED-CLASS mechanism. Then the programmer + must write methods for both UPDATE-INSTANCE-... and + UPDATE-PERSISTENT-INSTANCE-... . That seems error prone. + +2. Remove all instances of the redefined class from the cache. Then + the objects will be loaded from disk again, and U-P-I-F-R-C will be + called automatically. This has the disadvantage that all values of + transient slots will be gone; then again, I'm not sure if transient + slots make much sense anyway for persistent objects. CLHS says: + "Updating such an instance occurs at an implementation-dependent + time, but no later than the next time a slot of that instance is + read or written." Maybe we can also hook into + SLOT-VALUE-USING-CLASS and (SETF S-V-U-C) to automatically reload + the object. Or maybe write an after method on Lisp's + UPDATE-INSTANCE-FOR-REDEFINED-CLASS that calls + UPDATE-PERSISTENT-... + +3. Forbid it and signal some kind of error. + +4. Write default method for Lisp's UPDATE-INSTANCE-FOR-REDEFINED-CLASS + that marks the object as dirty and calls Rucksack's + UPDATE-PERSISTENT-INSTANCE-FOR-REDEFINED-CLASS. + +Strategy 4 looks like a simple and reasonably clean solution to me. +I'll implement that. + --- /project/rucksack/cvsroot/rucksack/objects.lisp 2006/09/01 13:57:07 1.15 +++ /project/rucksack/cvsroot/rucksack/objects.lisp 2006/09/03 14:40:51 1.16 @@ -1,4 +1,4 @@ -;; $Id: objects.lisp,v 1.15 2006/09/01 13:57:07 alemmens Exp $ +;; $Id: objects.lisp,v 1.16 2006/09/03 14:40:51 alemmens Exp $ (in-package :rucksack) @@ -403,13 +403,14 @@ -(defmethod shared-initialize :before ((object persistent-object) slots - &key rucksack - ;; The DONT-INDEX argument is used - ;; when creating the indexes themselves - ;; (to prevent infinite recursion). - (dont-index nil) - &allow-other-keys) +(defmethod initialize-instance :before ((object persistent-object) + &rest args + &key rucksack + ;; The DONT-INDEX argument is used + ;; when creating the indexes themselves + ;; (to prevent infinite recursion). + (dont-index nil) + &allow-other-keys) ;; This happens when persistent-objects are created in memory, not when ;; they're loaded from the cache (loading uses ALLOCATE-INSTANCE instead). (let ((rucksack (or rucksack (rucksack object)))) @@ -422,10 +423,10 @@ (unless dont-index (rucksack-maybe-index-new-object rucksack (class-of object) object)))) -(defmethod shared-initialize :after ((object persistent-object) slots - &key rucksack - (dont-index nil) - &allow-other-keys) +(defmethod initialize-instance :after ((object persistent-object) + &rest args + &key rucksack (dont-index nil) + &allow-other-keys) ;; Update slot indexes for persistent slots that are bound now. (unless dont-index (let ((class (class-of object))) @@ -433,7 +434,7 @@ (let ((slot-name (slot-definition-name slot))) (when (and (slot-boundp object slot-name) (slot-persistence slot)) - (rucksack-maybe-index-changed-slot rucksack + (rucksack-maybe-index-changed-slot (or rucksack (rucksack object)) class object slot nil (slot-value object slot-name) nil t))))))) @@ -772,10 +773,11 @@ (defgeneric update-persistent-instance-for-redefined-class (instance added-slots discarded-slots property-list &key) - (:method ((instance persistent-object) added-slots discarded-slots property-list + (:method ((instance persistent-object) added-slots discarded-slots plist &key) ;; Default method: ignore the discarded slots and initialize added slots - ;; according to their initfunctions. + ;; according to their initforms. We do this 'by hand' and not by calling + ;; SHARED-INITIALIZE because slot indexes may need to be updated too. (let ((slots (class-slots (class-of instance)))) (loop for slot-name in added-slots for slot = (find slot-name slots :key #'slot-definition-name) @@ -789,3 +791,15 @@ ;; arguments are provided." do (setf (slot-value instance slot-name) (funcall initfunction)))))) + +(defmethod update-instance-for-redefined-class + ((object persistent-object) added-slots discarded-slots plist + &rest initargs &key) + ;; This method exists for updating in-memory persistent objects + ;; of which the class definition has changed. + (declare (ignore initargs)) ; there shouldn't be any, anyway + (cache-touch-object object (rucksack-cache (rucksack object))) + (update-persistent-instance-for-redefined-class object added-slots + discarded-slots plist)) + + --- /project/rucksack/cvsroot/rucksack/test-index-1a.lisp 2006/09/01 13:57:07 1.3 +++ /project/rucksack/cvsroot/rucksack/test-index-1a.lisp 2006/09/03 14:40:51 1.4 @@ -1,4 +1,4 @@ -;; $Id: test-index-1a.lisp,v 1.3 2006/09/01 13:57:07 alemmens Exp $ +;; $Id: test-index-1a.lisp,v 1.4 2006/09/03 14:40:51 alemmens Exp $ (in-package :rucksack-test) @@ -94,7 +94,7 @@ #| -TEST-RS 3 > (create-hackers) +RS-TEST 3 > (create-hackers) # # @@ -129,7 +129,7 @@ NIL T -TEST-RS 4 > (show-hackers) +RS-TEST 4 > (show-hackers) "Hackers indexed by object id." # From alemmens at common-lisp.net Mon Sep 4 12:34:35 2006 From: alemmens at common-lisp.net (alemmens) Date: Mon, 4 Sep 2006 08:34:35 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060904123435.A4E035406D@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv7254 Modified Files: do.txt done.txt garbage-collector.lisp heap.lisp mop.lisp objects.lisp test-schema-update-1a.lisp test-schema-update-1b.lisp test-schema-update-1c.lisp Log Message: Take care of some differences between the MOP implementations of Lispworks and SBCL. Lispworks doesn call (SETF SLOT-VALUE-USING-CLASS) in SHARED-INITIALIZE, but SBCL does. Lispworks calls FINALIZE-INHERITANCE after a class is redefined and a new instance is created, but SBCL doesn't. All tests now work for Lispworks (5.0) and SBCL (0.9.16). Some work on a copying GC. --- /project/rucksack/cvsroot/rucksack/do.txt 2006/09/03 14:40:50 1.4 +++ /project/rucksack/cvsroot/rucksack/do.txt 2006/09/04 12:34:34 1.5 @@ -1,5 +1,9 @@ DO: +- In SBCL, FINALIZE-INHERITANCE is not called when a class was redefined + and a new instance of the redefined class is created. (In Lispworks, + it *is* called then.) + - Make Rucksack crash proof. (Use a copying GC?) - There's still a btree bug that's detected (very rarely) by the --- /project/rucksack/cvsroot/rucksack/done.txt 2006/09/03 14:40:51 1.4 +++ /project/rucksack/cvsroot/rucksack/done.txt 2006/09/04 12:34:34 1.5 @@ -1,3 +1,13 @@ +* 2006-09-04 + +- Take care of some differences between the MOP implementations of Lispworks + and SBCL. Lispworks doesn't call (setf slot-value-using-class) in + SHARED-INITIALIZE, but SBCL does. Lispworks calls FINALIZE-INHERITANCE + after a class is redefined and a new instance is created, but SBCL + doesn't. All tests now work for Lispworks (5.0) and SBCL (0.9.16). + +- Some work on a copying GC. + * 2006-09-03 - Handle updates of in-memory persistent objects by writing a method --- /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/08/24 15:21:25 1.18 +++ /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/09/04 12:34:34 1.19 @@ -1,4 +1,4 @@ -;; $Id: garbage-collector.lisp,v 1.18 2006/08/24 15:21:25 alemmens Exp $ +;; $Id: garbage-collector.lisp,v 1.19 2006/09/04 12:34:34 alemmens Exp $ (in-package :rucksack) @@ -7,7 +7,30 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass garbage-collector () - ()) + ((object-table :initarg :object-table :reader object-table) + (buffer :initform (make-instance 'serialization-buffer) + :reader serialization-buffer) + (rucksack :initarg :rucksack :reader rucksack) + ;; Some state used for incremental garbage collection. + (roots :initarg :roots :initform '() :accessor roots + :documentation "A list of object-ids of roots that must be kept alive.") + (state :initform :ready + :type (member :starting + :finishing + :ready + ;; For copying collector + :copying + ;; For mark-and-sweep collector + :marking-object-table + :scanning + :sweeping-heap + :sweeping-object-table) + :accessor state) + (doing-work :initform nil :accessor gc-doing-work + ;; NOTE: This flag is probably not necessary anymore and + ;; should probably be removed. + :documentation + "A flag to prevent recursive calls to COLLECT-SOME-GARBAGE."))) (defgeneric scan (buffer garbage-collector) @@ -24,33 +47,42 @@ ;; Most of the SCAN-CONTENTS methods are in serialize.lisp. (scan-contents marker buffer gc))) + + +(defmethod gc-work-for-size ((heap heap) size) + ;; The garbage collector needs to be ready when there's no more free space + ;; left in the heap. So when SIZE octets are allocated, the garbage collector + ;; needs to collect a proportional amount of bytes: + ;; + ;; Size / Free = Work / WorkLeft + ;; + ;; or: Work = (Size / Free) * WorkLeft + ;; + (if (zerop size) + 0 + (let* ((free (free-space heap)) + (work-left (work-left heap))) + (if (>= size free) + work-left + (floor (* size work-left) free))))) + +(defmethod free-space ((heap heap)) + ;; Returns an estimate of the number of octets that can be + ;; allocated until the heap is full (i.e. heap-end >= heap-max-end). + ;; For a copying collector, this number is very close to the truth. + ;; But for mark-and-sweep collectorsestimate it is a very conservative + ;; estimate, because we only count the heap space that hasn't been + ;; reserved by one of the free lists (because you can't be sure that + ;; a free list block can actually be used to allocate an arbitrary-sized + ;; block). + (- (max-heap-end heap) (heap-end heap))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Mark and sweep collector ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass mark-and-sweep-heap (garbage-collector free-list-heap serializer) - ((object-table :initarg :object-table :reader object-table) - (buffer :initform (make-instance 'serialization-buffer) - :reader serialization-buffer) - (rucksack :initarg :rucksack :reader rucksack) - ;; Some state used for incremental garbage collection. - (roots :initarg :roots :initform '() :accessor roots - :documentation "A list of object-ids of roots that must be marked.") - (state :initform :ready - :type (member :starting - :marking-object-table - :scanning - :sweeping-heap - :sweeping-object-table - :finishing - :ready) - :accessor state) - (doing-work :initform nil :accessor gc-doing-work - ;; NOTE: This flag is probably not necessary anymore and - ;; should probably be removed. - :documentation - "A flag to prevent recursive calls to COLLECT-SOME-GARBAGE.") - ;; Some counters that keep track of the amount of work done by + (;; Some counters that keep track of the amount of work done by ;; the garbage collector. (nr-object-bytes-marked :initform 0 :accessor nr-object-bytes-marked) (nr-heap-bytes-scanned :initform 0 :accessor nr-heap-bytes-scanned) @@ -92,7 +124,6 @@ (defmethod close-heap :after ((heap mark-and-sweep-heap)) (close-heap (object-table heap))) - (defmethod initialize-block (block block-size (heap mark-and-sweep-heap)) ;; This is called by a free list heap while creating free blocks. ;; Write the block size (as a negative number) in the start of the @@ -122,32 +153,7 @@ ;; Hooking into free list methods ;; -(defmethod gc-work-for-size ((heap mark-and-sweep-heap) size) - ;; The garbage collector needs to be ready when there's no more free space - ;; left in the heap. So when SIZE octets are allocated, the garbage collector - ;; needs to collect a proportional amount of bytes: - ;; - ;; Size / Free = Work / WorkLeft - ;; - ;; or: Work = (Size / Free) * WorkLeft - ;; - (if (zerop size) - 0 - (let* ((free (free-space heap)) - (work-left (work-left heap))) - (if (>= size free) - work-left - (floor (* size work-left) free))))) - -(defmethod free-space ((heap mark-and-sweep-heap)) - ;; Returns an estimate of the number of octets that can be - ;; allocated until the heap is full (i.e. heap-end >= heap-max-end). - ;; We use a conservative estimate and only count the heap space that - ;; hasn't been reserved by one of the free lists (because you can't - ;; be sure that a free list block can actually be used to allocate - ;; an arbitrary-sized block). - (- (max-heap-end heap) (heap-end heap))) (defmethod expand-heap :after ((heap mark-and-sweep-heap) block-size) @@ -480,12 +486,8 @@ #| MAYBE LATER -(defclass compacting-heap (heap) - ((top :initform 0 :accessor top - :documentation "The file-position where new objects can be allocated."))) - -(defclass copying-collector (garbage-collector serializer) +(defclass copying-heap (garbage-collector serializer) ((space-0 :initarg :space-0 :reader space-0) (space-1 :initarg :space-1 :reader space-1) (from-space :accessor from-space) @@ -494,6 +496,14 @@ :documentation "The position in to-space where the next object can be evacuated."))) +(defmethod collect-some-garbage ((heap copying-collector) amount) + 'DO-THIS) + +(defmethod gc-work-for-size ((heap copying-collector) nr-allocated-octets) + 'DO-THIS) + +(defmethod close-heap :after ((heap copying-heap)) + (close-heap (object-table heap))) (defmethod deserialize-byte ((gc copying-collector) &optional (eof-error-p t)) @@ -551,7 +561,8 @@ ;; -(defmethod trace-contents ((marker (eql +cached-object+)) +(defmethod scan-contents ((marker (eql +cached-object+)) + buffer (gc copying-collector)) ;; Hook into the scanner: when the scanner finds a cached-object, ;; it evacuates that object and returns. --- /project/rucksack/cvsroot/rucksack/heap.lisp 2006/08/10 12:36:16 1.11 +++ /project/rucksack/cvsroot/rucksack/heap.lisp 2006/09/04 12:34:34 1.12 @@ -1,4 +1,4 @@ -;; $Id: heap.lisp,v 1.11 2006/08/10 12:36:16 alemmens Exp $ +;; $Id: heap.lisp,v 1.12 2006/09/04 12:34:34 alemmens Exp $ (in-package :rucksack) @@ -18,6 +18,9 @@ (defgeneric heap-stream (heap) (:documentation "Returns the heap's stream.")) +(defgeneric heap-start (heap) + (:documentation "Returns the position of the first block in the heap.")) + (defgeneric heap-end (heap) (:documentation "Returns the end of the heap.")) @@ -52,8 +55,9 @@ ;; Just a buffer for 1 cell. :reader cell-buffer) (end :accessor heap-end - :documentation "The end of the heap. This number is stored in the first -heap cell.") + :documentation "The end of the heap. For free-list heaps, this number +is stored in the first heap cell. For appending heaps, it's stored in the +end of the file.") (max-size :initarg :max-size :initform nil :accessor max-heap-size :documentation "The maximum size (in octets) for the heap. @@ -70,14 +74,6 @@ ;; Open/close/initialize ;; -(defmethod initialize-instance :after ((heap heap) &key &allow-other-keys) - ;; Initialize the heap end. - (if (zerop (file-length (heap-stream heap))) - (setf (heap-end heap) +pointer-size+) - (setf (slot-value heap 'end) (pointer-value 0 heap)))) - - - (defun open-heap (pathname &key (class 'heap) rucksack (options '()) (if-exists :overwrite) (if-does-not-exist :create)) @@ -99,19 +95,9 @@ (defmethod finish-heap-output ((heap heap)) (finish-output (heap-stream heap))) -;; -;; Heap start/end -;; - -(defgeneric heap-start (heap) - (:method ((heap heap)) - ;; Default: return the position just after the heap end cell. - +pointer-size+) - (:documentation "Returns the position of the first block in the heap.")) -(defmethod (setf heap-end) :after (end (heap heap)) - ;; Store the heap end in the file. - (setf (pointer-value 0 heap) end)) +(defmethod heap-size ((heap heap)) + (- (heap-end heap) (heap-start heap))) ;; ;; Pointers @@ -205,6 +191,10 @@ (defmethod initialize-instance :after ((heap free-list-heap) &key &allow-other-keys) + ;; Initialize the heap end. + (if (zerop (file-length (heap-stream heap))) + (setf (heap-end heap) +pointer-size+) + (setf (slot-value heap 'end) (pointer-value 0 heap))) ;; Load or create the array of free list pointers. (setf (slot-value heap 'starts) (make-array (nr-free-lists heap))) @@ -230,6 +220,16 @@ (+ +pointer-size+ ; skip heap end cell (* size-class +pointer-size+))) + +(defmethod heap-start ((heap free-list-heap)) + ;; A free-list-heap starts with an array of pointers to the first element + ;; of each free list; the heap blocks start after that array. + (free-list-pointer (nr-free-lists heap))) + +(defmethod (setf heap-end) :after (end (heap free-list-heap)) + ;; Store the heap end in the file. + (setf (pointer-value 0 heap) end)) + ;; ;; @@ -291,17 +291,6 @@ ;; the block is occupied. (block-header block heap)) -;; -;; - - -(defmethod heap-start ((heap free-list-heap)) - ;; A free-list-heap starts with an array of pointers to the first element - ;; of each free list; the heap blocks start after that array. - (free-list-pointer (nr-free-lists heap))) - -(defmethod heap-size ((heap free-list-heap)) - (- (heap-end heap) (heap-start heap))) ;; ;; Allocating and deallocating blocks @@ -467,6 +456,45 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Appending heap (as used by copying garbage collector) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass appending-heap (heap) + ;; For an APPENDING-HEAP, all writes take place to the heap's end. + ;; The last 7 octets of the file always contain a serialized version + ;; of the heap's end. + ()) + +(defmethod allocate-block ((heap appending-heap) &key size &allow-other-keys) + (let ((block (heap-end heap))) + ;; Put block size (including the size of header) into header. + (setf (block-size block heap) size) + ;; + (incf (heap-end heap) size) + (values block size))) + +(defmethod (setf heap-end) :after (end (heap appending-heap)) + (let ((stream (heap-stream heap))) + (file-position stream end) + ;; Write new end to the end of the file. + (serialize-marker +positive-byte-48+ stream) + (serialize-byte-48 end stream))) + +(defmethod heap-start ((heap appending-heap)) + 0) + +(defmethod load-heap-end ((heap appending-heap)) + (let* ((stream (heap-stream heap)) + ;; 7 octets: one for a marker, 6 for a byte-48. + (pos (- (file-length stream) 7))) + (file-position stream pos) + (let ((end (deserialize stream))) + (unless (= end pos) + (error "Heap may be corrupt (heap-end info is missing.")) + (setf (slot-value heap 'end) end)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Little utility functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; --- /project/rucksack/cvsroot/rucksack/mop.lisp 2006/09/01 13:57:07 1.10 +++ /project/rucksack/cvsroot/rucksack/mop.lisp 2006/09/04 12:34:34 1.11 @@ -1,4 +1,4 @@ -;; $Id: mop.lisp,v 1.10 2006/09/01 13:57:07 alemmens Exp $ +;; $Id: mop.lisp,v 1.11 2006/09/04 12:34:34 alemmens Exp $ (in-package :rucksack) @@ -15,7 +15,13 @@ :accessor class-persistent-slots) (index :initarg :index :initform nil :documentation "Can be either NIL (for no class index) or T -(for the standard class index). Default value is NIL."))) +(for the standard class index). Default value is NIL.") + (changed-p :initform nil :accessor class-changed-p + :documentation "True iff the class definition was changed +but the schemas haven't been updated yet. This flag is necessary because +some MOP implementations don't call FINALIZE-INHERITANCE when a class +was redefined and a new instance of the redefined class is created."))) + (defmethod class-index ((class persistent-class)) ;; According to the MOP, the INDEX slot is initialized with the @@ -151,10 +157,12 @@ ;; SLOT-VALUE-USING-CLASS. #+lispworks :optimize-slot-access #+lispworks nil args))) + (setf (class-changed-p class) t) (update-indexes class) result)) + (defun maybe-add-persistent-object-class (class direct-superclasses) ;; Add PERSISTENT-OBJECT to the superclass list if necessary. (let ((root-class (find-class 'persistent-object nil)) @@ -183,6 +191,9 @@ (defmethod finalize-inheritance :after ((class persistent-class)) + (update-slot-info class)) + +(defun update-slot-info (class) ;; Register all (effective) persistent slots. (setf (class-persistent-slots class) (remove-if-not #'slot-persistence (class-slots class))) @@ -191,8 +202,13 @@ (let ((rucksack (current-rucksack))) (when rucksack (maybe-update-schemas (schema-table (rucksack-cache rucksack)) - class))))) - + class)))) + ;; + (setf (class-changed-p class) nil)) + +(defun maybe-update-slot-info (class) + (when (class-changed-p class) + (update-slot-info class))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Computing slot definitions @@ -236,3 +252,4 @@ ;; Return the effective slot definition. effective-slotdef)) + --- /project/rucksack/cvsroot/rucksack/objects.lisp 2006/09/03 14:40:51 1.16 +++ /project/rucksack/cvsroot/rucksack/objects.lisp 2006/09/04 12:34:34 1.17 @@ -1,4 +1,4 @@ -;; $Id: objects.lisp,v 1.16 2006/09/03 14:40:51 alemmens Exp $ +;; $Id: objects.lisp,v 1.17 2006/09/04 12:34:34 alemmens Exp $ (in-package :rucksack) @@ -402,8 +402,14 @@ inherit from this class.")) +(defparameter *initializing-instance* + ;; A hack to paper over some MOP differences. Maybe a cleaner way + ;; to solve this would be to write our own method for SHARED-INITIALIZE, + ;; as suggested by Pascal Costanza. + ;; See emails of 2006-09-03/04 on rucksack-devel at common-lisp.net. + nil) -(defmethod initialize-instance :before ((object persistent-object) +(defmethod initialize-instance :around ((object persistent-object) &rest args &key rucksack ;; The DONT-INDEX argument is used @@ -411,6 +417,7 @@ ;; (to prevent infinite recursion). (dont-index nil) &allow-other-keys) + (maybe-update-slot-info (class-of object)) ;; This happens when persistent-objects are created in memory, not when ;; they're loaded from the cache (loading uses ALLOCATE-INSTANCE instead). (let ((rucksack (or rucksack (rucksack object)))) @@ -421,23 +428,27 @@ (unless (slot-boundp object 'rucksack) (setf (slot-value object 'rucksack) rucksack)) (unless dont-index - (rucksack-maybe-index-new-object rucksack (class-of object) object)))) - -(defmethod initialize-instance :after ((object persistent-object) - &rest args - &key rucksack (dont-index nil) - &allow-other-keys) - ;; Update slot indexes for persistent slots that are bound now. - (unless dont-index - (let ((class (class-of object))) - (dolist (slot (class-slots class)) - (let ((slot-name (slot-definition-name slot))) - (when (and (slot-boundp object slot-name) - (slot-persistence slot)) - (rucksack-maybe-index-changed-slot (or rucksack (rucksack object)) - class object slot - nil (slot-value object slot-name) - nil t))))))) + (rucksack-maybe-index-new-object rucksack (class-of object) object))) + ;; + (let (;; Tell (SETF SLOT-VALUE-USING-CLASS), which may be called + ;; by SHARED-INITIALIZE in some implementations, that we're + ;; just initializing the instance and it shouldn't try to + ;; update any indexes. + (*initializing-instance* t)) + (let ((result (call-next-method))) + ;; Update slot indexes for persistent slots that are bound now. + (unless dont-index + (let ((class (class-of object))) + (dolist (slot (class-slots class)) + (let ((slot-name (slot-definition-name slot))) + (when (and (slot-boundp object slot-name) + (slot-persistence slot)) + (rucksack-maybe-index-changed-slot (or rucksack (rucksack object)) + class object slot + nil (slot-value object slot-name) + nil t)))))) + ;; + result))) (defmethod print-object ((object persistent-object) stream) @@ -468,8 +479,8 @@ (defmethod slot-value-using-class :around ((class persistent-class) object slot) + (maybe-update-slot-info class) ;; Automatically dereference proxies. - (declare (ignore class slot)) (maybe-dereference-proxy (call-next-method))) @@ -477,6 +488,7 @@ (class persistent-class) object slot-name-or-def) + (maybe-update-slot-info class) ;; If this is a persistent slot, tell the cache that this object ;; has changed. The cache will save it when necessary. (let ((slot (slot-def-and-name class slot-name-or-def))) @@ -492,10 +504,11 @@ (result (call-next-method))) (cache-touch-object object (cache object)) ;; Update indexes. - (rucksack-maybe-index-changed-slot (rucksack object) - class object slot - old-value new-value - old-boundp t) + (unless *initializing-instance* + (rucksack-maybe-index-changed-slot (rucksack object) + class object slot + old-value new-value + old-boundp t)) result) (call-next-method)))) @@ -503,6 +516,7 @@ (defmethod slot-makunbound-using-class :around ((class persistent-class) object slot-name-or-def) + (maybe-update-slot-info class) ;; If this is a persistent slot, tell the cache that this object ;; has changed. Rely on the cache to save it when necessary. (let ((slot (slot-def-and-name class slot-name-or-def))) --- /project/rucksack/cvsroot/rucksack/test-schema-update-1a.lisp 2006/09/01 13:57:07 1.2 +++ /project/rucksack/cvsroot/rucksack/test-schema-update-1a.lisp 2006/09/04 12:34:34 1.3 @@ -1,12 +1,15 @@ -;; $Id: test-schema-update-1a.lisp,v 1.2 2006/09/01 13:57:07 alemmens Exp $ +;; $Id: test-schema-update-1a.lisp,v 1.3 2006/09/04 12:34:34 alemmens Exp $ (in-package :rucksack-test-schema-update) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Schema updates and UPDATE-INSTANCE-FOR-REDEFINED-CLASS, part 1 of 3 ;;; -;;; After compiling and loading this file, compile and load -;;; test-schema-update-1b.lisp. +;;; After compiling and loading this file, evaluate: +;;; - (in-package :rucksack-test-schema-update) +;;; - (test-1) +;;; +;;; Then move on to test-schema-update-1b.lisp. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *names* '(john dick mary jane peter ronald)) @@ -40,17 +43,17 @@ (name person) (age person)))) -;; Create some persons. -(with-rucksack (rs *dir*) - (with-transaction () - (loop repeat 10 - do (make-instance 'person)))) - -;; Show them. -(with-rucksack (rs *dir*) - (with-transaction () - (rucksack-map-class rs 'person #'print))) +(defun test-1 () + ;; Create some persons. + (with-rucksack (rs *dir*) + (with-transaction () + (loop repeat 10 + do (make-instance 'person)))) + ;; Show them. + (with-rucksack (rs *dir*) + (with-transaction () + (rucksack-map-class rs 'person #'print)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Sample output --- /project/rucksack/cvsroot/rucksack/test-schema-update-1b.lisp 2006/09/01 13:57:07 1.2 +++ /project/rucksack/cvsroot/rucksack/test-schema-update-1b.lisp 2006/09/04 12:34:34 1.3 @@ -1,13 +1,15 @@ -;; $Id: test-schema-update-1b.lisp,v 1.2 2006/09/01 13:57:07 alemmens Exp $ +;; $Id: test-schema-update-1b.lisp,v 1.3 2006/09/04 12:34:34 alemmens Exp $ (in-package :rucksack-test-schema-update) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Schema updates and UPDATE-INSTANCE-FOR-REDEFINED-CLASS, part 2 of 3 ;;; -;;; Compile and load this file after compiling and loading -;;; test-schema-update-1a.lisp. Study the output, and then compile -;;; and load test-schema-update-1c.lisp. +;;; Run this example after test-schema-update-1a.lisp: +;;; +;;; - Compile and load this file +;;; - Evaluate (TEST-2) +;;; - Then move on to test-schema-update-1c.lisp. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -49,27 +51,28 @@ (- +this-year+ (year-of-birth person))) -;; Create some persons with the new class definition. -(with-rucksack (rs *dir*) - (with-transaction () - (loop repeat 10 - do (make-instance 'person)))) - -;; Show some PERSON instances and some old PERSON instances. -;; (We don't show all PERSON instances, because showing them may -;; update them and we want to keep a few old instances for the next -;; part of the test). - -(with-rucksack (rs *dir*) - (with-transaction () - (let ((cache (rucksack-cache rs)) - (count 0)) - (rucksack-map-class rs 'person - (lambda (id) - (when (evenp count) - (print (cache-get-object id cache))) - (incf count)) - :id-only t)))) +(defun test-2 () + ;; Create some persons with the new class definition. + (with-rucksack (rs *dir*) + (with-transaction () + (loop repeat 10 + do (make-instance 'person)))) + + ;; Show some PERSON instances and some old PERSON instances. + ;; (We don't show all PERSON instances, because showing them may + ;; update them and we want to keep a few old instances for the next + ;; part of the test). + + (with-rucksack (rs *dir*) + (with-transaction () + (let ((cache (rucksack-cache rs)) + (count 0)) + (rucksack-map-class rs 'person + (lambda (id) + (when (evenp count) + (print (cache-get-object id cache))) + (incf count)) + :id-only t))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; --- /project/rucksack/cvsroot/rucksack/test-schema-update-1c.lisp 2006/09/01 13:57:07 1.2 +++ /project/rucksack/cvsroot/rucksack/test-schema-update-1c.lisp 2006/09/04 12:34:34 1.3 @@ -1,12 +1,13 @@ -;; $Id: test-schema-update-1c.lisp,v 1.2 2006/09/01 13:57:07 alemmens Exp $ +;; $Id: test-schema-update-1c.lisp,v 1.3 2006/09/04 12:34:34 alemmens Exp $ (in-package :rucksack-test-schema-update) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Schema updates and UPDATE-INSTANCE-FOR-REDEFINED-CLASS, part 3 of 3 ;;; -;;; Compile and load this file after compiling and loading -;;; test-schema-update-1c.lisp +;;; Run this example after test-schema-update-1b.lisp: +;;; - compile and load this file +;;; - evaluate (TEST-3) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -72,16 +73,16 @@ (nth-value 5 (decode-universal-time (date-of-birth person)))) -;; Create some persons with the second version of the class definition. -(with-rucksack (rs *dir*) - (with-transaction () - (loop repeat 10 - do (make-instance 'person)))) - -;; Show all persons (for three versions of the class definition). -(with-rucksack (rs *dir*) - (with-transaction () - (rucksack-map-class rs 'person #'print))) +(defun test-3 () + ;; Create some persons with the second version of the class definition. + (with-rucksack (rs *dir*) + (with-transaction () + (loop repeat 10 + do (make-instance 'person)))) + ;; Show all persons (for three versions of the class definition). + (with-rucksack (rs *dir*) + (with-transaction () + (rucksack-map-class rs 'person #'print)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Sample output