typep and defclass vs. ExCL

[Gregor.pa@Xerox.COM]

Jim Larus' message last week pointed out a significant PCL performance
problem I was previously unaware of.  Specifically, there was a
performance problem which I thought was a compile time issue, which is
in fact a runtime issue in ExCL.  This only affects people who use typep
to test if an object is an instance of a PCL defined class.

Anyone using the St. Patrick's day version of PCL in Franz Lisp should
make this patch.  People using other ports of PCL can ignore this
message.

The change involves installing three new definitions in your PCL. You
can avoid a lot of wasted PCL recompilation time by doing the following.

1) Edit the files to install these changes.
2) In the PCL you already have loaded, manually recompile each file of
   the changed files.  First recompile defs, then load it.  Then
   recompile defclass.
3) Get a new lisp, load pcl with the recompiled files, and load your
   system.  You do not need to recompile your code.

If you use (compile-pcl), it will probably recompile all of PCL which
is unnecessary.

;in defs.lisp, replace do-deftype with this
(defun do-satisfies-deftype (name predicate)
  (let* ((specifier `(satisfies ,predicate))
	 (expand-fn #'(lambda (&rest ignore)
			(declare (ignore ignore))
			specifier)))
    ;; Specific ports can insert their own way of doing this.  Many
    ;; ports may find the expand-fn defined above useful.
    ;; the right place is.
    (or #+:Genera
	(setf (get name 'deftype) expand-fn)
	#+:Lucid
	(system:define-macro `(deftype ,name) expand-fn nil)
	#+ExCL
	(setf (get name 'excl::deftype-expander) expand-fn)
	#+:coral
	(setf (get name 'ccl::deftype-expander) expand-fn)

	;; This is the default for ports for which we don't know any
	;; better.  Note that for most ports, providing this definition
	;; should just speed up class definition.  It shouldn't have an
	;; effect on performance of most user code.
	(eval `(deftype ,name () `'(satisfies ,predicate))))))


;in defs.lisp, replace existing definition with this one
(defun define-early-setfs-and-type-predicates ()
  (dolist (forms-var '(*early-defclass-forms*
		       *fsc-defclass-forms*
		       *methods-defclass-forms*))
    (dolist (defclass (eval forms-var))
      (destructuring-bind (ignore name supers slots . options)
			  defclass      
	(unless (eq name 't)
	  (do-satisfies-deftype name (make-type-predicate-name name)))
	
	(dolist (slot slots)
	  (let ((slot-options (cdr slot)))
	    (loop (when (null slot-options) (return t))
		  (when (eq (car slot-options) ':accessor)
		    (do-defmethod-setf-defsetf (cadr slot-options)
					       (list name)))
		  (setq slot-options (cddr slot-options)))))

	(dolist (option options)
	  (when (and (listp option)
		     (eq (car option) :accessor-prefix))
	    (setq option (cadr option))
	    (dolist (slot slots)
	      (if (null option)
		  (do-defmethod-setf-defsetf (car slot) (list name))
		  (do-defmethod-setf-defsetf
		    (symbol-append (symbol-name option)
				   (symbol-name (car slot)))
		    (list name))))))))))

;in defclass.lisp, replace existing definition with this one
(defmethod inform-type-system-about-class ((class standard-class) name)
  (let ((predicate-name (make-type-predicate-name name)))
    (setf (symbol-function predicate-name) (make-type-predicate class))
    (do-satisfies-deftype name predicate-name)))
-------