Re: method discrimination on persistent objects

[Gregor.pa@Xerox.COM]

Oh hell.  One more random typo fixed.  This is version 4.

This message is a version of the db-class stuff with all the changes
incorporated.  Typos are fixed, and the stuff which makes inherited slot
accesses be deoptimized is included.  

I have spent a little time thinking about the question you asked.  I
haven't answered sooner because I have been to busy to type in a long
reply.  I am still too busy so this will be a short reply.  Once I get
back from the Lisp conference I will be able to send more.

It seems to me that having make-instance return an object-id rather than
an object itself is causing problems.  I think a form of your third
solution is the way to go.  Here are some ideas about how to do it in
PCL.  Some of this is undocumented PCL, and will change in the next few
months.  But there is a corresponding part to all of this in the Chapter
3 we are working on.

We will define a new metaclass called db-class.  The feature of
this metaclass is that it will store the values of the slots for its
metainstances in the database.  The only thing stored in core will be
the object-id of the instance.  This implementation has an important 
problem which could be fixed later.  It allocates space for the database
slots in core even though this space is never used.  This could be fixed
later, remind me next week after the Lisp Conference.

(defclass db-class (standard-class)
     ())

As soon as the instances are allocated, we have to set their object-id.

(defmethod allocate-instance ((class db-class))
  (let ((instance (call-next-method)))
    (setf (slot-value instance 'object-id) (allocate-object-id))
    instance))

We need to add the special slot object-id slot to all db-classes.  This
just arranges to tack the slot onto all the other slots a given db-class
inherits.

(defmethod collect-slotds ((class db-class) local-slots cpl)
  (cons (make-slotd (find-class 'standard-slot-description)
		    :name 'object-id
		    :allocation :instance)
	(call-next-method)))

Now we need to teach slot-value for the class to use the value stored
in the database.  Of course the object-id slot is special as it is
stored in core.

(defmethod slot-value-using-class ((class db-class) object slot-name)
  (if (eq slot-name 'object-id)
      (call-next-method)
      (if (find slot-name (class-slots class) :key #'slotd-name)
	  (GET-VALUE-FROM-DB (slot-value object 'object-id)
			     slot-name)
	  (slot-missing object slot-name))))

(defmethod put-slot-using-class ((class db-class) object slot-name new-value)
  (if (eq slot-name 'object-id)
      (call-next-method)
      (if (find slot-name (class-slots class) :key #'slotd-name)
	  (PUT-VALUE-IN-DB (slot-value object 'object-id)
			   slot-name
			   new-value)
	  (slot-missing object slot-name))))

We also want to be able to use automatically generated accessor methods
to access the slots.  We need to make sure PCL uses the right code for
getting at these slots.

(defmethod make-reader-method-function ((class db-class) slotd)
  (let ((slot-name (slotd-name slotd)))
    #'(lambda (object)
	(slot-value object slot-name))))

(defmethod make-writer-method-function ((class db-class) slotd)
  (let ((slot-name (slotd-name slotd)))
    #'(lambda (object new-value)
	(setf (slot-value object slot-name) new-value))))


We need to make sure that any optimized calls to slot-value we inherit
get deoptimized appropriately.  We also need to have optimized accessor
methods get deoptimized appropriately.  De-optimization means having
any calls to these trap out to calling slot-value-using-class or
put-slot-using-class.

This code takes advantage of undocumented PCL functionality.  Well, its
documented now because I just told you about it.  There will be a more
elegant mechanism for doing this in future versions of PCL, as well as
in the CLOS spec.


This method arranges for all optimized accesses to any slot of a
db-class to trap through slot-value-using-class.
 
(defmethod lookup-pv-miss-1 ((class db-class) slots pv)
  (dolist (slot slots)
    (push nil pv))
  pv)

This method arranges for all inherited reader and writer methods to
trap through slot-value-using-class.
 
(defmethod all-std-class-readers-miss-1 ((class db-class) slot-name)
  ())


Given this, the proper method for check-super-metaclass-compatibility
is.

(defmethod check-super-metaclass-compatibility ((class db-class)
						(new-super standard-class))
  t)


It doesn't seem worth doing slot-value optimization because of the time
required to go to the database.  We have to disable the optimization
method we would otherwise inherit.

(defmethod optimize-slot-value ((class db-class) form) form)
(defmethod optimize-set-slot-value ((class db-class) form) form)

Here are some stubs for the Database stuff.  This just arranges to store
the values in a different place so that we can show that the values
aren't being stored in the instance.  Note that the way I have this
setup, the database doesn't get any advance warning about the existence
of a new object id.  That would be easy to fix by having
allocate-object-id inform the database it just made a new id.


(defvar *db* ())
(defun get-value-from-db (object-id slot-name)
  (getf (cdr (get-db-internal object-id)) slot-name))
(defun put-value-in-db (object-id slot-name new-value)
  (setf (getf (cdr (get-db-internal object-id)) slot-name)
	new-value))

(defun get-db-internal (object-id)  
  (let ((instance (assq object-id *db*)))
    (unless instance
      (setq instance (list object-id))
      (push instance *db*))
    instance))


(defun allocate-object-id ()
  (gensym))


;;;
;;; Here is some code that tries it all out.
;;;
(defclass pos ()
     ((x :initform 0 :accessor pos-x)
      (y :initform 0 :accessor pos-y)))

(defmethod describe-object ((p pos) stream)
  (format stream
	  "~&~S is a position, stored in the database.~@
           Its x coordinate is ~D, its y coordinate is ~D."
	  p (pos-x p) (pos-y p)))

(defmethod move ((p pos) dx dy)
  (with-slots (x y) p
    (incf x dx)
    (incf y dy)))


(defclass db-pos (pos)
     ()
  (:metaclass db-class))

(setq p1 (mki 'db-pos))
#<Position 27345>

(move p1 -3 5)

(describe-object p1 *standard-output*)
#<POS 104130217> is a position, stored in the database.
Its x coordinate is -3, its y coordinate is 5.


;;;
;;; The following patches must be made to the 7/20 version of PCL for
;;; the strategy outlined above to work.  The nature of these changes
;;; is such that you will have to make them, use compile-pcl to compile
;;; them, load a fresh pcl, and load your code.  You do not have to
;;; recompile your code.
;;; 

;from vector.lisp, replace lookup-pv-miss with these two definitions

(defun lookup-pv-miss (isl &rest wrappers)
  (let ((pv ())
	(class-slots nil))
    (dolist (slots (cdr isl))
      (when slots
	(when (null wrappers)
	  (error "Fewer classes than indicated by the isl."))
	(let ((class (class-wrapper-class (pop wrappers))))
	  (setq pv (lookup-pv-miss-1 class slots pv)))))
    (when wrappers
      (error "More classes than indicated by the isl."))
    (intern-pv (reverse pv))))

(defmethod lookup-pv-miss-1 ((class standard-class) slots pv)
  ;; *** Later this wants to fetch the cached info from
  ;; *** the class wrapper.
  (let ((class-slots (class-instance-slots class)))
    (dolist (slot slots)
      (push (position slot class-slots :key #'slotd-name) pv))
    pv))

;from vector.lisp, replace pv-access-trap with this definition.

(defun pv-access-trap (instance offset isl &optional (new-value nil nvp))
  (let ((slot-name nil)
	(i 0))
    (dolist (per-class-slots (cdr isl))
      (dolist (slot per-class-slots)
	(when (= i offset)
	  (return (setq slot-name slot)))
	(incf i)))
    (when (null slot-name)
      (error "Internal Error:~@
              Unable to determine the name of the slot from the PV-OFFSET~@
              and the ISL.  This results from inconsistency between the~@
              PV-OFFSET this access was told to use and the ISL for the~@
              method."))
    (if nvp
	(put-slot-using-class (class-of instance) instance slot-name new-value)
	(slot-value-using-class (class-of instance) instance slot-name))))

;from dcode.lisp replace the definition of all-std-class-readers-miss
;with the following definition
(defun all-std-class-readers-miss
       (arg wrapper .cache. offset generic-function)
  (let ((class (class-wrapper-class wrapper))
	(method (lookup-method-1 generic-function arg)))
    (if (null method)
	(no-matching-method generic-function)
	(let* ((slot-name (reader/writer-method-slot-name method))
	       (slot-pos (all-std-class-readers-miss-1 class slot-name)))
	  (if (not (null slot-pos))
	      (progn 
		;; This is an instance slot.  Convert it's position to its
		;; index, then cache the index.  Return the value of the slot.
		(setq slot-pos
		      (%convert-slotd-position-to-slot-index slot-pos))
		(without-interrupts
		  (setf (r/w-cache-key) wrapper)
		  (setf (r/w-cache-val) slot-pos))
		(get-static-slot--class arg slot-pos))
	       (slot-value-using-class class arg slot-name))))))

;from dcode.lisp, add this definition

(defmethod all-std-class-readers-miss-1 ((class standard-class) slot-name)
  (slotd-position slot-name (class-instance-slots class)))

;from dcode.lisp replace the definition of all-std-class-writers-miss
;with the following definition
(defun all-std-class-writers-miss
       (new-value arg wrapper .cache. offset generic-function)
  (let ((class (class-wrapper-class wrapper))
	(method (lookup-method-1 generic-function arg)))
    (if (null method)
	(no-matching-method generic-function)
	(let* ((slot-name (reader/writer-method-slot-name method))
	       (slot-pos (all-std-class-readers-miss-1 class slot-name)))
	  (if (not (null slot-pos))
	      (progn 
		(setq slot-pos
		      (%convert-slotd-position-to-slot-index slot-pos))
		(without-interrupts
		  (setf (r/w-cache-key) wrapper)
		  (setf (r/w-cache-val) slot-pos))
		(setf (get-static-slot--class arg slot-pos) new-value))
	      (put-slot-using-class class arg slot-name new-value))))))
-------