[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
More patches
- To: gregor.pa@Xerox.COM
- Subject: More patches
- From: Mike Thome <mthome@BBN.COM>
- Date: Thu, 10 Aug 89 12:38:28 -0400
- Cc: commonloops.pa@Xerox.COM
- Redistributed: commonloops.pa
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%.
enjoy!
-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)
new-fully-defined-p
old-fully-defined-p
changed-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)
(clear-precedence-dag-cache)
(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))
sub-newly-defined-p
sub-oldly-defined-p)
(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) ())))
(t
;; 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
sub-newly-defined-p
sub-oldly-defined-p
changed-class
key-arguments)))
(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
old-cpl
(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))))
(t
(push (list c1 c2) *umi-reorder*)))))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; PATCH SLOTS.LISP
;;; ok
#||
;; This fixes the following bug:
(defclass incomplete-class1 (very-incomplete-class1) ())
(make-instance 'incomplete-class1)
;D,#TD1Ps T[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");
; 1GET-CLASS-1
2; Arg 0 (CLASSES): #<ART-Q-128 321201370>
; Arg 1 (I): 0
; Arg 2 (A): #<Error printing object IWMC-CLASS 50017416>
; GET-CLASS-1 GET-CPL-1 LOOKUP-METHOD-INTERNAL
; (METHOD COMPUTE-APPLICABLE-METHODS-1 (STANDARD-GENERIC-FUNCTION T))
; (METHOD MAKE-INSTANCE (STANDARD-CLASS)) (METHOD MAKE-INSTANCE (SYMBOL))
; 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)
instance)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; PATCH INIT.LISP
;;;
;;; 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...
#-symbolics
(defmacro with-stack-list ((var &rest elements) &body body)
`(funcall #'(lambda (&rest ,var) ,@body) ,@elements))
;;; This should be in 3600-low.lisp
#+symbolics
(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))
(check-initargs-1
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)
instance))
(defmethod reinitialize-instance ((instance object) &rest initargs)
(if initargs
(with-stack-list (instances instance)
(check-initargs-1
(class-of instance) initargs
(compute-applicable-methods #'reinitialize-instance instances)
(compute-applicable-methods #'shared-initialize instances))))
(apply #'shared-initialize instance nil initargs)
instance)
(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)
(check-initargs-1
(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)
added-slots
discarded-slots
property-list
&rest initargs)
(declare (ignore discarded-slots property-list))
(if initargs
(with-stack-list (i instance)
(check-initargs-1
(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"
key
(class-name class)))))))