[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

More patches

	Included below are three more sets of patches.  The first is a
correction to the update-method-inheritance patch I sent out a while
ago, the second adds a useful error message to appear when someone
tries to instantiate an incomplete class, and the third hacks the
initialization protocol for a little better efficiency.  All three are
applicable to any PCL port, though the third patch probably will win
by less on non-symbolics (though many ports ought to be able to do
similar tricks).
	On my machine, Patch 1 speeds up defclass time of a new class
by a factor of 5, conses only abut 3% as much, and invalidates no gfns
unless needed.  Patch 3 speeds up "(make-instance 'standard-class)" by
about 60%.

		-mik (mthome@bbn.com)

;;; -*- Package: PCL -*-


;;; patch.1
;;;    This is to fix an insidious little bug with the umi patch I sent out
;;;  a while back. The only actual change from the last set is in
;;;  PROPAGATE-CLASS-UPDATE (near the end), but I've included the utility
;;;  routine and the patched UPDATE-METHOD-INHERITANCE for completeness.
;;;    The case that the original patched failed on was:
;;;       (defclass a () ())
;;;       (defclass b () ())
;;;       (defmethod foo ((x object)) x)
;;;       (defmethod foo :after ((x b)) (print 'bleah))
;;;       (defclass c (a) ())
;;;       (foo (make-instance 'c)) --> #<instance of C>
;;;       (defclass a (b) ())     ; didn't invalidate foo - does now
;;;       (foo (make-instance 'c))
;;;            used to produce -->  #<instance of C>
;;;            now produces --> BLEAH #<instance of C>

;;; Patch   std-class.lisp

(defmethod PROPAGATE-CLASS-UPDATE ((class standard-class)
				   &rest key-arguments	  ;hidden argument
				   &key (its-direct-superclasses () supers-p)
					(its-options () options-p)
					(its-direct-slots  () slots-p))
  (declare (ignore its-direct-superclasses its-options its-direct-slots))

  (let ((old-cpl (class-precedence-list class))
	(new-cpl ()))
    (when new-fully-defined-p
      (cond (supers-p
	     (setq new-cpl (compute-class-precedence-list class))
	     (setf (class-precedence-list class) new-cpl)
	     (update-slots--class class)
	     (update-constructors class))
	    ((or options-p slots-p)
	     (update-slots--class class)
	     (update-constructors class))))
    ;; Propagate all the change information down through our subclasses.
    ;; For each subclass we also compute its new and old fully-defined-p
    ;; status.  The details of this computation are specific to PCL.
    (dolist (subclass (class-direct-subclasses class))
      (let ((sub-forward-referenced-supers
	      (class-forward-referenced-supers subclass))
	(cond ((null sub-forward-referenced-supers)
	       ;; The subclass used to be fully defined.  By definition,
	       ;; that means that we used to be fully defined.  It also
	       ;; means that if we just became not-fully-defined this
	       ;; subclass must now become not fully defined.
	       (setq sub-newly-defined-p new-fully-defined-p
		     sub-oldly-defined-p 't)
	       (when (not new-fully-defined-p)
		 (setf (class-forward-referenced-supers subclass) (list class))))
	      ((and (eq (car sub-forward-referenced-supers) class)
		    (null (cdr sub-forward-referenced-supers)))
	       ;; The only reason this subclass used to be not fully defined
	       ;; is because we used to be not fully defined.  That means
	       ;; that if we are still not fully defined so is this subclass
	       ;; and if we just became fully defined so does this subclass.
	       (setq sub-newly-defined-p new-fully-defined-p
		     sub-oldly-defined-p old-fully-defined-p)
	       (when new-fully-defined-p
		 (setf (class-forward-referenced-supers subclass) ())))
	       ;; The general case is where there were multiple reasons
	       ;; why this subclass used to be not-fully-defined.  That
	       ;; means it stays not fully defined, but we may add or
	       ;; remove ourselves as a reason.
	       (setq sub-newly-defined-p nil
		     sub-oldly-defined-p nil)
	       (setf (class-forward-referenced-supers subclass)
		     (if new-fully-defined-p
			 (delete class sub-forward-referenced-supers)
			 (pushnew class sub-forward-referenced-supers)))))
	(apply #'propagate-class-update subclass
    (when new-fully-defined-p
      (cond (supers-p
	     ;; always do umi now, since (1) it is so much faster and (2)
	     ;; it is needed.
	     ;;(when (eq class changed-class)
	     (update-method-inheritance class
					  (class-precedence-list class))
      (setf (class-all-default-initargs class)
	    (collect-all-default-initargs class new-cpl)))

(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))))
		       (push (list c1 c2) *umi-reorder*)))))))))))


;;;   ok 
;; This fixes the following bug:
(defclass incomplete-class1 (very-incomplete-class1) ())
(make-instance 'incomplete-class1)
;D,#TD1PsT[Begin using 006 escapes](1 0 (NIL 0) (:FIX :ROMAN :NORMAL) "CPTFONT")Trap: The first argument given to the ZL:AR-1 instruction, NIL, was not an array.
(2 0 (NIL 0) (NIL NIL NIL) "CPTFONT"); 
2;    Arg 0 (CLASSES): #<ART-Q-128 321201370>
;    Arg 1 (I): 0
;    Arg 2 (A): #<Error printing object IWMC-CLASS 50017416>
; The make-instance would allocate a wrapperless instance as the prototype
; of INCOMPLETE-CLASS, and would die in lookup-method-internal.

(defmethod allocate-instance ((class standard-class) &rest initargs)
  (declare (ignore initargs))
  (if (class-forward-referenced-supers class)
      (error "You can't allocate an instance of the incompletely defined class ~A" class)
      (let* ((class-wrapper (class-wrapper class))
	     (instance (%allocate-instance--class
			 (class-no-of-instance-slots class))))
	(setf (iwmc-class-class-wrapper instance) class-wrapper)



;;; The initializing protocol does a lot of needless consing, and goes to
;;; the method well too often.  This version reduces consing, and doesn't
;;; go to the well when there are no initargs.  This makes (MAKE-INSTANCE
;;; 'STANDARD-CLASS) over 60% faster (on symbolics)
;;; The CHECK-INITARGS-1 stuff should be cached.  Perhaps
;;; COMPUTE-APPLICABLE-METHODS should take args as &rest args.  Perhaps
;;; COMPUTE-APPLICABLE-METHODS should use the Method cache.

;;; This should be in low.lisp without the following #+s...
(defmacro with-stack-list ((var &rest elements) &body body)
  `(funcall #'(lambda (&rest ,var) ,@body) ,@elements))

;;; This should be in 3600-low.lisp
(import 'scl:with-stack-list 'pcl)

(defmethod make-instance ((class standard-class) &rest initargs)
  (setq initargs (default-initargs class initargs))
  (if initargs
      (with-stack-list (classes class)
	(with-stack-list (prototypes (class-prototype class))
	    class initargs
	    (compute-applicable-methods #'allocate-instance classes)
	    (compute-applicable-methods #'initialize-instance prototypes)
	    (compute-applicable-methods #'shared-initialize prototypes)))))
  (let ((instance (apply #'allocate-instance class initargs)))
    (apply #'initialize-instance instance initargs)

(defmethod reinitialize-instance ((instance object) &rest initargs)
  (if initargs
      (with-stack-list (instances instance)
	  (class-of instance) initargs
	  (compute-applicable-methods #'reinitialize-instance instances)
	  (compute-applicable-methods #'shared-initialize instances))))
  (apply #'shared-initialize instance nil initargs)

(defmethod update-instance-for-different-class ((previous object)
						(current object)
						&rest initargs)
  (if initargs
      (with-stack-list (pc previous current)
	(with-stack-list (c current)
	    (class-of current) initargs
	    (compute-applicable-methods #'update-instance-for-different-class pc)
	    (compute-applicable-methods #'shared-initialize c)))))
  ;; First we must compute the newly added slots.  The spec defines
  ;; newly added slots as "those local slots for which no slot of
  ;; the same name exists in the previous class."
  (let ((added-slots '())
	(current-slotds (class-slots (class-of current)))
	(previous-slot-names (mapcar #'slotd-name
				     (class-slots (class-of previous)))))
    (dolist (slotd current-slotds)
      (if (and (not (memq (slotd-name slotd) previous-slot-names))
	       (eq (slotd-allocation slotd) ':instance))
	  (push (slotd-name slotd) added-slots)))
    (apply #'shared-initialize current added-slots initargs)))

(defmethod update-instance-for-redefined-class ((instance object)
						&rest initargs)
  (declare (ignore discarded-slots property-list))
  (if initargs
      (with-stack-list (i instance)
	  (class-of instance) initargs
	  (compute-applicable-methods #'update-instance-for-redefined-class i)
	  (compute-applicable-methods #'shared-initialize i))))
  (apply #'shared-initialize instance added-slots initargs))

;;; For bootstrapping reasons, the real definition of this appears
;;; in fixup.lisp.
(proclaim '(notinline check-initargs-1))
(defun check-initargs-1 (class initargs &rest methods-lists)
  (declare (ignore class initargs methods-lists))

;;; Patch FIXUP.LISP
(defun check-initargs-1 (class initargs &rest method-lists)
  (let ((legal (apply #'append (mapcar #'slotd-initargs (class-slots class)))))
    (unless (getf initargs :allow-other-keys)
      ;; Add to the set of slot-filling initargs the set of
      ;; initargs that are accepted by the methods.  If at
      ;; any point we come across &allow-other-keys, we can
      ;; just quit.
      (dolist (methods method-lists)
	(dolist (method methods)
	  (multiple-value-bind (keys allow-other-keys)
	      (function-keywords method)
	    (when allow-other-keys
	      (return-from check-initargs-1 nil))
	    (setq legal (append keys legal)))))
      ;; Now check the supplied-initarg-names and the default initargs
      ;; against the total set that we know are legal.
      (doplist (key val) initargs
	(unless (memq key legal)
	  (error "Invalid initialization argument ~S for class ~S"
		 (class-name class)))))))