From 8f2883a6a64e8116ecddba619de2250e0e236efd Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 15 Nov 2010 17:43:37 +0000 Subject: [PATCH] 1.0.44.23: replace %METHOD-NAME and %METHOD-LAMBDA-LIST decls with special variables This not only simplifies PCL code, but fixes a long-standing MOP-bug and actually gives us SB-PCL:SLOW-METHOD frames in the backtraces. Previously a fairly trivial MAKE-METHOD-LAMBDA method was enough to cause (defmethod foo (x) (return-from foo t)) to break, as MAKE-METHOD-LAMBDA-INTERNAL no longer found the %METHOD-NAME declaration in the expected place, and hence was unable to add the block name. --- NEWS | 2 + src/pcl/boot.lisp | 129 ++++++++++++++++++++----------------------------- src/pcl/macros.lisp | 5 -- src/pcl/vector.lisp | 21 ++------ tests/mop.impure.lisp | 30 +++++++++++- version.lisp-expr | 2 +- 6 files changed, 89 insertions(+), 100 deletions(-) diff --git a/NEWS b/NEWS index e25d993..46c0f5c 100644 --- a/NEWS +++ b/NEWS @@ -15,6 +15,8 @@ changes relative to sbcl-1.0.44: * bug fix: when SPEED > SPACE compiling CONCATENATE 'STRING with constant long string arguments slowed the compiler down to a crawl. * bug fix: closure VALUE-CELLs are no longer stack-allocated (lp#308934). + * bug fix: non-standard MAKE-METHOD-LAMBDA methods could break RETURN-FROM + in the DEFMETHOD body. changes in sbcl-1.0.44 relative to sbcl-1.0.43: * enhancement: RUN-PROGRAM accepts :EXTERNAL-FORMAT argument to select the diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 40c6b73..d77709b 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -388,6 +388,11 @@ bootstrapping. (class-prototype (or (generic-function-method-class gf?) (find-class 'standard-method))))))) +;;; These are used to communicate the method name and lambda-list to +;;; MAKE-METHOD-LAMBDA-INTERNAL. +(defvar *method-name* nil) +(defvar *method-lambda-list* nil) + (defun expand-defmethod (name proto-gf proto-method @@ -395,41 +400,45 @@ bootstrapping. lambda-list body env) - (multiple-value-bind (method-lambda unspecialized-lambda-list specializers) - (add-method-declarations name qualifiers lambda-list body env) - (multiple-value-bind (method-function-lambda initargs) - (make-method-lambda proto-gf proto-method method-lambda env) - (let ((initargs-form (make-method-initargs-form - proto-gf proto-method method-function-lambda - initargs env)) - (specializers-form (make-method-specializers-form - proto-gf proto-method specializers env))) - `(progn - ;; Note: We could DECLAIM the ftype of the generic function - ;; here, since ANSI specifies that we create it if it does - ;; not exist. However, I chose not to, because I think it's - ;; more useful to support a style of programming where every - ;; generic function has an explicit DEFGENERIC and any typos - ;; in DEFMETHODs are warned about. Otherwise - ;; - ;; (DEFGENERIC FOO-BAR-BLETCH (X)) - ;; (DEFMETHOD FOO-BAR-BLETCH ((X HASH-TABLE)) ..) - ;; (DEFMETHOD FOO-BRA-BLETCH ((X SIMPLE-VECTOR)) ..) - ;; (DEFMETHOD FOO-BAR-BLETCH ((X VECTOR)) ..) - ;; (DEFMETHOD FOO-BAR-BLETCH ((X ARRAY)) ..) - ;; (DEFMETHOD FOO-BAR-BLETCH ((X LIST)) ..) - ;; - ;; compiles without raising an error and runs without - ;; raising an error (since SIMPLE-VECTOR cases fall through - ;; to VECTOR) but still doesn't do what was intended. I hate - ;; that kind of bug (code which silently gives the wrong - ;; answer), so we don't do a DECLAIM here. -- WHN 20000229 - ,(make-defmethod-form name qualifiers specializers-form - unspecialized-lambda-list - (if proto-method - (class-name (class-of proto-method)) - 'standard-method) - initargs-form)))))) + (multiple-value-bind (parameters unspecialized-lambda-list specializers) + (parse-specialized-lambda-list lambda-list) + (declare (ignore parameters)) + (let ((method-lambda `(lambda ,unspecialized-lambda-list ,@body)) + (*method-name* `(,name ,@qualifiers ,specializers)) + (*method-lambda-list* lambda-list)) + (multiple-value-bind (method-function-lambda initargs) + (make-method-lambda proto-gf proto-method method-lambda env) + (let ((initargs-form (make-method-initargs-form + proto-gf proto-method method-function-lambda + initargs env)) + (specializers-form (make-method-specializers-form + proto-gf proto-method specializers env))) + `(progn + ;; Note: We could DECLAIM the ftype of the generic function + ;; here, since ANSI specifies that we create it if it does + ;; not exist. However, I chose not to, because I think it's + ;; more useful to support a style of programming where every + ;; generic function has an explicit DEFGENERIC and any typos + ;; in DEFMETHODs are warned about. Otherwise + ;; + ;; (DEFGENERIC FOO-BAR-BLETCH (X)) + ;; (DEFMETHOD FOO-BAR-BLETCH ((X HASH-TABLE)) ..) + ;; (DEFMETHOD FOO-BRA-BLETCH ((X SIMPLE-VECTOR)) ..) + ;; (DEFMETHOD FOO-BAR-BLETCH ((X VECTOR)) ..) + ;; (DEFMETHOD FOO-BAR-BLETCH ((X ARRAY)) ..) + ;; (DEFMETHOD FOO-BAR-BLETCH ((X LIST)) ..) + ;; + ;; compiles without raising an error and runs without + ;; raising an error (since SIMPLE-VECTOR cases fall through + ;; to VECTOR) but still doesn't do what was intended. I hate + ;; that kind of bug (code which silently gives the wrong + ;; answer), so we don't do a DECLAIM here. -- WHN 20000229 + ,(make-defmethod-form name qualifiers specializers-form + unspecialized-lambda-list + (if proto-method + (class-name (class-of proto-method)) + 'standard-method) + initargs-form))))))) (defun interned-symbol-p (x) (and (symbolp x) (symbol-package x))) @@ -524,44 +533,6 @@ bootstrapping. initargs env)))) -(defun add-method-declarations (name qualifiers lambda-list body env) - (declare (ignore env)) - (multiple-value-bind (parameters unspecialized-lambda-list specializers) - (parse-specialized-lambda-list lambda-list) - (multiple-value-bind (real-body declarations documentation) - (parse-body body) - (values `(lambda ,unspecialized-lambda-list - ,@(when documentation `(,documentation)) - ;; (Old PCL code used a somewhat different style of - ;; list for %METHOD-NAME values. Our names use - ;; ,@QUALIFIERS instead of ,QUALIFIERS so that the - ;; method names look more like what you see in a - ;; DEFMETHOD form.) - ;; - ;; FIXME: As of sbcl-0.7.0.6, code elsewhere, at - ;; least the code to set up named BLOCKs around the - ;; bodies of methods, depends on the function's base - ;; name being the first element of the %METHOD-NAME - ;; list. It would be good to remove this dependency, - ;; perhaps by building the BLOCK here, or by using - ;; another declaration (e.g. %BLOCK-NAME), so that - ;; our method debug names are free to have any format, - ;; e.g. (:METHOD PRINT-OBJECT :AROUND (CLOWN T)). - ;; - ;; Further, as of sbcl-0.7.9.10, the code to - ;; implement NO-NEXT-METHOD is coupled to the form of - ;; this declaration; see the definition of - ;; CALL-NO-NEXT-METHOD (and the passing of - ;; METHOD-NAME-DECLARATION arguments around the - ;; various CALL-NEXT-METHOD logic). - (declare (%method-name (,name - ,@qualifiers - ,specializers))) - (declare (%method-lambda-list ,@lambda-list)) - ,@declarations - ,@real-body) - unspecialized-lambda-list specializers)))) - (defun real-make-method-initargs-form (proto-gf proto-method method-lambda initargs env) (declare (ignore proto-gf proto-method)) @@ -604,11 +575,15 @@ bootstrapping. method-lambda)) (multiple-value-bind (real-body declarations documentation) (parse-body (cddr method-lambda)) - (let* ((name-decl (get-declaration '%method-name declarations)) - (sll-decl (get-declaration '%method-lambda-list declarations)) - (method-name (when (consp name-decl) (car name-decl))) + ;; We have the %METHOD-NAME declaration in the place where we expect it only + ;; if there is are no non-standard prior MAKE-METHOD-LAMBDA methods -- or + ;; unless they're fantastically unintrusive. + (let* ((method-name *method-name*) (generic-function-name (when method-name (car method-name))) - (specialized-lambda-list (or sll-decl (cadr method-lambda))) + (specialized-lambda-list (or *method-lambda-list* + (ecase (car method-lambda) + (lambda (second method-lambda)) + (named-lambda (third method-lambda))))) ;; the method-cell is a way of communicating what method a ;; method-function implements, for the purpose of ;; NO-NEXT-METHOD. We need something that can be shared diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp index 80dab6b..39379d2 100644 --- a/src/pcl/macros.lisp +++ b/src/pcl/macros.lisp @@ -29,15 +29,10 @@ (/show "starting pcl/macros.lisp") (declaim (declaration - ;; As of sbcl-0.7.0.6, SBCL actively uses this declaration - ;; to propagate information needed to set up nice debug - ;; names (as seen e.g. in BACKTRACE) for method functions. - %method-name ;; These nonstandard declarations seem to be used privately ;; within PCL itself to pass information around, so we can't ;; just delete them. %class - %method-lambda-list ;; This declaration may also be used within PCL to pass ;; information around, I'm not sure. -- WHN 2000-12-30 %variable-rebinding)) diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index 1a6a529..696f472 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -593,17 +593,6 @@ (setq body (cdr body))) (values outer-decls inner-decls body))) -;;; Pull a name out of the %METHOD-NAME declaration in the function -;;; body given, or return NIL if no %METHOD-NAME declaration is found. -(defun body-method-name (body) - (multiple-value-bind (real-body declarations documentation) - (parse-body body) - (declare (ignore real-body documentation)) - (let ((name-decl (get-declaration '%method-name declarations))) - (and name-decl - (destructuring-bind (name) name-decl - name))))) - ;;; Convert a lambda expression containing a SB-PCL::%METHOD-NAME ;;; declaration (which is a naming style internal to PCL) into an ;;; SB-INT:NAMED-LAMBDA expression (which is a naming style used @@ -611,9 +600,9 @@ ;;; no SB-PCL::%METHOD-NAME declaration, then just return the original ;;; lambda expression. (defun name-method-lambda (method-lambda) - (let ((method-name (body-method-name (cddr method-lambda)))) + (let ((method-name *method-name*)) (if method-name - `(named-lambda (slow-method ,method-name) ,(rest method-lambda)) + `(named-lambda (slow-method ,@method-name) ,@(rest method-lambda)) method-lambda))) (defun make-method-initargs-form-internal (method-lambda initargs env) @@ -712,10 +701,10 @@ lambda-list)))) `(list* :function - (let* ((fmf (,(if (body-method-name body) 'named-lambda 'lambda) - ,@(when (body-method-name body) + (let* ((fmf (,(if *method-name* 'named-lambda 'lambda) + ,@(when *method-name* ;; function name - (list (cons 'fast-method (body-method-name body)))) + (list `(fast-method ,@*method-name*))) ;; The lambda-list of the FMF (.pv. .next-method-call. ,@fmf-lambda-list) ;; body of the function diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp index c362778..35118d0 100644 --- a/tests/mop.impure.lisp +++ b/tests/mop.impure.lisp @@ -15,8 +15,10 @@ ;;;; However, this seems a good a way as any of ensuring that we have ;;;; no regressions. +(load "test-util.lisp") + (defpackage "MOP-TEST" - (:use "CL" "SB-MOP" "ASSERTOID")) + (:use "CL" "SB-MOP" "ASSERTOID" "TEST-UTIL")) (in-package "MOP-TEST") @@ -526,5 +528,31 @@ (let ((class (find-class 'has-slots-but-isnt-finalized))) (assert (not (sb-mop:class-finalized-p class))) (assert (raises-error? (sb-mop:class-slots class) sb-kernel::reference-condition))) + +;;; Check that MAKE-METHOD-LAMBDA which wraps the original body doesn't +;;; break RETURN-FROM. +(defclass wrapped-generic (standard-generic-function) + () + (:metaclass sb-mop:funcallable-standard-class)) + +(defmethod sb-mop:make-method-lambda ((gf wrapped-generic) method lambda env) + (call-next-method gf method + `(lambda ,(second lambda) + (flet ((default () :default)) + ,@(cddr lambda))) + env)) + +(defgeneric wrapped (x) + (:generic-function-class wrapped-generic)) + +(defmethod wrapped ((x cons)) + (return-from wrapped (default))) + +(with-test (:name :make-method-lambda-wrapping+return-from) + (assert (eq :default (wrapped (cons t t))))) + +(with-test (:name :slow-method-is-fboundp) + (assert (fboundp '(sb-pcl::slow-method wrapped (cons)))) + (assert (eq :default (funcall #'(sb-pcl::slow-method wrapped (cons)) (list (cons t t)) nil)))) ;;;; success diff --git a/version.lisp-expr b/version.lisp-expr index 77210b5..c26c81e 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.44.22" +"1.0.44.23" -- 1.7.10.4