Re: Persistent objects

[David C. Martin <dcmartin%postgres.Berkeley.EDU@Berkeley.EDU>]

I reimplemented the Shared Object Hierarchy under the 3/17/88 PCL and made use
of the iwmc-class structure to reference through a handle to get the
shared semantics.  

Basically, I make two iwmc-class structs and set the same class-wrapper 
pointer for both.  The handle instance has a simple-vector off the 
iwmc-class-static-slots which contains the object-id and a cache reference to 
the storage instance.  The storage instance is a standard instance and has the 
standard simple-vector for storing the instance values.

I then make use of a hash-table to allow an object-manager to flush arbitrary 
shared-objects (the storage instance) to the dbms and invalidate the handle's 
cache reference (via a backward pointer to the handle from the hash-table).

I have extended this design to include both shared-objects and shared-classes.

dcm

ps. code on demand.

--------
Your message:

        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 thro
   ugh
        'describe'. Information like the object id is instead hidden in some fi
   elds
        at the beginning of the slot value vector.  This is one of the tricks t
   hat
        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 unders
   tood
        it. Unfortunately the solution Gregor suggests - of simply not allowing
        such inheritance - is problematic in the real world. We have encountere
   d
        several cases where we needed to inherit in this way and the superclass
   es
        could not be touched because we get them canned. There was originally t
   alk
        about an "unoptimize" capability which would presumably go through a me
   thod
        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 dilem
   ma.

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