Re: Persistent objects

[Gregor.pa@Xerox.COM]

    Date: Fri, 22 Jul 88 09:24:47 PDT
    From: Andreas Paepcke <paepcke%hplap@hplabs.HP.COM>

    The PCLOS imlementation is similar to what Gregor outlines. The object id,
    however, doesn't show up as a slot which would be seen by the user through
    'describe'. Information like the object id is instead hidden in some fields
    at the beginning of the slot value vector.  This is one of the tricks that
    are easy to do through a new metaclass and it adds to the transparency of
    persistence.

This trick is undocumented, and will not be supported as such by CLOS or
in any documented way by PCL.  The really proper way to do this is to
use a slot.  To hide this slot from describe, you should define your own
describe method which doesn't show it.  This is good style for using
describe anyways.

    The problem with slot access optimization by methods of superclasses of a
    different metaclass is insidious. It has caused me grief until I understood
    it. Unfortunately the solution Gregor suggests - of simply not allowing
    such inheritance - is problematic in the real world. We have encountered
    several cases where we needed to inherit in this way and the superclasses
    could not be touched because we get them canned. There was originally talk
    about an "unoptimize" capability which would presumably go through a method
    and turn all the optimized slot accesses into calls to slot-value. I am not
    sure how that could possibly be done on binaries, but I refuse to give up
    my believe in magic. So I am looking for that as a way out of the dilemma.

Future versions of PCL will support a documented mechanism for deoptimizing
inherited slot accesses.  This rest of this message describes an
undocumented PCL mechanism for achieving the same effect.

This example code is a supplement to the db-class I sent out yesterday.
For the code presented here to work, there are a couple patches at the
end of this message that you will have to make to your PCL.  

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


;;; Here is a demo.
;;; 

(defclass bazola-1 ()
     ((bazola-1 :initform 0 :accessor boof)))

(defclass bazola-2 (bazola-1)
     ()
  (:metaclass db-class))

(defmethod bazola-1 ((b bazola-1))
  (slot-value b 'bazola-1))

(setq b2 (mki 'bazola-2))


;;;
;;; Here are some tests.
;;; 
(boof b2)            ;0
(setf (boof b2) 3)   ;3

(bazola-1 b2)        ;3



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