important performance patch

[Gregor.pa@Xerox.COM]

The following patch, to Rainy Day PCL, fixes a problem which, in some
programs, can cause serious performance problems.  You should make this
patch right away.

;from dfun.lisp
(defun accessor-miss (gf ostate otype new object oindex ow0 ow1 field cache)
  (declare (ignore ow1))
  (let ((args (ecase otype			;The congruence rules assure
		(reader (list object))		;us that this is safe despite
		(writer (list new object)))))	;not knowing the new type yet.
    
    (protect-cache-miss-code gf
			     args
      (multiple-value-bind (wrappers invalidp nfunction applicable)
	  (cache-miss-values gf args)
	(multiple-value-bind (ntype nindex)
	    (accessor-miss-values gf applicable args)
	  ;;
	  ;; The following lexical functions change the state of the
	  ;; dfun to that which is their name.  They accept arguments
	  ;; which are the parameters of the new state, and get other
	  ;; information from the lexical variables bound above.
	  ;; 
	  (flet ((two-class (index w0 w1)
		   (when (zerop (random 2)) (psetf w0 w1 w1 w0))
		   (ecase ntype
		     (reader (update-to-two-class-readers-dfun gf w0 w1 index))
		     (writer (update-to-two-class-writers-dfun gf w0 w1 index))
		     ))
		 (one-index (index &optional field cache)
		   (ecase ntype
		     (reader
		       (update-to-one-index-readers-dfun gf index field cache))
		     (writer
		       (update-to-one-index-writers-dfun gf index field cache))
		     ))
		 (n-n (&optional field cache)
		   (ecase ntype
		     (reader (update-to-n-n-readers-dfun gf field cache))
		     (writer (update-to-n-n-writers-dfun gf field cache))))
		 (checking ()
		   (update-to-checking-dfun gf nfunction))
		 ;;
		 ;;
		 ;;		 
		 (do-fill (valuep limit-fn update-fn)
		   (multiple-value-bind (nfield ncache)
		       (fill-cache field cache
				   1 valuep
				   limit-fn wrappers nindex)
		     (unless (and (= nfield field)
				  (eq ncache cache))
		       (funcall update-fn nfield ncache)))))

	    (cond ((null nfunction)
		   (no-applicable-method gf args))
		  ((null ntype)
		   (checking)
		   (apply nfunction args))		   
		  ((or invalidp
		       (null nindex))
		   (apply nfunction args))
		  ((not (or (std-instance-p object)
			    (fsc-instance-p object)))
		   (checking)
		   (apply nfunction args))
		  ((neq ntype otype)
		   (checking)
		   (apply nfunction args))
		  (t
		   (ecase ostate
		     (one-class
		       (if (eql nindex oindex)
			   (two-class nindex ow0 wrappers)
			   (n-n)))
		     (two-class
		       (if (eql nindex oindex)
			   (one-index nindex)
			   (n-n)))
		     (one-index
		       (if (eql nindex oindex)
			   (do-fill nil
				    #'one-index-limit-fn
				    #'(lambda (nfield ncache)
					(one-index nindex nfield ncache)))
			   (n-n)))
		     (n-n
		       (unless (consp nindex)
			 (do-fill t
				  #'n-n-accessors-limit-fn
				  #'n-n))))
		   (apply nfunction args)))))))))
-------