From e66288cd5588b336b79a7e19f1c884e4e3263d53 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Mon, 9 Jun 2008 21:49:15 +0000 Subject: [PATCH] 1.0.17.32: faster ADD-METHOD to PRINT-OBJECT The basic idea here is reducing the number of functions whose discriminating function and effective method cache are precomputed; in particular, to reduce the number where users can both legitimately define their own methods, and where a large number of methods will be applicable to different classes. The biggest culprit in both of those categories is the PRINT-OBJECT generic function, which would recompute its entire dispatch structure every time any method was added or removed. So, turn off precomputation for names in the CL package; deal with the bootstrap metacircles that that provokes; special-case PRINT-OBJECT in COMPUTE-DISCRIMINATING-FUNCTION so that we can always print certain critical pieces of infrastructure; also, warn the user if they break our assumptions in PRINT-OBJECT's specialization. Fix one broken "how did it ever work" test. --- NEWS | 2 + src/pcl/boot.lisp | 30 +++++++------- src/pcl/combin.lisp | 2 +- src/pcl/ctor.lisp | 8 +++- src/pcl/methods.lisp | 104 +++++++++++++++++++++++++++++++++--------------- src/pcl/std-class.lisp | 16 ++++---- tests/clos.impure.lisp | 2 +- tests/clos.pure.lisp | 2 +- version.lisp-expr | 2 +- 9 files changed, 108 insertions(+), 60 deletions(-) diff --git a/NEWS b/NEWS index 9f9e052..5fe425f 100644 --- a/NEWS +++ b/NEWS @@ -19,6 +19,8 @@ changes in sbcl-1.0.18 relative to 1.0.17: * optimization: file compiler is now able to coalesce non-circular lists, non-base strings, and bit-vectors. Additionally, constants are never referenced through SYMBOL-VALUE at runtime. + * optimization: code defining methods on PRINT-OBJECT (and other + generic functions in the COMMON-LISP package) now loads faster. * bug fix: EAI_NODATA is deprecated since RFC 3493. Stop using it in sb-bsd-sockets. * bug fix: if COMPILE-FILE aborts due to an unwind, the partial diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 89ba91e..47e270a 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -1913,14 +1913,19 @@ bootstrapping. (aver (= (symbol-value (intern (format nil "*SM-~A-INDEX*" s))) (!bootstrap-slot-index 'standard-reader-method s) (!bootstrap-slot-index 'standard-writer-method s) - (!bootstrap-slot-index 'standard-boundp-method s)))) + (!bootstrap-slot-index 'standard-boundp-method s) + (!bootstrap-slot-index 'global-reader-method s) + (!bootstrap-slot-index 'global-writer-method s) + (!bootstrap-slot-index 'global-boundp-method s)))) + +(define-symbol-macro *standard-method-classes* + (list *the-class-standard-method* *the-class-standard-reader-method* + *the-class-standard-writer-method* *the-class-standard-boundp-method* + *the-class-global-reader-method* *the-class-global-writer-method* + *the-class-global-boundp-method*)) (defun safe-method-specializers (method) - (let ((standard-method-classes - (list *the-class-standard-method* - *the-class-standard-reader-method* - *the-class-standard-writer-method* - *the-class-standard-boundp-method*)) + (let ((standard-method-classes *standard-method-classes*) (class (class-of method))) (if (member class standard-method-classes) (clos-slots-ref (get-slots method) *sm-specializers-index*) @@ -1930,21 +1935,13 @@ bootstrapping. (and (typep mf '%method-function) (%method-function-fast-function mf)))) (defun safe-method-function (method) - (let ((standard-method-classes - (list *the-class-standard-method* - *the-class-standard-reader-method* - *the-class-standard-writer-method* - *the-class-standard-boundp-method*)) + (let ((standard-method-classes *standard-method-classes*) (class (class-of method))) (if (member class standard-method-classes) (clos-slots-ref (get-slots method) *sm-%function-index*) (method-function method)))) (defun safe-method-qualifiers (method) - (let ((standard-method-classes - (list *the-class-standard-method* - *the-class-standard-reader-method* - *the-class-standard-writer-method* - *the-class-standard-boundp-method*)) + (let ((standard-method-classes *standard-method-classes*) (class (class-of method))) (if (member class standard-method-classes) (clos-slots-ref (get-slots method) *sm-qualifiers-index*) @@ -2011,6 +2008,7 @@ bootstrapping. (package (symbol-package symbol))) (and (or (eq package *pcl-package*) (memq package (package-use-list *pcl-package*))) + (not (eq package #.(find-package "CL"))) ;; FIXME: this test will eventually be ;; superseded by the *internal-pcl...* test, ;; above. While we are in a process of diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp index ecd09d5..201620b 100644 --- a/src/pcl/combin.lisp +++ b/src/pcl/combin.lisp @@ -419,7 +419,7 @@ (dolist (m applicable-methods) (let ((qualifiers (if (listp m) (early-method-qualifiers m) - (method-qualifiers m)))) + (safe-method-qualifiers m)))) (cond ((null qualifiers) (primary m)) ((cdr qualifiers) (invalid generic-function combin m)) diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index 9b565be..0aae966 100644 --- a/src/pcl/ctor.lisp +++ b/src/pcl/ctor.lisp @@ -342,7 +342,9 @@ (methods &optional standard-method) (loop with primary-checked-p = nil for method in methods - as qualifiers = (method-qualifiers method) + as qualifiers = (if (consp method) + (early-method-qualifiers method) + (safe-method-qualifiers method)) when (or (eq :around (car qualifiers)) (and (null qualifiers) (not primary-checked-p) @@ -456,7 +458,9 @@ ;;; must be called. (defun standard-sort-methods (applicable-methods) (loop for method in applicable-methods - as qualifiers = (method-qualifiers method) + as qualifiers = (if (consp method) + (early-method-qualifiers method) + (safe-method-qualifiers method)) if (null qualifiers) collect method into primary else if (eq :around (car qualifiers)) diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index d2e5d9c..b9515ed 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -265,7 +265,7 @@ (dolist (method methods) (let ((mspecializers (method-specializers method))) (aver (= lspec (length mspecializers))) - (when (and (equal qualifiers (method-qualifiers method)) + (when (and (equal qualifiers (safe-method-qualifiers method)) (every #'same-specializer-p specializers (method-specializers method))) (return method)))))) @@ -450,7 +450,18 @@ (slot-value method 'qualifiers) (slot-value method 'specializers) (slot-value method 'lambda-list) - (slot-value method '%generic-function)))) + (slot-value method '%generic-function) + (slot-value gf 'name)))) + +(define-condition print-object-stream-specializer (reference-condition simple-warning) + () + (:default-initargs + :references (list '(:ansi-cl :function print-object)) + :format-control "~@" + :format-arguments (list 'print-object))) (defun real-add-method (generic-function method &optional skip-dfun-update-p) (flet ((similar-lambda-lists-p (old-method new-lambda-list) @@ -463,13 +474,15 @@ (eq (or a-keyp a-restp) (or b-keyp b-restp))))))) (multiple-value-bind (lock qualifiers specializers new-lambda-list - method-gf) + method-gf name) (values-for-add-method generic-function method) (when method-gf (error "~@" method method-gf)) + (when (and (eq name 'print-object) (not (eq (second specializers) *the-class-t*))) + (warn 'print-object-stream-specializer)) (handler-case ;; System lock because interrupts need to be disabled as ;; well: it would be bad to unwind and leave the gf in an @@ -1516,34 +1529,63 @@ (eq gf #'(setf slot-value-using-class)) (eq gf #'slot-boundp-using-class))) -(defmethod compute-discriminating-function ((gf standard-generic-function)) - (let ((dfun-state (slot-value gf 'dfun-state))) - (when (special-case-for-compute-discriminating-function-p gf) - ;; if we have a special case for - ;; COMPUTE-DISCRIMINATING-FUNCTION, then (at least for the - ;; special cases implemented as of 2006-05-09) any information - ;; in the cache is misplaced. - (aver (null dfun-state))) - (typecase dfun-state - (null - (when (eq gf #'compute-applicable-methods) - (update-all-c-a-m-gf-info gf)) - (cond - ((eq gf #'slot-value-using-class) - (update-slot-value-gf-info gf 'reader) - #'slot-value-using-class-dfun) - ((eq gf #'(setf slot-value-using-class)) - (update-slot-value-gf-info gf 'writer) - #'setf-slot-value-using-class-dfun) - ((eq gf #'slot-boundp-using-class) - (update-slot-value-gf-info gf 'boundp) - #'slot-boundp-using-class-dfun) - ((gf-precompute-dfun-and-emf-p (slot-value gf 'arg-info)) - (make-final-dfun gf)) - (t - (make-initial-dfun gf)))) - (function dfun-state) - (cons (car dfun-state))))) +(let (po-cache) + (defmethod compute-discriminating-function ((gf standard-generic-function)) + (let ((dfun-state (slot-value gf 'dfun-state))) + (when (special-case-for-compute-discriminating-function-p gf) + ;; if we have a special case for + ;; COMPUTE-DISCRIMINATING-FUNCTION, then (at least for the + ;; special cases implemented as of 2006-05-09) any information + ;; in the cache is misplaced. + (aver (null dfun-state))) + (typecase dfun-state + (null + (when (eq gf #'compute-applicable-methods) + (update-all-c-a-m-gf-info gf)) + (cond + ((eq gf #'slot-value-using-class) + (update-slot-value-gf-info gf 'reader) + #'slot-value-using-class-dfun) + ((eq gf #'(setf slot-value-using-class)) + (update-slot-value-gf-info gf 'writer) + #'setf-slot-value-using-class-dfun) + ((eq gf #'slot-boundp-using-class) + (update-slot-value-gf-info gf 'boundp) + #'slot-boundp-using-class-dfun) + ;; KLUDGE: PRINT-OBJECT is not a special-case in the sense + ;; of having a desperately special discriminating function. + ;; However, it is important that the machinery for printing + ;; conditions for stack and heap exhaustion, and the + ;; restarts offered by the debugger, work without consuming + ;; many extra resources. This way (testing by name of GF + ;; rather than by identity) was the only way I found to get + ;; this to bootstrap, given that the PRINT-OBJECT generic + ;; function is only set up later, in + ;; SRC;PCL;PRINT-OBJECT.LISP. -- CSR, 2008-06-09 + ((eq (slot-value gf 'name) 'print-object) + (let ((nkeys (nth-value 3 (get-generic-fun-info gf)))) + (cond ((/= nkeys 1) + ;; KLUDGE: someone has defined a method + ;; specialized on the second argument: punt. + (make-initial-dfun gf)) + (po-cache + (multiple-value-bind (dfun cache info) + (make-caching-dfun gf po-cache) + (set-dfun gf dfun cache info))) + (t (multiple-value-bind (dfun cache info) + (make-final-dfun-internal + gf + (list (list (find-class 'sb-kernel::control-stack-exhausted)) + (list (find-class 'sb-kernel::heap-exhausted-error)) + (list (find-class 'restart)))) + (setq po-cache cache) + (set-dfun gf dfun cache info)))))) + ((gf-precompute-dfun-and-emf-p (slot-value gf 'arg-info)) + (make-final-dfun gf)) + (t + (make-initial-dfun gf)))) + (function dfun-state) + (cons (car dfun-state)))))) (defmethod update-gf-dfun ((class std-class) gf) (let ((*new-class* class) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 0849a80..675d115 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -519,7 +519,7 @@ (defmethod shared-initialize :after ((class condition-class) slot-names &key direct-slots direct-superclasses) (declare (ignore slot-names)) - (let ((classoid (find-classoid (class-name class)))) + (let ((classoid (find-classoid (slot-value class 'name)))) (with-slots (wrapper %class-precedence-list cpl-available-p prototype (direct-supers direct-superclasses)) class @@ -655,9 +655,9 @@ (cons nil nil)))) (values defstruct-form constructor reader-names writer-names))) -(defun make-defstruct-allocation-function (class) +(defun make-defstruct-allocation-function (name) ;; FIXME: Why don't we go class->layout->info == dd - (let ((dd (find-defstruct-description (class-name class)))) + (let ((dd (find-defstruct-description name))) (%make-structure-instance-allocator dd nil))) (defmethod shared-initialize :after @@ -671,10 +671,10 @@ (setf (slot-value class 'direct-superclasses) (or direct-superclasses (setq direct-superclasses - (and (not (eq (class-name class) 'structure-object)) + (and (not (eq (slot-value class 'name) 'structure-object)) (list *the-class-structure-object*))))) (setq direct-superclasses (slot-value class 'direct-superclasses))) - (let* ((name (class-name class)) + (let* ((name (slot-value class 'name)) (from-defclass-p (slot-value class 'from-defclass-p)) (defstruct-p (or from-defclass-p (not (structure-type-p name))))) (if direct-slots-p @@ -709,14 +709,16 @@ (setf (slot-value class 'defstruct-form) defstruct-form) (setf (slot-value class 'defstruct-constructor) constructor))) (setf (slot-value class 'defstruct-constructor) - (make-defstruct-allocation-function class))) + ;; KLUDGE: not class; in fixup.lisp, can't access slots + ;; outside methods yet. + (make-defstruct-allocation-function name))) (add-direct-subclasses class direct-superclasses) (setf (slot-value class '%class-precedence-list) (compute-class-precedence-list class)) (setf (slot-value class 'cpl-available-p) t) (let ((slots (compute-slots class))) (setf (slot-value class 'slots) slots) - (let* ((lclass (find-classoid (class-name class))) + (let* ((lclass (find-classoid (slot-value class 'name))) (layout (classoid-layout lclass))) (setf (classoid-pcl-class lclass) class) (setf (slot-value class 'wrapper) layout) diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index 174e328..3dc1d93 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -1344,7 +1344,7 @@ (defclass class-with-odd-class-name-method () ((a :accessor class-name))) -;;; another case where precomputing (this time on PRINT-OBJET) and +;;; another case where precomputing (this time on PRINT-OBJECT) and ;;; lazily-finalized classes caused problems. (report from James Y ;;; Knight sbcl-devel 20-07-2006) diff --git a/tests/clos.pure.lisp b/tests/clos.pure.lisp index aec1850..ae8b524 100644 --- a/tests/clos.pure.lisp +++ b/tests/clos.pure.lisp @@ -54,7 +54,7 @@ ;;; (i.e. portably) but it's much easier using the MOP and ;;; MAP-ALL-CLASSES. (flet ((standardized-class-p (c) - (find-symbol (symbol-name (class-name c)) "CL"))) + (eq (class-name c) (find-symbol (symbol-name (class-name c)) "CL")))) (let (result) (sb-pcl::map-all-classes (lambda (c) (when (standardized-class-p c) diff --git a/version.lisp-expr b/version.lisp-expr index e9001f9..5ae4f8e 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.17.31" +"1.0.17.32" -- 1.7.10.4