May Day PCL bugs affecting instances of redefined classes

[harrisr@turing.cs.rpi.edu (Richard Harris)]

Here are some bugs in May Day PCL I have found while
redefining classes which have existing instances.

;>>> Date: Tue, 3 Apr 90 12:06 PDT
;>>> From: Danny Bobrow <bobrow@parc.xerox.com>
;>>> Subject: Re: insert classes? 
;>>> Cc: CommonLoops.PA@Xerox.COM
;>>> ...
;>>> (reinitialize-instance	(find-class 'a)
;>>> 			:direct-superclasses (list (find-class 'c)))
;>>> 
;>>> This will change the direct-superclasses of A without affecting the
;>>> rest of its definition (e.g. slots defined, accessors).
;In May Day PCL, this call to reinitialize-instance does indeed affect
;the rest of its definition.  I just created an extra class which
;has no (direct) slots or accessors in order to avoid this problem.

;Here are the bugs I had to fix in order to make class redefinition work:

;1. Fix a bug in invalidate-wrapper: when the state is obsolete,
;   the state of every previous wrapper must be changed to obsolete.
;   [added the form (when (eq state 'obsolete) ...).]
;2. Change fill-cache so that it does not assume that its argument
;   is not already in the cache.  This is important because invalid
;   wrappers can cause the cache miss function primary-pv-cache-miss
;   to be called, and the corresponding valid wrappers might already be 
;   in the cache.
;   [added an extra argument to line-valid-p, and changed the calls to it.]
;3. Change add-pv-binding to insert code to update the wrapper variables
;   after calling primary-pv-cache-miss.
;   [emit-dlap and add-pv-binding were reorganized, added the function
;    emit-pv-dlap.]

;*** This is not a patch file.  You must edit the files
;*** cache.lisp, dlap.lisp, and vector.lisp.

;cache.lisp
(defun invalidate-wrapper (owrapper state nwrapper)
  (ecase state
    ((flush obsolete)
     (let ((new-previous ()))
       ;;
       ;; First off, a previous call to invalidate-wrapper may have
recorded
       ;; owrapper as an nwrapper to update to.  Since owrapper is about to
       ;; be invalid, it no longer makes sense to update to it.
       ;;
       ;; We go back and change the previously invalidated wrappers so that
       ;; they will now update directly to nwrapper.  This corresponds to a
       ;; kind of transitivity of wrapper updates.
       ;; 
       (dolist (previous (gethash owrapper *previous-nwrappers*))
	 (when (eq state 'obsolete)          ; obsolete must override flush
	   (setf (car previous) 'obsolete))
	 (setf (cadr previous) nwrapper)
	 (push previous new-previous))
       
       (iterate ((type (list-elements wrapper-layout))
		 (i (interval :from 0)))
	 (when (eq type 'number) (setf (wrapper-ref owrapper i) 0)))
       (push (setf (wrapper-state owrapper) (list state nwrapper))
	     new-previous)
       
       (setf (gethash owrapper *previous-nwrappers*) ()
	     (gethash nwrapper *previous-nwrappers*) new-previous)))))

;(defvar *local-cache-functions*
;	`(
;...
	  ;;
	  ;; Given a line number, return true IFF the line is full and
	  ;; there are no invalid wrappers in the line, and the line's
	  ;; wrappers are different from wrappers.
	  ;; An error is signalled if the line is reserved.
	  ;;
	  (line-valid-p (line wrappers)
	    (when (line-reserved-p line) (error "Line is reserved."))
	    (let ((loc (line-location line)))
	      (dotimes (i (nkeys) t)
		(let ((wrapper (cache-ref (cache) (+ loc i))))
		  (when (or (null wrapper)
			    (and wrappers
				 (eq wrapper
				     (if (consp wrappers) (pop wrappers) wrappers)))
			    (invalid-wrapper-p wrapper))
		    (return nil))))))
;...
;	  ))
;;;
;;; returns T or NIL
;;;
(defun fill-cache-p (forcep field cache wrappers value)
  (with-local-cache-functions (cache)
    (let* ((primary (location-line (compute-primary-cache-location field
(mask) wrappers))))
      (multiple-value-bind (free emptyp)
	  (find-free-cache-line primary field cache wrappers)
	(when (or forcep emptyp) (fill-line free wrappers value) t)))))
;;;
;;; Returns NIL or (values <field> <cache>)
;;; 
;;; This is only called when it isn't possible to put the entry in the
cache
;;; the easy way.  That is, this function assumes that FILL-CACHE-P has
been
;;; called as returned NIL.
;;;
;;; If this returns NIL, it means that it wasn't possible to find a wrapper
;;; field for which all of the entries could be put in the cache (within
the
;;; limit).  
;;;
(defun adjust-cache (field cache wrappers value)
  (with-local-cache-functions (cache)
    (let ((ncache (get-cache (size))))
      (do ((nfield field (next-wrapper-field nfield)))
	  ((null nfield) (free-cache ncache) nil)
	(labels ((try-one-fill-from-line (line)
		   (fill-cache-from-cache-p nil nfield ncache cache line))
		 (try-one-fill (wrappers value)
		   (fill-cache-p nil nfield ncache wrappers value)))
	  (if (and (dotimes (i (nlines) t)
		     (when (and (null (line-reserved-p i))
				(line-valid-p i wrappers))
		       (unless (try-one-fill-from-line i) (return nil))))
		   (try-one-fill wrappers value))
	      (return (values nfield ncache))
	      (flush-cache-internal ncache)))))))
		       
;;;
;;; returns: (values <field> <cache>)
;;;
(defun expand-cache (field cache wrappers value)
  (declare (values field cache) (ignore field))
  (with-local-cache-functions (cache)
    (multiple-value-bind (ignore size)
	(compute-cache-parameters (nkeys) (valuep) (* (nlines) 2))
      (let* ((ncache (get-cache size))
	     (nfield (wrapper-field 'number)))
	(labels ((do-one-fill-from-line (line)
		   (unless (fill-cache-from-cache-p nil nfield ncache cache line)
		     (do-one-fill (line-wrappers line) (line-value line))))
		 (do-one-fill (wrappers value)
		   (multiple-value-bind (adj-field adj-cache)
		       (adjust-cache nfield ncache wrappers value)
		     (if adj-field
			 (setq nfield adj-field ncache adj-cache)
			 (fill-cache-p t nfield ncache wrappers value))))
		 (try-one-fill (wrappers value)
		   (fill-cache-p nil nfield ncache wrappers value)))
	  (dotimes (i (nlines))
	    (when (and (null (line-reserved-p i))
		       (line-valid-p i wrappers))
	      (do-one-fill-from-line i)))
	  (unless (try-one-fill wrappers value)
	    (do-one-fill wrappers value))
	  (values nfield ncache))))))

;;;
;;; This is the heart of the cache filling mechanism.  It implements the
decisions
;;; about where entries are placed.
;;; 
;;; Find a line in the cache at which a new entry can be inserted.
;;;
;;;   <line>
;;;   <empty?>           is <line> in fact empty?
;;;
(defun find-free-cache-line (primary field cache &optional wrappers)
  (declare (values line empty?))
  (with-local-cache-functions (cache)
    (let ((limit (funcall (limit-fn) (nlines)))
	  (wrappedp nil))
      (when (line-reserved-p primary) (setq primary (next-line primary)))
      (labels (;;
	       ;; Try to find a free line starting at <start>.  <primary>
	       ;; is the primary line of the entry we are finding a free
	       ;; line for, it is used to compute the seperations.
	       ;;
	       (find-free (p s)
		 (do* ((line s (next-line line))
		       (nsep (line-separation p s) (1+ nsep)))
		      (())
		   (if (null (line-valid-p line wrappers)) ;If this line is empty or
		       (return (values line t))	           ;invalid, just use it.

		       (let ((osep (line-separation (line-primary field line) line)))
			 (if (and wrappedp (>= line primary))
			     ;;
			     ;; have gone all the way around the cache, time to quit
			     ;; 
			     (return (values line nil))
			     
			     (when (cond ((or (= nsep limit)) t)
					 ((= nsep osep) (zerop (random 2)))
					 ((> nsep osep) t)
					 (t nil))
			       ;;
			       ;; Try to displace what is in this line so that we
			       ;; can use the line.
			       ;;
			       (return (values line (displace line)))))))
		   
		   (if (= line (1- (nlines))) (setq wrappedp t))))
	       ;;
	       ;; Given a line, attempt to free up that line by moving its
	       ;; contents elsewhere. Returns nil when it wasn't possible to
	       ;; move the contents of the line without dumping something on
	       ;; the floor.  
	       ;; 
	       (displace (line)
		 (if (= line (1- (nlines))) (setq wrappedp t))
		 (multiple-value-bind (dline dempty?)
		     (find-free (line-primary field line) (next-line line))
		   (when dempty? (copy-line line dline) t))))
	
	(find-free primary primary)))))

;dlap.lisp
(defun dlap-wrappers (metatypes)
  (mapcar #'(lambda (x) (and (neq x 't) (allocate-register 'vector)))
	  metatypes))

(defun dlap-wrapper-moves (wrappers args metatypes miss-label slot-regs)
  (gathering1 (collecting)
    (iterate ((mt (list-elements metatypes))
	      (arg (list-elements args))
	      (wrapper (list-elements wrappers))
	      (i (interval :from 0)))
       (when wrapper
         (gather1
	   (emit-fetch-wrapper mt arg wrapper miss-label (nth i slot-regs)))))))

(defun emit-dlap (args metatypes miss-label hit miss value-reg &optional
slot-regs)
  (let* ((wrappers (dlap-wrappers metatypes))
	 (nwrappers (remove nil wrappers))
	 (wrapper-moves (dlap-wrapper-moves wrappers args metatypes miss-label
slot-regs)))
    (prog1 (emit-dlap-internal nwrappers
			       wrapper-moves
			       hit
			       miss
			       miss-label
			       value-reg)
	   (mapc #'deallocate-register nwrappers))))

;vector.lisp
(defun add-pv-binding (method-body plist required-parameters)
  (let* ((isl (getf plist :isl))
	 (isl-cache-symbol (make-symbol "isl-cache")))
    (nconc plist (list :isl-cache-symbol isl-cache-symbol))
    (with-gathering ((slot-variables (collecting))
		     (metatypes (collecting)))
	  (iterate ((slots (list-elements isl))
		    (i (interval :from 0)))
	    (cond (slots
		   (gather (slot-vector-symbol i) slot-variables)
		   (gather 'standard-instance     metatypes))
		  (t
		   (gather nil slot-variables)
		   (gather t   metatypes))))
      `((let ((.ISL. (locally (declare (special ,isl-cache-symbol))
,isl-cache-symbol))
	      (.PV. *empty-vector*)
	      ,@(remove nil slot-variables))
	  (declare ,(make-isl-type-declaration '.ISL.)
		   ,(make-pv-type-declaration '.PV.))
	
	  (let* ((cache (%isl-cache .ISL.))
		 (size  (%isl-size  .ISL.))
		 (mask  (%isl-mask  .ISL.))
		 (field (%isl-field .ISL.)))
	    ,(generating-lap-in-lisp '(cache size mask field)
				     required-parameters
	       (flatten-lap
		 (emit-pv-dlap required-parameters metatypes slot-variables))))

	  ,@method-body)))))

(defun emit-pv-dlap (required-parameters metatypes slot-variables)
  (let* ((slot-regs (mapcar #'(lambda (sv) (and sv (operand :lisp-variable
sv)))
			    slot-variables))
	 (wrappers (dlap-wrappers metatypes))
	 (nwrappers (remove nil wrappers)))
    (flet ((wrapper-moves (miss-label)
	     (dlap-wrapper-moves wrappers required-parameters metatypes miss-label
slot-regs)))
      (prog1 (emit-dlap-internal
	       nwrappers                   ;wrapper-regs
	       (wrapper-moves 'pv-miss)    ;wrapper-moves
	       (opcode :exit-lap-in-lisp)  ;hit
	       (flatten-lap		   ;miss
		 (opcode :label 'pv-miss)
		 (opcode :move
			 (operand :lisp `(primary-pv-cache-miss
					  .ISL. ,@required-parameters))
			 (operand :lisp-variable '.PV.))
		 (apply #'flatten-lap (wrapper-moves 'pv-wrapper-miss)) ; -- Maybe the
wrappers have changed.
		 (opcode :label 'pv-wrapper-miss)
		 (opcode :exit-lap-in-lisp))                               
	       'pv-miss			    ;miss-label
	       (operand :lisp-variable '.PV.)) ;value-reg
	   (mapc #'deallocate-register nwrappers)))))

 -------
Richard Harris