Try this out: better UMI.

[Mike Thome <mthome@BBN.COM>]

	I've come up with what seems to be a "better"
Update-method-inheritance... "better" at least in the sense that it
only invalidates generic functions which already have the class in
question cached.  Does it work?  I've not been able to break it, after
trying it out one two significant meta-level systems, two
clos-browsers and several other systems... I've gotten as much as 20%
speedup on loading classes, plus the non-invalidation of lots of gfns.

The patch can be loaded on top of a running pcl - no recompiling your
system, either.  I'm pretty certain that it can be made still better,
but at least it avoids the EQL specializer bug Dan Haug recently
noticed, and elimates large quantities of useless invalidation.

	-mike (mthome@bbn.com)

;;; -*- Package: PCL; Syntax: Common-Lisp -*-

(defun class-wrapper-in-gfn-cache (wrapper gfn)
  (let ((cache (generic-function-cache gfn)))
    (and cache
	 (find wrapper cache :test #'eq :start 1))))

(defmethod update-method-inheritance ((class standard-class) old-cpl new-cpl)
  (let ((wrapper (class-wrapper class)))
    (flet ((reset-gfs (c)
	     (dolist (m (class-direct-methods c))
	       (let ((gf (method-generic-function m)))
		 (when (and (not (memq gf *umi-gfs*))
			    (class-wrapper-in-gfn-cache wrapper gf))
		   (invalidate-generic-function gf)
		   (push gf *umi-gfs*)))))
	   (reset-some-gfs (c1 c2)
	     (let ((gfs1 ()))
	       (dolist (m (class-direct-methods c1))
		 (pushnew (method-generic-function m) gfs1))
	       (dolist (m (class-direct-methods c2))
		 (let ((gf (method-generic-function m)))
		   (when (and (memq gf gfs1)
			      (not (memq gf *umi-gfs*))
			      (class-wrapper-in-gfn-cache wrapper gf))
		     (invalidate-generic-function gf)
		     (push gf *umi-gfs*)))))))
      (multiple-value-bind (appear disappear reorder)
	  (reordered-classes old-cpl new-cpl)
	(dolist (a appear)
	  (unless (memq a *umi-complete-classes*)
	    (reset-gfs a)
	    (push a *umi-complete-classes*)))
	(dolist (d disappear)
	  (unless (memq d *umi-complete-classes*)
	    (reset-gfs d)
	    (push d *umi-complete-classes*)))
	(dolist (r reorder)
	  (dolist (c1 r)
	    (dolist (c2 (memq c1 r))
	      (let ((temp nil))
		(cond ((setq temp (assq c1 *umi-reorder*))
		       (unless (memq c2 temp)
			 (reset-some-gfs c1 c2)
			 (push c2 (cdr temp))))
		      ((setq temp (assq c2 *umi-reorder*))
		       (unless (memq c1 temp)
			 (reset-some-gfs c1 c2)
			 (push c1 (cdr temp))))
		      (t
		       (push (list c1 c2) *umi-reorder*)))))))))))



(defmethod m-1 ((x (eql :x)) stuff)
  (print (list x :x)))

(defmethod m-2 ((x (eql :x)) stuff)
  (print (list x :x)))