From 3b2fe8ed844834cfc975d63695fd2cb1b828f375 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Tue, 26 Aug 2003 16:15:57 +0000 Subject: [PATCH] 0.8.3.4: Slightly less bad fix for invalid-qualifiers "not an error" bug ... when we're precomputing methods, defer the error until call time; ... document remaining badness --- BUGS | 18 ++++++++ CREDITS | 19 +++++--- NEWS | 3 ++ src/pcl/braid.lisp | 17 +++++++ src/pcl/combin.lisp | 100 ++++++++++++++++++---------------------- src/pcl/defcombin.lisp | 48 ++++++++++++------- src/pcl/dfun.lisp | 4 +- src/pcl/generic-functions.lisp | 2 + version.lisp-expr | 2 +- 9 files changed, 132 insertions(+), 81 deletions(-) diff --git a/BUGS b/BUGS index 0ad71a7..fd1d7b0 100644 --- a/BUGS +++ b/BUGS @@ -1173,6 +1173,24 @@ WORKAROUND: (let ((cv-ks (cv (kpd.ks pd)))) (funcall reduce-fn d-rbds))))) +281: COMPUTE-EFFECTIVE-METHOD error signalling. + (slightly obscured by a non-0 default value for + SB-PCL::*MAX-EMF-PRECOMPUTE-METHODS*) + It would be natural for COMPUTE-EFFECTIVE-METHOD to signal errors + when it finds a method with invalid qualifiers. However, it + shouldn't signal errors when any such methods are not applicable to + the particular call being evaluated, and certainly it shouldn't when + simply precomputing effective methods that may never be called. + (setf sb-pcl::*max-emf-precompute-methods* 0) + (defgeneric foo (x) + (:method-combination +) + (:method ((x symbol)) 1) + (:method + ((x number)) x)) + (foo 1) -> ERROR, but should simply return 1 + + The issue seems to be that construction of a discriminating function + calls COMPUTE-EFFECTIVE-METHOD with methods that are not all applicable. + DEFUNCT CATEGORIES OF BUGS IR1-#: These labels were used for bugs related to the old IR1 interpreter. diff --git a/CREDITS b/CREDITS index 4941a70..0318e38 100644 --- a/CREDITS +++ b/CREDITS @@ -596,7 +596,9 @@ Antonio Martinez-Shotton: He has contributed a number of bug fixes and bug reports to SBCL. Brian Mastenbrook: - He contributed to the port of SBCL to MacOS X. + He contributed to the port of SBCL to MacOS X. He found a way to + overcome binary compatibility issues between different versions of + dlcompat on Darwin. Dave McDonald: He made a lot of progress toward getting SBCL to be bootstrappable @@ -627,12 +629,15 @@ Kevin M. Rosenberg: Debian packages of SBCL. Christophe Rhodes: - He ported SBCL to SPARC, made various port-related and SPARC-related - changes (like *BACKEND-SUBFEATURES*), made many fixes and - improvements in the compiler's type system, has essentially - completed the work to enable bootstrapping SBCL under unrelated - (non-SBCL, non-CMU-CL) Common Lisps, and contributed in other ways - as well. + He ported SBCL to SPARC (based on the CMUCL backend), made various + port-related and SPARC-related changes (like *BACKEND-SUBFEATURES*), + made many fixes and improvements in the compiler's type system, has + essentially completed the work to enable bootstrapping SBCL under + unrelated (non-SBCL, non-CMU-CL) Common Lisps. He participated in + the modernization of SBCL's CLOS implementation, implemented the + treatment of compiler notes as restartable conditions, provided + optimizations to compiler output, and contributed in other ways as + well. Stig Erik Sandoe: He showed how to convince the GNU toolchain to build SBCL in a way diff --git a/NEWS b/NEWS index 1cb34d0..f88e62a 100644 --- a/NEWS +++ b/NEWS @@ -2003,6 +2003,9 @@ changes in sbcl-0.8.3 relative to sbcl-0.8.2: changes in sbcl-0.8.4 relative to sbcl-0.8.3: * fixed compiler performance when processing loops with a step >1; + * optimization: restored some effective method precomputation + (turned off by an ANSI fix in sbcl-0.8.3); the amount of + precomputation is now tunable. planned incompatible changes in 0.8.x: * (not done yet, but planned:) When the profiling interface settles diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 066e6c4..82f1563 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -720,3 +720,20 @@ ~I~_when called with arguments ~2I~_~S.~:>" generic-function args)) + +(defmethod invalid-qualifiers ((gf generic-function) + combin + method) + (let ((qualifiers (method-qualifiers method))) + (let ((why (cond + ((cdr qualifiers) "has too many qualifiers") + (t (aver (not (member (car qualifiers) + '(:around :before :after)))) + "has an invalid qualifier")))) + (invalid-method-error + method + "The method ~S on ~S ~A.~%~ + Standard method combination requires all methods to have one~%~ + of the single qualifiers :AROUND, :BEFORE and :AFTER or to~%~ + have no qualifier at all." + method gf why)))) diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp index 5be842e..c4494e6 100644 --- a/src/pcl/combin.lisp +++ b/src/pcl/combin.lisp @@ -174,7 +174,8 @@ (get-generic-fun-info gf) (declare (ignore nreq nkeys arg-info)) (let ((ll (make-fast-method-call-lambda-list metatypes applyp)) - (error-p (eq (first effective-method) '%no-primary-method)) + (error-p (or (eq (first effective-method) '%no-primary-method) + (eq (first effective-method) '%invalid-qualifiers))) (mc-args-p (when (eq *boot-state* 'complete) ;; Otherwise the METHOD-COMBINATION slot is not bound. @@ -185,8 +186,12 @@ (error-p `(lambda (.pv-cell. .next-method-call. &rest .args.) (declare (ignore .pv-cell. .next-method-call.)) + (declare (ignorable .args.)) (flet ((%no-primary-method (gf args) - (apply #'no-primary-method gf args))) + (apply #'no-primary-method gf args)) + (%invalid-qualifiers (gf combin method) + (invalid-qualifiers gf combin method))) + (declare (ignorable #'%no-primary-method #'%invalid-qualifiers)) ,effective-method))) (mc-args-p (let* ((required @@ -331,59 +336,44 @@ `(call-method-list ,@(mapcar (lambda (method) `(call-method ,method ())) methods))) -(defun standard-compute-effective-method (generic-function combin applicable-methods) - (declare (ignore combin)) - (let ((before ()) - (primary ()) - (after ()) - (around ())) - (flet ((lose (method why) - (invalid-method-error - method - "The method ~S ~A.~%~ - Standard method combination requires all methods to have one~%~ - of the single qualifiers :AROUND, :BEFORE and :AFTER or to~%~ - have no qualifier at all." - method why))) +(defun standard-compute-effective-method + (generic-function combin applicable-methods) + (collect ((before) (primary) (after) (around)) + (flet ((invalid (gf combin m) + (if *in-precompute-effective-methods-p* + (return-from standard-compute-effective-method + `(%invalid-qualifiers ',gf ',combin ',m)) + (invalid-qualifiers gf combin m)))) (dolist (m applicable-methods) - (let ((qualifiers (if (listp m) - (early-method-qualifiers m) - (method-qualifiers m)))) - (cond - ((null qualifiers) (push m primary)) - ((cdr qualifiers) - (lose m "has more than one qualifier")) - ((eq (car qualifiers) :around) - (push m around)) - ((eq (car qualifiers) :before) - (push m before)) - ((eq (car qualifiers) :after) - (push m after)) - (t - (lose m "has an illegal qualifier")))))) - (setq before (reverse before) - after (reverse after) - primary (reverse primary) - around (reverse around)) - (cond ((null primary) + (let ((qualifiers (if (listp m) + (early-method-qualifiers m) + (method-qualifiers m)))) + (cond + ((null qualifiers) (primary m)) + ((cdr qualifiers) (invalid generic-function combin m)) + ((eq (car qualifiers) :around) (around m)) + ((eq (car qualifiers) :before) (before m)) + ((eq (car qualifiers) :after) (after m)) + (t (invalid generic-function combin m)))))) + (cond ((null (primary)) `(%no-primary-method ',generic-function .args.)) - ((and (null before) (null after) (null around)) + ((and (null (before)) (null (after)) (null (around))) ;; By returning a single call-method `form' here we enable ;; an important implementation-specific optimization. - `(call-method ,(first primary) ,(rest primary))) + `(call-method ,(first (primary)) ,(rest (primary)))) (t (let ((main-effective-method - (if (or before after) + (if (or (before) (after)) `(multiple-value-prog1 (progn - ,(make-call-methods before) - (call-method ,(first primary) - ,(rest primary))) - ,(make-call-methods (reverse after))) - `(call-method ,(first primary) ,(rest primary))))) - (if around - `(call-method ,(first around) - (,@(rest around) + ,(make-call-methods (before)) + (call-method ,(first (primary)) + ,(rest (primary)))) + ,(make-call-methods (reverse (after)))) + `(call-method ,(first (primary)) ,(rest (primary)))))) + (if (around) + `(call-method ,(first (around)) + (,@(rest (around)) (make-method ,main-effective-method))) main-effective-method)))))) @@ -405,12 +395,14 @@ applicable-methods)) (defun invalid-method-error (method format-control &rest format-arguments) - (error "~@" - method - format-control - format-arguments)) + (let ((sb-debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame)))) + (error "~@" + method + format-control + format-arguments))) (defun method-combination-error (format-control &rest format-arguments) - (error "~@" - format-control - format-arguments)) + (let ((sb-debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame)))) + (error "~@" + format-control + format-arguments))) diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp index 7652ec8..8b034ce 100644 --- a/src/pcl/defcombin.lisp +++ b/src/pcl/defcombin.lisp @@ -128,27 +128,20 @@ (order (car (method-combination-options combin))) (around ()) (primary ())) - (dolist (m applicable-methods) - (let ((qualifiers (method-qualifiers m))) - (flet ((lose (method why) - (invalid-method-error - method - "The method ~S ~A.~%~ - The method combination type ~S was defined with the~%~ - short form of DEFINE-METHOD-COMBINATION and so requires~%~ - all methods have either the single qualifier ~S or the~%~ - single qualifier :AROUND." - method why type type))) - (cond ((null qualifiers) - (lose m "has no qualifiers")) - ((cdr qualifiers) - (lose m "has more than one qualifier")) + (flet ((invalid (gf combin m) + (if *in-precompute-effective-methods-p* + (return-from compute-effective-method + `(%invalid-qualifiers ',gf ',combin ',m)) + (invalid-qualifiers gf combin m)))) + (dolist (m applicable-methods) + (let ((qualifiers (method-qualifiers m))) + (cond ((null qualifiers) (invalid generic-function combin m)) + ((cdr qualifiers) (invalid generic-function combin m)) ((eq (car qualifiers) :around) (push m around)) ((eq (car qualifiers) type) (push m primary)) - (t - (lose m "has an illegal qualifier")))))) + (t (invalid generic-function combin m)))))) (setq around (nreverse around)) (ecase order (:most-specific-last) ; nothing to be done, already in correct order @@ -192,6 +185,26 @@ (t `(call-method ,(car around) (,@(cdr around) (make-method ,main-method)))))))) + +(defmethod invalid-qualifiers ((gf generic-function) + (combin short-method-combination) + method) + (let ((qualifiers (method-qualifiers method)) + (type (method-combination-type combin))) + (let ((why (cond + ((null qualifiers) "has no qualifiers") + ((cdr qualifiers) "has too many qualifiers") + (t (aver (and (neq (car qualifiers) type) + (neq (car qualifiers) :around))) + "has an invalid qualifier")))) + (invalid-method-error + method + "The method ~S on ~S ~A.~%~ + The method combination type ~S was defined with the~%~ + short form of DEFINE-METHOD-COMBINATION and so requires~%~ + all methods have either the single qualifier ~S or the~%~ + single qualifier :AROUND." + method gf why type type)))) ;;;; long method combinations @@ -496,3 +509,4 @@ (return (nconc (frob required nr nreq) (frob optional no nopt) values))))) + diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index d51705b..6245903 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -763,11 +763,11 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;;; considered as state transitions. (defvar *lazy-dfun-compute-p* t) (defvar *early-p* nil) -(defvar *max-emf-precomputation-methods* 0) +(defvar *max-emf-precomputation-methods* 10) (defun finalize-specializers (gf) (let ((methods (generic-function-methods gf))) - (when (< (length methods) *max-emf-precomputation-methods*) + (when (<= (length methods) *max-emf-precomputation-methods*) (let ((all-finalized t)) (dolist (method methods all-finalized) (dolist (specializer (method-specializers method)) diff --git a/src/pcl/generic-functions.lisp b/src/pcl/generic-functions.lisp index f91ced0..1b787ca 100644 --- a/src/pcl/generic-functions.lisp +++ b/src/pcl/generic-functions.lisp @@ -419,6 +419,8 @@ (defgeneric find-method-combination (generic-function type options)) +(defgeneric invalid-qualifiers (generic-function combin method)) + (defgeneric (setf slot-accessor-function) (function slotd type)) (defgeneric (setf slot-accessor-std-p) (value slotd type)) diff --git a/version.lisp-expr b/version.lisp-expr index 2b1f5af..5187c7a 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -16,4 +16,4 @@ ;;; with something arbitrary in the fourth field, is used for CVS ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS -"0.8.3.3" +"0.8.3.4" -- 1.7.10.4