X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fpcl%2Fboot.lisp;h=bfa56ce84da4b3b2744fbdadccbef5589ca0b115;hb=c1d63b850fe9528036f8ae715088384e81d880cc;hp=672e483a0125dfcf1267202ab41e46cbe9f2f61b;hpb=665eea819b61f87f401ff0a9ff82f6cbdcc5c636;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 672e483..bfa56ce 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -68,18 +68,13 @@ bootstrapping. |# -(declaim (notinline make-a-method - add-named-method +(declaim (notinline make-a-method add-named-method ensure-generic-function-using-class - add-method - remove-method)) + add-method remove-method)) (defvar *!early-functions* - '((make-a-method early-make-a-method - real-make-a-method) - (add-named-method early-add-named-method - real-add-named-method) - )) + '((make-a-method early-make-a-method real-make-a-method) + (add-named-method early-add-named-method real-add-named-method))) ;;; For each of the early functions, arrange to have it point to its ;;; early definition. Do this in a way that makes sure that if we @@ -97,11 +92,14 @@ bootstrapping. ;;; *!GENERIC-FUNCTION-FIXUPS* is used by !FIX-EARLY-GENERIC-FUNCTIONS ;;; to convert the few functions in the bootstrap which are supposed ;;; to be generic functions but can't be early on. +;;; +;;; each entry is a list of name and lambda-list, class names as +;;; specializers, and method body function name. (defvar *!generic-function-fixups* '((add-method - ((generic-function method) ;lambda-list - (standard-generic-function method) ;specializers - real-add-method)) ;method-function + ((generic-function method) + (standard-generic-function method) + real-add-method)) (remove-method ((generic-function method) (standard-generic-function method) @@ -125,6 +123,18 @@ bootstrapping. ((proto-generic-function proto-method lambda-expression environment) (standard-generic-function standard-method t t) real-make-method-lambda)) + (make-method-specializers-form + ((proto-generic-function proto-method specializer-names environment) + (standard-generic-function standard-method t t) + real-make-method-specializers-form)) + (parse-specializer-using-class + ((generic-function specializer) + (standard-generic-function t) + real-parse-specializer-using-class)) + (unparse-specializer-using-class + ((generic-function specializer) + (standard-generic-function t) + real-unparse-specializer-using-class)) (make-method-initargs-form ((proto-generic-function proto-method lambda-expression @@ -298,18 +308,48 @@ bootstrapping. ;; belong here! (aver (not morep))))) -(defmacro defmethod (&rest args &environment env) +(defmacro defmethod (&rest args) (multiple-value-bind (name qualifiers lambda-list body) (parse-defmethod args) - (multiple-value-bind (proto-gf proto-method) - (prototypes-for-make-method-lambda name) - (expand-defmethod name - proto-gf - proto-method - qualifiers - lambda-list - body - env)))) + `(progn + ;; KLUDGE: this double expansion is quite a monumental + ;; workaround: it comes about because of a fantastic interaction + ;; between the processing rules of CLHS 3.2.3.1 and the + ;; bizarreness of MAKE-METHOD-LAMBDA. + ;; + ;; MAKE-METHOD-LAMBDA can be called by the user, and if the + ;; lambda itself doesn't refer to outside bindings the return + ;; value must be compileable in the null lexical environment. + ;; However, the function must also refer somehow to the + ;; associated method object, so that it can call NO-NEXT-METHOD + ;; with the appropriate arguments if there is no next method -- + ;; but when the function is generated, the method object doesn't + ;; exist yet. + ;; + ;; In order to resolve this issue, we insert a literal cons cell + ;; into the body of the method lambda, return the same cons cell + ;; as part of the second (initargs) return value of + ;; MAKE-METHOD-LAMBDA, and a method on INITIALIZE-INSTANCE fills + ;; in the cell when the method is created. However, this + ;; strategy depends on having a fresh cons cell for every method + ;; lambda, which (without the workaround below) is skewered by + ;; the processing in CLHS 3.2.3.1, which permits implementations + ;; to macroexpand the bodies of EVAL-WHEN forms with both + ;; :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL only once. The + ;; expansion below forces the double expansion in those cases, + ;; while expanding only once in the common case. + (eval-when (:load-toplevel) + (%defmethod-expander ,name ,qualifiers ,lambda-list ,body)) + (eval-when (:execute) + (%defmethod-expander ,name ,qualifiers ,lambda-list ,body))))) + +(defmacro %defmethod-expander + (name qualifiers lambda-list body &environment env) + (multiple-value-bind (proto-gf proto-method) + (prototypes-for-make-method-lambda name) + (expand-defmethod name proto-gf proto-method qualifiers + lambda-list body env))) + (defun prototypes-for-make-method-lambda (name) (if (not (eq *boot-state* 'complete)) @@ -358,11 +398,11 @@ bootstrapping. (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))) + (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 @@ -371,7 +411,7 @@ bootstrapping. ;; generic function has an explicit DEFGENERIC and any typos ;; in DEFMETHODs are warned about. Otherwise ;; - ;; (DEFGENERIC FOO-BAR-BLETCH ((X T))) + ;; (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)) ..) @@ -383,7 +423,7 @@ bootstrapping. ;; 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 + ,(make-defmethod-form name qualifiers specializers-form unspecialized-lambda-list (if proto-method (class-name (class-of proto-method)) @@ -413,13 +453,24 @@ bootstrapping. specializers) (consp initargs-form) (eq (car initargs-form) 'list*) - (memq (cadr initargs-form) '(:function :fast-function)) + (memq (cadr initargs-form) '(:function)) (consp (setq fn (caddr initargs-form))) (eq (car fn) 'function) (consp (setq fn-lambda (cadr fn))) - (eq (car fn-lambda) 'lambda)) + (eq (car fn-lambda) 'lambda) + (bug "Really got here")) (let* ((specls (mapcar (lambda (specl) (if (consp specl) + ;; CONSTANT-FORM-VALUE? What I + ;; kind of want to know, though, + ;; is what happens if we don't do + ;; this for some slow-method + ;; function because of a hairy + ;; lexenv -- is the only bad + ;; effect that the method + ;; function ends up unnamed? If + ;; so, couldn't we arrange to + ;; name it later? `(,(car specl) ,(eval (cadr specl))) specl)) specializers)) @@ -437,6 +488,8 @@ bootstrapping. ,@(cdddr initargs-form))))) (make-defmethod-form-internal name qualifiers + specializers + #+nil `(list ,@(mapcar (lambda (specializer) (if (consp specializer) ``(,',(car specializer) @@ -460,9 +513,6 @@ bootstrapping. (sb-c:source-location))) (defmacro make-method-function (method-lambda &environment env) - (make-method-function-internal method-lambda env)) - -(defun make-method-function-internal (method-lambda &optional env) (multiple-value-bind (proto-gf proto-method) (prototypes-for-make-method-lambda nil) (multiple-value-bind (method-function-lambda initargs) @@ -525,134 +575,22 @@ bootstrapping. (setf (gdefinition 'make-method-initargs-form) (symbol-function 'real-make-method-initargs-form))) +;;; When bootstrapping PCL MAKE-METHOD-LAMBDA starts out as a regular +;;; functions: REAL-MAKE-METHOD-LAMBDA set to the fdefinition of +;;; MAKE-METHOD-LAMBDA. Once generic functions are born, the +;;; REAL-MAKE-METHOD lambda is used as the body of the default method. +;;; MAKE-METHOD-LAMBDA-INTERNAL is split out into a separate function +;;; so that changing it in a live image is easy, and changes actually +;;; take effect. (defun real-make-method-lambda (proto-gf proto-method method-lambda env) - (declare (ignore proto-gf proto-method)) - (make-method-lambda-internal method-lambda env)) + (make-method-lambda-internal proto-gf proto-method method-lambda env)) -;;; a helper function for creating Python-friendly type declarations -;;; in DEFMETHOD forms -(defun parameter-specializer-declaration-in-defmethod (parameter specializer) - (cond ((and (consp specializer) - (eq (car specializer) 'eql)) - ;; KLUDGE: ANSI, in its wisdom, says that - ;; EQL-SPECIALIZER-FORMs in EQL specializers are evaluated at - ;; DEFMETHOD expansion time. Thus, although one might think - ;; that in - ;; (DEFMETHOD FOO ((X PACKAGE) - ;; (Y (EQL 12)) - ;; ..)) - ;; the PACKAGE and (EQL 12) forms are both parallel type - ;; names, they're not, as is made clear when you do - ;; (DEFMETHOD FOO ((X PACKAGE) - ;; (Y (EQL 'BAR))) - ;; ..) - ;; where Y needs to be a symbol named "BAR", not some cons - ;; made by (CONS 'QUOTE 'BAR). I.e. when the - ;; EQL-SPECIALIZER-FORM is (EQL 'X), it requires an argument - ;; to be of type (EQL X). It'd be easy to transform one to - ;; the other, but it'd be somewhat messier to do so while - ;; ensuring that the EQL-SPECIALIZER-FORM is only EVAL'd - ;; once. (The new code wouldn't be messy, but it'd require a - ;; big transformation of the old code.) So instead we punt. - ;; -- WHN 20000610 - '(ignorable)) - ((member specializer - ;; KLUDGE: For some low-level implementation - ;; classes, perhaps because of some problems related - ;; to the incomplete integration of PCL into SBCL's - ;; type system, some specializer classes can't be - ;; declared as argument types. E.g. - ;; (DEFMETHOD FOO ((X SLOT-OBJECT)) - ;; (DECLARE (TYPE SLOT-OBJECT X)) - ;; ..) - ;; loses when - ;; (DEFSTRUCT BAR A B) - ;; (FOO (MAKE-BAR)) - ;; perhaps because of the way that STRUCTURE-OBJECT - ;; inherits both from SLOT-OBJECT and from - ;; SB-KERNEL:INSTANCE. In an effort to sweep such - ;; problems under the rug, we exclude these problem - ;; cases by blacklisting them here. -- WHN 2001-01-19 - (list 'slot-object #+nil (find-class 'slot-object))) - '(ignorable)) - ((not (eq *boot-state* 'complete)) - ;; KLUDGE: PCL, in its wisdom, sometimes calls methods with - ;; types which don't match their specializers. (Specifically, - ;; it calls ENSURE-CLASS-USING-CLASS (T NULL) with a non-NULL - ;; second argument.) Hopefully it only does this kind of - ;; weirdness when bootstrapping.. -- WHN 20000610 - '(ignorable)) - ((typep specializer 'eql-specializer) - `(type (eql ,(eql-specializer-object specializer)) ,parameter)) - ((var-globally-special-p parameter) - ;; KLUDGE: Don't declare types for global special variables - ;; -- our rebinding magic for SETQ cases don't work right - ;; there. - ;; - ;; FIXME: It would be better to detect the SETQ earlier and - ;; skip declarations for specials only when needed, not - ;; always. - ;; - ;; --NS 2004-10-14 - '(ignorable)) - (t - ;; Otherwise, we can usually make Python very happy. - ;; - ;; KLUDGE: Since INFO doesn't work right for class objects here, - ;; and they are valid specializers, see if the specializer is - ;; a named class, and use the name in that case -- otherwise - ;; the class instance is ok, since info will just return NIL, NIL. - ;; - ;; We still need to deal with the class case too, but at - ;; least #.(find-class 'integer) and integer as equivalent - ;; specializers with this. - (let* ((specializer (if (and (typep specializer 'class) - (let ((name (class-name specializer))) - (and name (symbolp name) - (eq specializer (find-class name nil))))) - (class-name specializer) - specializer)) - (kind (info :type :kind specializer))) - - (flet ((specializer-class () - (if (typep specializer 'class) - specializer - (find-class specializer nil)))) - (ecase kind - ((:primitive) `(type ,specializer ,parameter)) - ((:defined) - (let ((class (specializer-class))) - ;; CLASS can be null here if the user has erroneously - ;; tried to use a defined type as a specializer; it - ;; can be a non-BUILT-IN-CLASS if the user defines a - ;; type and calls (SETF FIND-CLASS) in a consistent - ;; way. - (when (and class (typep class 'built-in-class)) - `(type ,specializer ,parameter)))) - ((:instance nil) - (let ((class (specializer-class))) - (cond - (class - (if (typep class '(or built-in-class structure-class)) - `(type ,specializer ,parameter) - ;; don't declare CLOS classes as parameters; - ;; it's too expensive. - '(ignorable))) - (t - ;; we can get here, and still not have a failure - ;; case, by doing MOP programming like (PROGN - ;; (ENSURE-CLASS 'FOO) (DEFMETHOD BAR ((X FOO)) - ;; ...)). Best to let the user know we haven't - ;; been able to extract enough information: - (style-warn - "~@" - specializer - 'parameter-specializer-declaration-in-defmethod) - '(ignorable))))) - ((:forthcoming-defclass-type) - '(ignorable)))))))) +(unless (fboundp 'make-method-lambda) + (setf (gdefinition 'make-method-lambda) + (symbol-function 'real-make-method-lambda))) -(defun make-method-lambda-internal (method-lambda &optional env) +(defun make-method-lambda-internal (proto-gf proto-method method-lambda env) + (declare (ignore proto-gf proto-method)) (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda)) (error "The METHOD-LAMBDA argument to MAKE-METHOD-LAMBDA, ~S, ~ is not a lambda form." @@ -663,7 +601,15 @@ bootstrapping. (sll-decl (get-declaration '%method-lambda-list declarations)) (method-name (when (consp name-decl) (car name-decl))) (generic-function-name (when method-name (car method-name))) - (specialized-lambda-list (or sll-decl (cadr method-lambda)))) + (specialized-lambda-list (or sll-decl (cadr 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 + ;; between function and initargs, but not something that + ;; will be coalesced as a constant (because we are naughty, + ;; oh yes) with the expansion of any other methods in the + ;; same file. -- CSR, 2007-05-30 + (method-cell (list (make-symbol "METHOD-CELL")))) (multiple-value-bind (parameters lambda-list specializers) (parse-specialized-lambda-list specialized-lambda-list) (let* ((required-parameters @@ -671,7 +617,6 @@ bootstrapping. parameters specializers)) (slots (mapcar #'list required-parameters)) - (calls (list nil)) (class-declarations `(declare ;; These declarations seem to be used by PCL to pass @@ -741,35 +686,30 @@ bootstrapping. (return nil)))))) (multiple-value-bind (walked-lambda call-next-method-p closurep - next-method-p-p setq-p) + next-method-p-p setq-p + parameters-setqd) (walk-method-lambda method-lambda required-parameters env - slots - calls) + slots) (multiple-value-bind (walked-lambda-body walked-declarations walked-documentation) (parse-body (cddr walked-lambda)) (declare (ignore walked-documentation)) - (when (or next-method-p-p call-next-method-p) - (setq plist (list* :needs-next-methods-p t plist))) (when (some #'cdr slots) - (multiple-value-bind (slot-name-lists call-list) - (slot-name-lists-from-slots slots calls) - (let ((pv-table-symbol (make-symbol "pv-table"))) - (setq plist - `(,@(when slot-name-lists - `(:slot-name-lists ,slot-name-lists)) - ,@(when call-list - `(:call-list ,call-list)) - :pv-table-symbol ,pv-table-symbol - ,@plist)) - (setq walked-lambda-body - `((pv-binding (,required-parameters - ,slot-name-lists - ,pv-table-symbol) - ,@walked-lambda-body)))))) + (let ((slot-name-lists (slot-name-lists-from-slots slots))) + (setq plist + `(,@(when slot-name-lists + `(:slot-name-lists ,slot-name-lists)) + ,@plist)) + (setq walked-lambda-body + `((pv-binding (,required-parameters + ,slot-name-lists + (load-time-value + (intern-pv-table + :slot-name-lists ',slot-name-lists))) + ,@walked-lambda-body))))) (when (and (memq '&key lambda-list) (not (memq '&allow-other-keys lambda-list))) (let ((aux (memq '&aux lambda-list))) @@ -783,26 +723,211 @@ bootstrapping. ,call-next-method-p :next-method-p-p ,next-method-p-p :setq-p ,setq-p - ;; we need to pass this along - ;; so that NO-NEXT-METHOD can - ;; be given a suitable METHOD - ;; argument; we need the - ;; QUALIFIERS and SPECIALIZERS - ;; inside the declaration to - ;; give to FIND-METHOD. - :method-name-declaration ,name-decl + :method-cell ,method-cell :closurep ,closurep :applyp ,applyp) ,@walked-declarations - ,@walked-lambda-body)) - `(,@(when plist - `(:plist ,plist)) - ,@(when documentation - `(:documentation ,documentation))))))))))) + (locally + (declare (disable-package-locks + %parameter-binding-modified)) + (symbol-macrolet ((%parameter-binding-modified + ',@parameters-setqd)) + (declare (enable-package-locks + %parameter-binding-modified)) + ,@walked-lambda-body)))) + `(,@(when call-next-method-p `(method-cell ,method-cell)) + ,@(when plist `(plist ,plist)) + ,@(when documentation `(:documentation ,documentation))))))))))) + +(defun real-make-method-specializers-form + (proto-gf proto-method specializer-names env) + (declare (ignore env proto-gf proto-method)) + (flet ((parse (name) + (cond + ((and (eq *boot-state* 'complete) + (specializerp name)) + name) + ((symbolp name) `(find-class ',name)) + ((consp name) (ecase (car name) + ((eql) `(intern-eql-specializer ,(cadr name))) + ((class-eq) `(class-eq-specializer (find-class ',(cadr name)))) + ((prototype) `(fixme)))) + (t (bug "Foo"))))) + `(list ,@(mapcar #'parse specializer-names)))) + +(unless (fboundp 'make-method-specializers-form) + (setf (gdefinition 'make-method-specializers-form) + (symbol-function 'real-make-method-specializers-form))) + +(defun real-parse-specializer-using-class (generic-function specializer) + (let ((result (specializer-from-type specializer))) + (if (specializerp result) + result + (error "~@<~S cannot be parsed as a specializer for ~S.~@:>" + specializer generic-function)))) + +(unless (fboundp 'parse-specializer-using-class) + (setf (gdefinition 'parse-specializer-using-class) + (symbol-function 'real-parse-specializer-using-class))) + +(defun real-unparse-specializer-using-class (generic-function specializer) + (if (specializerp specializer) + ;; FIXME: this HANDLER-CASE is a bit of a hammer to crack a nut: + ;; the idea is that we want to unparse permissively, so that the + ;; lazy (or rather the "portable") specializer extender (who + ;; does not define methods on these new SBCL-specific MOP + ;; functions) can still subclass specializer and define methods + ;; without everything going wrong. Making it cleaner and + ;; clearer that that is what we are defending against would be + ;; nice. -- CSR, 2007-06-01 + (handler-case + (let ((type (specializer-type specializer))) + (if (and (consp type) (eq (car type) 'class)) + (let* ((class (cadr type)) + (class-name (class-name class))) + (if (eq class (find-class class-name nil)) + class-name + type)) + type)) + (error () specializer)) + (error "~@<~S is not a legal specializer for ~S.~@:>" + specializer generic-function))) + +(unless (fboundp 'unparse-specializer-using-class) + (setf (gdefinition 'unparse-specializer-using-class) + (symbol-function 'real-unparse-specializer-using-class))) -(unless (fboundp 'make-method-lambda) - (setf (gdefinition 'make-method-lambda) - (symbol-function 'real-make-method-lambda))) +;;; a helper function for creating Python-friendly type declarations +;;; in DEFMETHOD forms +(defun parameter-specializer-declaration-in-defmethod (parameter specializer) + (cond ((and (consp specializer) + (eq (car specializer) 'eql)) + ;; KLUDGE: ANSI, in its wisdom, says that + ;; EQL-SPECIALIZER-FORMs in EQL specializers are evaluated at + ;; DEFMETHOD expansion time. Thus, although one might think + ;; that in + ;; (DEFMETHOD FOO ((X PACKAGE) + ;; (Y (EQL 12)) + ;; ..)) + ;; the PACKAGE and (EQL 12) forms are both parallel type + ;; names, they're not, as is made clear when you do + ;; (DEFMETHOD FOO ((X PACKAGE) + ;; (Y (EQL 'BAR))) + ;; ..) + ;; where Y needs to be a symbol named "BAR", not some cons + ;; made by (CONS 'QUOTE 'BAR). I.e. when the + ;; EQL-SPECIALIZER-FORM is (EQL 'X), it requires an argument + ;; to be of type (EQL X). It'd be easy to transform one to + ;; the other, but it'd be somewhat messier to do so while + ;; ensuring that the EQL-SPECIALIZER-FORM is only EVAL'd + ;; once. (The new code wouldn't be messy, but it'd require a + ;; big transformation of the old code.) So instead we punt. + ;; -- WHN 20000610 + '(ignorable)) + ((member specializer + ;; KLUDGE: For some low-level implementation + ;; classes, perhaps because of some problems related + ;; to the incomplete integration of PCL into SBCL's + ;; type system, some specializer classes can't be + ;; declared as argument types. E.g. + ;; (DEFMETHOD FOO ((X SLOT-OBJECT)) + ;; (DECLARE (TYPE SLOT-OBJECT X)) + ;; ..) + ;; loses when + ;; (DEFSTRUCT BAR A B) + ;; (FOO (MAKE-BAR)) + ;; perhaps because of the way that STRUCTURE-OBJECT + ;; inherits both from SLOT-OBJECT and from + ;; SB-KERNEL:INSTANCE. In an effort to sweep such + ;; problems under the rug, we exclude these problem + ;; cases by blacklisting them here. -- WHN 2001-01-19 + (list 'slot-object #+nil (find-class 'slot-object))) + '(ignorable)) + ((not (eq *boot-state* 'complete)) + ;; KLUDGE: PCL, in its wisdom, sometimes calls methods with + ;; types which don't match their specializers. (Specifically, + ;; it calls ENSURE-CLASS-USING-CLASS (T NULL) with a non-NULL + ;; second argument.) Hopefully it only does this kind of + ;; weirdness when bootstrapping.. -- WHN 20000610 + '(ignorable)) + ((typep specializer 'eql-specializer) + `(type (eql ,(eql-specializer-object specializer)) ,parameter)) + ((var-globally-special-p parameter) + ;; KLUDGE: Don't declare types for global special variables + ;; -- our rebinding magic for SETQ cases don't work right + ;; there. + ;; + ;; FIXME: It would be better to detect the SETQ earlier and + ;; skip declarations for specials only when needed, not + ;; always. + ;; + ;; --NS 2004-10-14 + '(ignorable)) + (t + ;; Otherwise, we can usually make Python very happy. + ;; + ;; KLUDGE: Since INFO doesn't work right for class objects here, + ;; and they are valid specializers, see if the specializer is + ;; a named class, and use the name in that case -- otherwise + ;; the class instance is ok, since info will just return NIL, NIL. + ;; + ;; We still need to deal with the class case too, but at + ;; least #.(find-class 'integer) and integer as equivalent + ;; specializers with this. + (let* ((specializer-nameoid + (if (and (typep specializer 'class) + (let ((name (class-name specializer))) + (and name (symbolp name) + (eq specializer (find-class name nil))))) + (class-name specializer) + specializer)) + (kind (info :type :kind specializer-nameoid))) + + (flet ((specializer-nameoid-class () + (typecase specializer-nameoid + (symbol (find-class specializer-nameoid nil)) + (class specializer-nameoid) + (class-eq-specializer + (specializer-class specializer-nameoid)) + (t nil)))) + (ecase kind + ((:primitive) `(type ,specializer-nameoid ,parameter)) + ((:defined) + (let ((class (specializer-nameoid-class))) + ;; CLASS can be null here if the user has + ;; erroneously tried to use a defined type as a + ;; specializer; it can be a non-BUILT-IN-CLASS if + ;; the user defines a type and calls (SETF + ;; FIND-CLASS) in a consistent way. + (when (and class (typep class 'built-in-class)) + `(type ,specializer-nameoid ,parameter)))) + ((:instance nil) + (let ((class (specializer-nameoid-class))) + (cond + (class + (if (typep class '(or built-in-class structure-class)) + `(type ,class ,parameter) + ;; don't declare CLOS classes as parameters; + ;; it's too expensive. + '(ignorable))) + (t + ;; we can get here, and still not have a failure + ;; case, by doing MOP programming like (PROGN + ;; (ENSURE-CLASS 'FOO) (DEFMETHOD BAR ((X FOO)) + ;; ...)). Best to let the user know we haven't + ;; been able to extract enough information: + (style-warn + "~@" + specializer-nameoid + 'parameter-specializer-declaration-in-defmethod) + '(ignorable))))) + ((:forthcoming-defclass-type) + '(ignorable)))))))) + +;;; For passing a list (groveled by the walker) of the required +;;; parameters whose bindings are modified in the method body to the +;;; optimized-slot-value* macros. +(define-symbol-macro %parameter-binding-modified ()) (defmacro simple-lexical-method-functions ((lambda-list method-args @@ -828,7 +953,7 @@ bootstrapping. (defmacro bind-simple-lexical-method-functions ((method-args next-methods (&key call-next-method-p next-method-p-p setq-p - closurep applyp method-name-declaration)) + closurep applyp method-cell)) &body body &environment env) (if (not (or call-next-method-p setq-p closurep next-method-p-p applyp)) @@ -843,7 +968,7 @@ bootstrapping. ,@(if (safe-code-p env) `((%check-cnm-args cnm-args ,method-args - ',method-name-declaration)) + ',method-cell)) nil) (if .next-method. (funcall (if (std-instance-p .next-method.) @@ -852,29 +977,24 @@ bootstrapping. (or cnm-args ,method-args) ,next-methods) (apply #'call-no-next-method - ',method-name-declaration + ',method-cell (or cnm-args ,method-args)))))) ,@(and next-method-p-p '((next-method-p () (not (null .next-method.)))))) ,@body)))) -(defun call-no-next-method (method-name-declaration &rest args) - (destructuring-bind (name) method-name-declaration - (destructuring-bind (name &rest qualifiers-and-specializers) name - ;; KLUDGE: inefficient traversal, but hey. This should only - ;; happen on the slow error path anyway. - (let* ((qualifiers (butlast qualifiers-and-specializers)) - (specializers (car (last qualifiers-and-specializers))) - (method (find-method (gdefinition name) qualifiers specializers))) - (apply #'no-next-method - (method-generic-function method) - method - args))))) +(defun call-no-next-method (method-cell &rest args) + (let ((method (car method-cell))) + (aver method) + (apply #'no-next-method (method-generic-function method) + method args))) (defstruct (method-call (:copier nil)) (function #'identity :type function) call-method-args) +(defstruct (constant-method-call (:copier nil) (:include method-call)) + value) #-sb-fluid (declaim (sb-ext:freeze-type method-call)) @@ -895,20 +1015,51 @@ bootstrapping. (defstruct (fast-method-call (:copier nil)) (function #'identity :type function) - pv-cell + pv next-method-call arg-info) +(defstruct (constant-fast-method-call + (:copier nil) (:include fast-method-call)) + value) #-sb-fluid (declaim (sb-ext:freeze-type fast-method-call)) -(defmacro fmc-funcall (fn pv-cell next-method-call &rest args) - `(funcall ,fn ,pv-cell ,next-method-call ,@args)) - -(defmacro invoke-fast-method-call (method-call &rest required-args+rest-arg) - `(fmc-funcall (fast-method-call-function ,method-call) - (fast-method-call-pv-cell ,method-call) - (fast-method-call-next-method-call ,method-call) - ,@required-args+rest-arg)) +;; The two variants of INVOKE-FAST-METHOD-CALL differ in how REST-ARGs +;; are handled. The first one will get REST-ARG as a single list (as +;; the last argument), and will thus need to use APPLY. The second one +;; will get them as a &MORE argument, so we can pass the arguments +;; directly with MULTIPLE-VALUE-CALL and %MORE-ARG-VALUES. + +(defmacro invoke-fast-method-call (method-call restp &rest required-args+rest-arg) + `(,(if restp 'apply 'funcall) (fast-method-call-function ,method-call) + (fast-method-call-pv ,method-call) + (fast-method-call-next-method-call ,method-call) + ,@required-args+rest-arg)) + +(defmacro invoke-fast-method-call/more (method-call + more-context + more-count + &rest required-args) + (macrolet ((generate-call (n) + ``(funcall (fast-method-call-function ,method-call) + (fast-method-call-pv ,method-call) + (fast-method-call-next-method-call ,method-call) + ,@required-args + ,@(loop for x below ,n + collect `(sb-c::%more-arg ,more-context ,x))))) + ;; The cases with only small amounts of required arguments passed + ;; are probably very common, and special-casing speeds them up by + ;; a factor of 2 with very little effect on the other + ;; cases. Though it'd be nice to have the generic case be equally + ;; fast. + `(case ,more-count + (0 ,(generate-call 0)) + (1 ,(generate-call 1)) + (t (multiple-value-call (fast-method-call-function ,method-call) + (values (fast-method-call-pv ,method-call)) + (values (fast-method-call-next-method-call ,method-call)) + ,@required-args + (sb-c::%more-arg-values ,more-context 0 ,more-count)))))) (defstruct (fast-instance-boundp (:copier nil)) (index 0 :type fixnum)) @@ -958,63 +1109,91 @@ bootstrapping. (trace-emf-call-internal ,emf ,format ,args)))) (defmacro invoke-effective-method-function-fast - (emf restp &rest required-args+rest-arg) - `(progn - (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg)) - (invoke-fast-method-call ,emf ,@required-args+rest-arg))) - -(defmacro invoke-effective-method-function (emf restp - &rest required-args+rest-arg) - (unless (constantp restp) - (error "The RESTP argument is not constant.")) - ;; FIXME: The RESTP handling here is confusing and maybe slightly - ;; broken if RESTP evaluates to a non-self-evaluating form. E.g. if - ;; (INVOKE-EFFECTIVE-METHOD-FUNCTION EMF '(ERROR "gotcha") ...) - ;; then TRACE-EMF-CALL-CALL-INTERNAL might die on a gotcha error. - (setq restp (constant-form-value restp)) + (emf restp &key required-args rest-arg more-arg) `(progn - (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg)) - (cond ((typep ,emf 'fast-method-call) - (invoke-fast-method-call ,emf ,@required-args+rest-arg)) - ;; "What," you may wonder, "do these next two clauses do?" - ;; In that case, you are not a PCL implementor, for they - ;; considered this to be self-documenting.:-| Or CSR, for - ;; that matter, since he can also figure it out by looking - ;; at it without breaking stride. For the rest of us, - ;; though: From what the code is doing with .SLOTS. and - ;; whatnot, evidently it's implementing SLOT-VALUEish and - ;; GET-SLOT-VALUEish things. Then we can reason backwards - ;; and conclude that setting EMF to a FIXNUM is an - ;; optimized way to represent these slot access operations. - ,@(when (and (null restp) (= 1 (length required-args+rest-arg))) - `(((typep ,emf 'fixnum) - (let* ((.slots. (get-slots-or-nil - ,(car required-args+rest-arg))) - (value (when .slots. (clos-slots-ref .slots. ,emf)))) - (if (eq value +slot-unbound+) - (slot-unbound-internal ,(car required-args+rest-arg) - ,emf) - value))))) - ,@(when (and (null restp) (= 2 (length required-args+rest-arg))) - `(((typep ,emf 'fixnum) - (let ((.new-value. ,(car required-args+rest-arg)) - (.slots. (get-slots-or-nil - ,(cadr required-args+rest-arg)))) - (when .slots. - (setf (clos-slots-ref .slots. ,emf) .new-value.)))))) - ;; (In cmucl-2.4.8 there was a commented-out third ,@(WHEN - ;; ...) clause here to handle SLOT-BOUNDish stuff. Since - ;; there was no explanation and presumably the code is 10+ - ;; years stale, I simply deleted it. -- WHN) - (t - (etypecase ,emf - (method-call - (invoke-method-call ,emf ,restp ,@required-args+rest-arg)) - (function - ,(if restp - `(apply (the function ,emf) ,@required-args+rest-arg) - `(funcall (the function ,emf) - ,@required-args+rest-arg)))))))) + (trace-emf-call ,emf ,restp (list ,@required-args rest-arg)) + ,(if more-arg + `(invoke-fast-method-call/more ,emf + ,@more-arg + ,@required-args) + `(invoke-fast-method-call ,emf + ,restp + ,@required-args + ,@rest-arg)))) + +(defun effective-method-optimized-slot-access-clause + (emf restp required-args) + ;; "What," you may wonder, "do these next two clauses do?" In that + ;; case, you are not a PCL implementor, for they considered this to + ;; be self-documenting.:-| Or CSR, for that matter, since he can + ;; also figure it out by looking at it without breaking stride. For + ;; the rest of us, though: From what the code is doing with .SLOTS. + ;; and whatnot, evidently it's implementing SLOT-VALUEish and + ;; GET-SLOT-VALUEish things. Then we can reason backwards and + ;; conclude that setting EMF to a FIXNUM is an optimized way to + ;; represent these slot access operations. + (when (not restp) + (let ((length (length required-args))) + (cond ((= 1 length) + `((fixnum + (let* ((.slots. (get-slots-or-nil + ,(car required-args))) + (value (when .slots. (clos-slots-ref .slots. ,emf)))) + (if (eq value +slot-unbound+) + (slot-unbound-internal ,(car required-args) + ,emf) + value))))) + ((= 2 length) + `((fixnum + (let ((.new-value. ,(car required-args)) + (.slots. (get-slots-or-nil + ,(cadr required-args)))) + (when .slots. + (setf (clos-slots-ref .slots. ,emf) .new-value.))))))) + ;; (In cmucl-2.4.8 there was a commented-out third ,@(WHEN + ;; ...) clause here to handle SLOT-BOUNDish stuff. Since + ;; there was no explanation and presumably the code is 10+ + ;; years stale, I simply deleted it. -- WHN) + ))) + +;;; Before SBCL 0.9.16.7 instead of +;;; INVOKE-NARROW-EFFECTIVE-METHOD-FUNCTION we passed a (THE (OR +;;; FUNCTION METHOD-CALL FAST-METHOD-CALL) EMF) form as the EMF. Now, +;;; to make less work for the compiler we take a path that doesn't +;;; involve the slot-accessor clause (where EMF is a FIXNUM) at all. +(macrolet ((def (name &optional narrow) + `(defmacro ,name (emf restp &key required-args rest-arg more-arg) + (unless (constantp restp) + (error "The RESTP argument is not constant.")) + (setq restp (constant-form-value restp)) + (with-unique-names (emf-n) + `(locally + (declare (optimize (sb-c:insert-step-conditions 0))) + (let ((,emf-n ,emf)) + (trace-emf-call ,emf-n ,restp (list ,@required-args ,@rest-arg)) + (etypecase ,emf-n + (fast-method-call + ,(if more-arg + `(invoke-fast-method-call/more ,emf-n + ,@more-arg + ,@required-args) + `(invoke-fast-method-call ,emf-n + ,restp + ,@required-args + ,@rest-arg))) + ,@,(unless narrow + `(effective-method-optimized-slot-access-clause + emf-n restp required-args)) + (method-call + (invoke-method-call ,emf-n ,restp ,@required-args + ,@rest-arg)) + (function + ,(if restp + `(apply ,emf-n ,@required-args ,@rest-arg) + `(funcall ,emf-n ,@required-args + ,@rest-arg)))))))))) + (def invoke-effective-method-function nil) + (def invoke-narrow-effective-method-function t)) (defun invoke-emf (emf args) (trace-emf-call emf t args) @@ -1024,33 +1203,31 @@ bootstrapping. (restp (cdr arg-info)) (nreq (car arg-info))) (if restp - (let* ((rest-args (nthcdr nreq args)) - (req-args (ldiff args rest-args))) - (apply (fast-method-call-function emf) - (fast-method-call-pv-cell emf) - (fast-method-call-next-method-call emf) - (nconc req-args (list rest-args)))) + (apply (fast-method-call-function emf) + (fast-method-call-pv emf) + (fast-method-call-next-method-call emf) + args) (cond ((null args) (if (eql nreq 0) - (invoke-fast-method-call emf) + (invoke-fast-method-call emf nil) (error 'simple-program-error :format-control "invalid number of arguments: 0" :format-arguments nil))) ((null (cdr args)) (if (eql nreq 1) - (invoke-fast-method-call emf (car args)) + (invoke-fast-method-call emf nil (car args)) (error 'simple-program-error :format-control "invalid number of arguments: 1" :format-arguments nil))) ((null (cddr args)) (if (eql nreq 2) - (invoke-fast-method-call emf (car args) (cadr args)) + (invoke-fast-method-call emf nil (car args) (cadr args)) (error 'simple-program-error :format-control "invalid number of arguments: 2" :format-arguments nil))) (t (apply (fast-method-call-function emf) - (fast-method-call-pv-cell emf) + (fast-method-call-pv emf) (fast-method-call-next-method-call emf) args)))))) (method-call @@ -1086,38 +1263,15 @@ bootstrapping. (apply emf args)))) -(defmacro fast-narrowed-emf (emf) - ;; INVOKE-EFFECTIVE-METHOD-FUNCTION has code in it to dispatch on - ;; the possibility that EMF might be of type FIXNUM (as an optimized - ;; representation of a slot accessor). But as far as I (WHN - ;; 2002-06-11) can tell, it's impossible for such a representation - ;; to end up as .NEXT-METHOD-CALL. By reassuring INVOKE-E-M-F that - ;; when called from this context it needn't worry about the FIXNUM - ;; case, we can keep those cases from being compiled, which is good - ;; both because it saves bytes and because it avoids annoying type - ;; mismatch compiler warnings. - ;; - ;; KLUDGE: In sbcl-0.7.4.29, the compiler's type system isn't smart - ;; enough about NOT and intersection types to benefit from a (NOT - ;; FIXNUM) declaration here. -- WHN 2002-06-12 (FIXME: maybe it is - ;; now... -- CSR, 2003-06-07) - ;; - ;; FIXME: Might the FUNCTION type be omittable here, leaving only - ;; METHOD-CALLs? Failing that, could this be documented somehow? - ;; (It'd be nice if the types involved could be understood without - ;; solving the halting problem.) - `(the (or function method-call fast-method-call) - ,emf)) - (defmacro fast-call-next-method-body ((args next-method-call rest-arg) - method-name-declaration + method-cell cnm-args) `(if ,next-method-call - ,(let ((call `(invoke-effective-method-function - (fast-narrowed-emf ,next-method-call) + ,(let ((call `(invoke-narrow-effective-method-function + ,next-method-call ,(not (null rest-arg)) - ,@args - ,@(when rest-arg `(,rest-arg))))) + :required-args ,args + :rest-arg ,(when rest-arg (list rest-arg))))) `(if ,cnm-args (bind-args ((,@args ,@(when rest-arg @@ -1125,7 +1279,7 @@ bootstrapping. ,cnm-args) ,call) ,call)) - (call-no-next-method ',method-name-declaration + (call-no-next-method ',method-cell ,@args ,@(when rest-arg `(,rest-arg))))) @@ -1134,7 +1288,7 @@ bootstrapping. ((args rest-arg next-method-call (&key call-next-method-p setq-p - method-name-declaration + method-cell next-method-p-p closurep applyp)) @@ -1148,19 +1302,20 @@ bootstrapping. ,@body) `(flet (,@(when call-next-method-p `((call-next-method (&rest cnm-args) - (declare (muffle-conditions code-deletion-note)) + (declare (muffle-conditions code-deletion-note) + (optimize (sb-c:insert-step-conditions 0))) ,@(if (safe-code-p env) `((%check-cnm-args cnm-args (list ,@args) - ',method-name-declaration)) + ',method-cell)) nil) (fast-call-next-method-body (,args ,next-method-call ,rest-arg) - ,method-name-declaration - cnm-args)))) + ,method-cell + cnm-args)))) ,@(when next-method-p-p - `((next-method-p - () + `((next-method-p () + (declare (optimize (sb-c:insert-step-conditions 0))) (not (null ,next-method-call)))))) (let ,rebindings ,@(when rebindings `((declare (ignorable ,@all-params)))) @@ -1181,9 +1336,9 @@ bootstrapping. ;;; for COMPUTE-APPLICABLE-METHODS and probably a lot more of such ;;; preconditions. That looks hairy and is probably not worth it, ;;; because this check will never be fast. -(defun %check-cnm-args (cnm-args orig-args method-name-declaration) +(defun %check-cnm-args (cnm-args orig-args method-cell) (when cnm-args - (let* ((gf (fdefinition (caar method-name-declaration))) + (let* ((gf (method-generic-function (car method-cell))) (omethods (compute-applicable-methods gf orig-args)) (nmethods (compute-applicable-methods gf cnm-args))) (unless (equal omethods nmethods) @@ -1222,7 +1377,7 @@ bootstrapping. (pop ,args-tail) ,(cadr var))))) (t - `((,(caddr var) ,args-tail) + `((,(caddr var) (not (null ,args-tail))) (,(car var) (if ,args-tail (pop ,args-tail) ,(cadr var))))))) @@ -1252,7 +1407,7 @@ bootstrapping. (car var))) `((,key (get-key-arg-tail ',keyword ,args-tail)) - (,(caddr var) ,key) + (,(caddr var) (not (null,key))) (,variable (if ,key (car ,key) ,(cadr var)))))))) @@ -1278,14 +1433,19 @@ bootstrapping. when (eq key keyword) return tail)) -(defun walk-method-lambda (method-lambda required-parameters env slots calls) - (let ((call-next-method-p nil) ; flag indicating that CALL-NEXT-METHOD - ; should be in the method definition - (closurep nil) ; flag indicating that #'CALL-NEXT-METHOD - ; was seen in the body of a method - (next-method-p-p nil) ; flag indicating that NEXT-METHOD-P - ; should be in the method definition - (setq-p nil)) +(defun walk-method-lambda (method-lambda required-parameters env slots) + (let (;; flag indicating that CALL-NEXT-METHOD should be in the + ;; method definition + (call-next-method-p nil) + ;; flag indicating that #'CALL-NEXT-METHOD was seen in the + ;; body of a method + (closurep nil) + ;; flag indicating that NEXT-METHOD-P should be in the method + ;; definition + (next-method-p-p nil) + ;; a list of all required parameters whose bindings might be + ;; modified in the method body. + (parameters-setqd nil)) (flet ((walk-function (form context env) (cond ((not (eq context :eval)) form) ;; FIXME: Jumping to a conclusion from the way it's used @@ -1309,7 +1469,34 @@ bootstrapping. ;; force method doesn't really cost much; a little ;; loss of discrimination over IGNORED variables ;; should be all. -- CSR, 2004-07-01 - (setq setq-p t) + ;; + ;; As of 2006-09-18 modified parameter bindings + ;; are now tracked with more granularity than just + ;; one SETQ-P flag, in order to disable SLOT-VALUE + ;; optimizations for parameters that are SETQd. + ;; The old binary SETQ-P flag is still used for + ;; all other purposes, since as noted above, the + ;; extra cost is minimal. -- JES, 2006-09-18 + ;; + ;; The walker will split (SETQ A 1 B 2) to + ;; separate (SETQ A 1) and (SETQ B 2) forms, so we + ;; only need to handle the simple case of SETQ + ;; here. + (let ((vars (if (eq (car form) 'setq) + (list (second form)) + (second form)))) + (dolist (var vars) + ;; Note that we don't need to check for + ;; %VARIABLE-REBINDING declarations like is + ;; done in CAN-OPTIMIZE-ACCESS1, since the + ;; bindings that will have that declation will + ;; never be SETQd. + (when (var-declaration '%class var env) + ;; If a parameter binding is shadowed by + ;; another binding it won't have a %CLASS + ;; declaration anymore, and this won't get + ;; executed. + (pushnew var parameters-setqd)))) form) ((and (eq (car form) 'function) (cond ((eq (cadr form) 'call-next-method) @@ -1323,32 +1510,27 @@ bootstrapping. (t nil)))) ((and (memq (car form) '(slot-value set-slot-value slot-boundp)) - (constantp (caddr form))) - (let ((parameter (can-optimize-access form - required-parameters - env))) - (let ((fun (ecase (car form) - (slot-value #'optimize-slot-value) - (set-slot-value #'optimize-set-slot-value) - (slot-boundp #'optimize-slot-boundp)))) - (funcall fun slots parameter form)))) - ((and (eq (car form) 'apply) - (consp (cadr form)) - (eq (car (cadr form)) 'function) - (generic-function-name-p (cadr (cadr form)))) - (optimize-generic-function-call - form required-parameters env slots calls)) - ((generic-function-name-p (car form)) - (optimize-generic-function-call - form required-parameters env slots calls)) + (constantp (caddr form) env)) + (let ((fun (ecase (car form) + (slot-value #'optimize-slot-value) + (set-slot-value #'optimize-set-slot-value) + (slot-boundp #'optimize-slot-boundp)))) + (funcall fun form slots required-parameters env))) (t form)))) (let ((walked-lambda (walk-form method-lambda env #'walk-function))) - (values walked-lambda + ;;; FIXME: the walker's rewriting of the source code causes + ;;; trouble when doing code coverage. The rewrites should be + ;;; removed, and the same operations done using + ;;; compiler-macros or tranforms. + (values (if (sb-c:policy env (= sb-c:store-coverage-data 0)) + walked-lambda + method-lambda) call-next-method-p closurep next-method-p-p - setq-p))))) + (not (null parameters-setqd)) + parameters-setqd))))) (defun generic-function-name-p (name) (and (legal-fun-name-p name) @@ -1357,39 +1539,26 @@ bootstrapping. (standard-generic-function-p (gdefinition name)) (funcallable-instance-p (gdefinition name))))) -(defvar *method-function-plist* (make-hash-table :test 'eq)) - -(defun method-function-plist (method-function) - (gethash method-function *method-function-plist*)) - -(defun (setf method-function-plist) (val method-function) - (setf (gethash method-function *method-function-plist*) val)) - -(defun method-function-get (method-function key &optional default) - (getf (method-function-plist method-function) key default)) - -(defun (setf method-function-get) - (val method-function key) - (setf (getf (method-function-plist method-function) key) val)) - -(defun method-function-pv-table (method-function) - (method-function-get method-function :pv-table)) - -(defun method-function-method (method-function) - (method-function-get method-function :method)) - -(defun method-function-needs-next-methods-p (method-function) - (method-function-get method-function :needs-next-methods-p t)) +(defun method-plist-value (method key &optional default) + (let ((plist (if (consp method) + (getf (early-method-initargs method) 'plist) + (object-plist method)))) + (getf plist key default))) + +(defun (setf method-plist-value) (new-value method key &optional default) + (if (consp method) + (setf (getf (getf (early-method-initargs method) 'plist) key default) + new-value) + (setf (getf (object-plist method) key default) new-value))) -(defmacro method-function-closure-generator (method-function) - `(method-function-get ,method-function 'closure-generator)) - -(defun load-defmethod - (class name quals specls ll initargs source-location) - (setq initargs (copy-tree initargs)) - (let ((method-spec (or (getf initargs :method-spec) - (make-method-spec name quals specls)))) - (setf (getf initargs :method-spec) method-spec) +(defun load-defmethod (class name quals specls ll initargs source-location) + (let ((method-cell (getf initargs 'method-cell))) + (setq initargs (copy-tree initargs)) + (when method-cell + (setf (getf initargs 'method-cell) method-cell)) + #+nil + (setf (getf (getf initargs 'plist) :name) + (make-method-spec name quals specls)) (load-defmethod-internal class name quals specls ll initargs source-location))) @@ -1401,10 +1570,7 @@ bootstrapping. (let* ((gf (fdefinition gf-spec)) (method (and (generic-function-p gf) (generic-function-methods gf) - (find-method gf - qualifiers - (parse-specializers specializers) - nil)))) + (find-method gf qualifiers specializers nil)))) (when method (style-warn "redefining ~S~{ ~S~} ~S in DEFMETHOD" gf-spec qualifiers specializers)))) @@ -1425,43 +1591,32 @@ bootstrapping. method-class (class-name (class-of method)))) method)) -(defun make-method-spec (gf-spec qualifiers unparsed-specializers) - `(slow-method ,gf-spec ,@qualifiers ,unparsed-specializers)) +(defun make-method-spec (gf qualifiers specializers) + (let ((name (generic-function-name gf)) + (unparsed-specializers (unparse-specializers gf specializers))) + `(slow-method ,name ,@qualifiers ,unparsed-specializers))) -(defun initialize-method-function (initargs &optional return-function-p method) +(defun initialize-method-function (initargs method) (let* ((mf (getf initargs :function)) - (method-spec (getf initargs :method-spec)) - (plist (getf initargs :plist)) - (pv-table-symbol (getf plist :pv-table-symbol)) - (pv-table nil) - (mff (getf initargs :fast-function))) - (flet ((set-mf-property (p v) - (when mf - (setf (method-function-get mf p) v)) - (when mff - (setf (method-function-get mff p) v)))) - (when method-spec - (when mf - (setq mf (set-fun-name mf method-spec))) - (when mff - (let ((name `(fast-method ,@(cdr method-spec)))) - (set-fun-name mff name) - (unless mf - (set-mf-property :name name))))) - (when plist - (let ((snl (getf plist :slot-name-lists)) - (cl (getf plist :call-list))) - (when (or snl cl) - (setq pv-table (intern-pv-table :slot-name-lists snl - :call-list cl)) - (when pv-table (set pv-table-symbol pv-table)) - (set-mf-property :pv-table pv-table))) - (loop (when (null plist) (return nil)) - (set-mf-property (pop plist) (pop plist))) - (when method - (set-mf-property :method method)) - (when return-function-p - (or mf (method-function-from-fast-function mff))))))) + (mff (and (typep mf '%method-function) + (%method-function-fast-function mf))) + (plist (getf initargs 'plist)) + (name (getf plist :name)) + (method-cell (getf initargs 'method-cell))) + (when method-cell + (setf (car method-cell) method)) + (when name + (when mf + (setq mf (set-fun-name mf name))) + (when (and mff (consp name) (eq (car name) 'slow-method)) + (let ((fast-name `(fast-method ,@(cdr name)))) + (set-fun-name mff fast-name)))) + (when plist + (let ((plist plist)) + (let ((snl (getf plist :slot-name-lists))) + (when snl + (setf (method-plist-value method :pv-table) + (intern-pv-table :slot-name-lists snl)))))))) (defun analyze-lambda-list (lambda-list) (flet (;; FIXME: Is this redundant with SB-C::MAKE-KEYWORD-FOR-ARG? @@ -1558,17 +1713,21 @@ bootstrapping. (declare (ignore environment)) (let ((existing (and (fboundp fun-name) (gdefinition fun-name)))) - (if (and existing - (eq *boot-state* 'complete) - (null (generic-function-p existing))) - (generic-clobbers-function fun-name) - (apply #'ensure-generic-function-using-class - existing fun-name all-keys)))) + (cond ((and existing + (eq *boot-state* 'complete) + (null (generic-function-p existing))) + (generic-clobbers-function fun-name) + (fmakunbound fun-name) + (apply #'ensure-generic-function fun-name all-keys)) + (t + (apply #'ensure-generic-function-using-class + existing fun-name all-keys))))) (defun generic-clobbers-function (fun-name) - (error 'simple-program-error - :format-control "~S already names an ordinary function or a macro." - :format-arguments (list fun-name))) + (cerror "Replace the function binding" + 'simple-program-error + :format-control "~S already names an ordinary function or a macro." + :format-arguments (list fun-name))) (defvar *sgf-wrapper* (boot-make-wrapper (early-class-size 'standard-generic-function) @@ -1739,10 +1898,10 @@ bootstrapping. (defvar *sm-specializers-index* (!bootstrap-slot-index 'standard-method 'specializers)) -(defvar *sm-fast-function-index* - (!bootstrap-slot-index 'standard-method 'fast-function)) (defvar *sm-%function-index* (!bootstrap-slot-index 'standard-method '%function)) +(defvar *sm-qualifiers-index* + (!bootstrap-slot-index 'standard-method 'qualifiers)) (defvar *sm-plist-index* (!bootstrap-slot-index 'standard-method 'plist)) @@ -1750,7 +1909,7 @@ bootstrapping. ;;; class and deal with it as appropriate. In fact we probably don't ;;; need it anyway because we only use this for METHOD-SPECIALIZERS on ;;; the standard reader method for METHOD-SPECIALIZERS. Probably. -(dolist (s '(specializers fast-function %function plist)) +(dolist (s '(specializers %function plist)) (aver (= (symbol-value (intern (format nil "*SM-~A-INDEX*" s))) (!bootstrap-slot-index 'standard-reader-method s) (!bootstrap-slot-index 'standard-writer-method s) @@ -1767,15 +1926,9 @@ bootstrapping. (clos-slots-ref (get-slots method) *sm-specializers-index*) (method-specializers method)))) (defun safe-method-fast-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*)) - (class (class-of method))) - (if (member class standard-method-classes) - (clos-slots-ref (get-slots method) *sm-fast-function-index*) - (method-fast-function method)))) + (let ((mf (safe-method-function method))) + (and (typep mf '%method-function) + (%method-function-fast-function mf)))) (defun safe-method-function (method) (let ((standard-method-classes (list *the-class-standard-method* @@ -1794,8 +1947,7 @@ bootstrapping. *the-class-standard-boundp-method*)) (class (class-of method))) (if (member class standard-method-classes) - (let ((plist (clos-slots-ref (get-slots method) *sm-plist-index*))) - (getf plist 'qualifiers)) + (clos-slots-ref (get-slots method) *sm-qualifiers-index*) (method-qualifiers method)))) (defun set-arg-info1 (gf arg-info new-method methods was-valid-p first-p) @@ -1895,6 +2047,7 @@ bootstrapping. lambda-list-p) argument-precedence-order source-location + documentation &allow-other-keys) (declare (ignore keys)) (cond ((and existing (early-gf-p existing)) @@ -1904,19 +2057,21 @@ bootstrapping. ((assoc spec *!generic-function-fixups* :test #'equal) (if existing (make-early-gf spec lambda-list lambda-list-p existing - argument-precedence-order source-location) - (error "The function ~S is not already defined." spec))) + argument-precedence-order source-location + documentation) + (bug "The function ~S is not already defined." spec))) (existing - (error "~S should be on the list ~S." - spec - '*!generic-function-fixups*)) + (bug "~S should be on the list ~S." + spec '*!generic-function-fixups*)) (t (pushnew spec *!early-generic-functions* :test #'equal) (make-early-gf spec lambda-list lambda-list-p nil - argument-precedence-order source-location)))) + argument-precedence-order source-location + documentation)))) (defun make-early-gf (spec &optional lambda-list lambda-list-p - function argument-precedence-order source-location) + function argument-precedence-order source-location + documentation) (let ((fin (allocate-standard-funcallable-instance *sgf-wrapper* *sgf-slots-init*))) (set-funcallable-instance-function @@ -1932,10 +2087,10 @@ bootstrapping. has not been set." fin))))) (setf (gdefinition spec) fin) (!bootstrap-set-slot 'standard-generic-function fin 'name spec) - (!bootstrap-set-slot 'standard-generic-function - fin - 'source - source-location) + (!bootstrap-set-slot 'standard-generic-function fin + 'source source-location) + (!bootstrap-set-slot 'standard-generic-function fin + '%documentation documentation) (set-fun-name fin spec) (let ((arg-info (make-arg-info))) (setf (early-gf-arg-info fin) arg-info) @@ -1960,15 +2115,18 @@ bootstrapping. (setf (gf-dfun-state generic-function) new-value))) (defun set-dfun (gf &optional dfun cache info) - (when cache - (setf (cache-owner cache) gf)) (let ((new-state (if (and dfun (or cache info)) (list* dfun cache info) dfun))) - (if (eq *boot-state* 'complete) - (setf (safe-gf-dfun-state gf) new-state) - (setf (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*) - new-state))) + (cond + ((eq *boot-state* 'complete) + ;; Check that we are under the lock. + #+sb-thread + (aver (eq sb-thread:*current-thread* (sb-thread::spinlock-value (gf-lock gf)))) + (setf (safe-gf-dfun-state gf) new-state)) + (t + (setf (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*) + new-state)))) dfun) (defun gf-dfun-cache (gf) @@ -2047,11 +2205,12 @@ bootstrapping. fun-name &rest all-keys &key environment (lambda-list nil lambda-list-p) - (generic-function-class 'standard-generic-function gf-class-p) + (generic-function-class 'standard-generic-function) &allow-other-keys) (real-ensure-gf-internal generic-function-class all-keys environment) - (unless (or (null gf-class-p) - (eq (class-of existing) generic-function-class)) + ;; KLUDGE: the above macro does SETQ on GENERIC-FUNCTION-CLASS, + ;; which is what makes the next line work + (unless (eq (class-of existing) generic-function-class) (change-class existing generic-function-class)) (prog1 (apply #'reinitialize-instance existing all-keys) @@ -2108,7 +2267,6 @@ bootstrapping. (defun early-make-a-method (class qualifiers arglist specializers initargs doc &key slot-name object-class method-class-function) - (initialize-method-function initargs) (let ((parsed ()) (unparsed ())) ;; Figure out whether we got class objects or class names as the @@ -2126,32 +2284,36 @@ bootstrapping. specializers)) (setq unparsed specializers parsed ())) - (list :early-method ;This is an early method dammit! - - (getf initargs :function) - (getf initargs :fast-function) - - parsed ;The parsed specializers. This is used - ;by early-method-specializers to cache - ;the parse. Note that this only comes - ;into play when there is more than one - ;early method on an early gf. - - (append - (list class ;A list to which real-make-a-method - qualifiers ;can be applied to make a real method - arglist ;corresponding to this early one. - unparsed - initargs - doc) - (when slot-name - (list :slot-name slot-name :object-class object-class - :method-class-function method-class-function)))))) + (let ((result + (list :early-method + + (getf initargs :function) + (let ((mf (getf initargs :function))) + (aver mf) + (and (typep mf '%method-function) + (%method-function-fast-function mf))) + + ;; the parsed specializers. This is used by + ;; EARLY-METHOD-SPECIALIZERS to cache the parse. + ;; Note that this only comes into play when there is + ;; more than one early method on an early gf. + parsed + + ;; A list to which REAL-MAKE-A-METHOD can be applied + ;; to make a real method corresponding to this early + ;; one. + (append + (list class qualifiers arglist unparsed + initargs doc) + (when slot-name + (list :slot-name slot-name :object-class object-class + :method-class-function method-class-function)))))) + (initialize-method-function initargs result) + result))) (defun real-make-a-method (class qualifiers lambda-list specializers initargs doc &rest args &key slot-name object-class method-class-function) - (setq specializers (parse-specializers specializers)) (if method-class-function (let* ((object-class (if (classp object-class) object-class (find-class object-class))) @@ -2218,25 +2380,30 @@ bootstrapping. (defun early-method-lambda-list (early-method) (third (fifth early-method))) -(defun early-add-named-method (generic-function-name - qualifiers - specializers - arglist - &rest initargs) - (let* ((gf (ensure-generic-function generic-function-name)) +(defun early-method-initargs (early-method) + (fifth (fifth early-method))) + +(defun (setf early-method-initargs) (new-value early-method) + (setf (fifth (fifth early-method)) new-value)) + +(defun early-add-named-method (generic-function-name qualifiers + specializers arglist &rest initargs) + (let* (;; we don't need to deal with the :generic-function-class + ;; argument here because the default, + ;; STANDARD-GENERIC-FUNCTION, is right for all early generic + ;; functions. (See REAL-ADD-NAMED-METHOD) + (gf (ensure-generic-function generic-function-name)) (existing (dolist (m (early-gf-methods gf)) (when (and (equal (early-method-specializers m) specializers) (equal (early-method-qualifiers m) qualifiers)) - (return m)))) - (new (make-a-method 'standard-method - qualifiers - arglist - specializers - initargs - ()))) - (when existing (remove-method gf existing)) - (add-method gf new))) + (return m))))) + (setf (getf (getf initargs 'plist) :name) + (make-method-spec gf qualifiers specializers)) + (let ((new (make-a-method 'standard-method qualifiers arglist + specializers initargs (getf initargs :documentation)))) + (when existing (remove-method gf existing)) + (add-method gf new)))) ;;; This is the early version of ADD-METHOD. Later this will become a ;;; generic function. See !FIX-EARLY-GENERIC-FUNCTIONS which has @@ -2343,7 +2510,7 @@ bootstrapping. (gf (gdefinition fspec)) (methods (mapcar (lambda (method) (let* ((lambda-list (first method)) - (specializers (second method)) + (specializers (mapcar #'find-class (second method))) (method-fn-name (third method)) (fn-name (or method-fn-name fspec)) (fn (fdefinition fn-name)) @@ -2383,63 +2550,17 @@ bootstrapping. (setq spec-ll (pop cdr-of-form)) (values name qualifiers spec-ll cdr-of-form))) -(defun parse-specializers (specializers) +(defun parse-specializers (generic-function specializers) (declare (list specializers)) (flet ((parse (spec) - (let ((result (specializer-from-type spec))) - (if (specializerp result) - result - (if (symbolp spec) - (error "~S was used as a specializer,~%~ - but is not the name of a class." - spec) - (error "~S is not a legal specializer." spec)))))) + (parse-specializer-using-class generic-function spec))) (mapcar #'parse specializers))) -(defun unparse-specializers (specializers-or-method) - (if (listp specializers-or-method) - (flet ((unparse (spec) - (if (specializerp spec) - (let ((type (specializer-type spec))) - (if (and (consp type) - (eq (car type) 'class)) - (let* ((class (cadr type)) - (class-name (class-name class))) - (if (eq class (find-class class-name nil)) - class-name - type)) - type)) - (error "~S is not a legal specializer." spec)))) - (mapcar #'unparse specializers-or-method)) - (unparse-specializers (method-specializers specializers-or-method)))) - -(defun parse-method-or-spec (spec &optional (errorp t)) - (let (gf method name temp) - (if (method-p spec) - (setq method spec - gf (method-generic-function method) - temp (and gf (generic-function-name gf)) - name (if temp - (make-method-spec temp - (method-qualifiers method) - (unparse-specializers - (method-specializers method))) - (make-symbol (format nil "~S" method)))) - (multiple-value-bind (gf-spec quals specls) - (parse-defmethod spec) - (and (setq gf (and (or errorp (fboundp gf-spec)) - (gdefinition gf-spec))) - (let ((nreq (compute-discriminating-function-arglist-info gf))) - (setq specls (append (parse-specializers specls) - (make-list (- nreq (length specls)) - :initial-element - *the-class-t*))) - (and - (setq method (get-method gf quals specls errorp)) - (setq name - (make-method-spec - gf-spec quals (unparse-specializers specls)))))))) - (values gf method name))) +(defun unparse-specializers (generic-function specializers) + (declare (list specializers)) + (flet ((unparse (spec) + (unparse-specializer-using-class generic-function spec))) + (mapcar #'unparse specializers))) (defun extract-parameters (specialized-lambda-list) (multiple-value-bind (parameters ignore1 ignore2) @@ -2551,13 +2672,18 @@ bootstrapping. ;;; walker stuff was only used for implementing stuff like that; maybe ;;; it's not needed any more? Hunt down what it was used for and see. +(defun extract-the (form) + (cond ((and (consp form) (eq (car form) 'the)) + (aver (proper-list-of-length-p 3)) + (third form)) + (t + form))) + (defmacro with-slots (slots instance &body body) (let ((in (gensym))) `(let ((,in ,instance)) (declare (ignorable ,in)) - ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the)) - (third instance) - instance))) + ,@(let ((instance (extract-the instance))) (and (symbolp instance) `((declare (%variable-rebinding ,in ,instance))))) ,in @@ -2579,9 +2705,7 @@ bootstrapping. (let ((in (gensym))) `(let ((,in ,instance)) (declare (ignorable ,in)) - ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the)) - (third instance) - instance))) + ,@(let ((instance (extract-the instance))) (and (symbolp instance) `((declare (%variable-rebinding ,in ,instance))))) ,in