From 7474a620a5538091b9c1cba877156f5645d78aa6 Mon Sep 17 00:00:00 2001 From: Juho Snellman Date: Mon, 13 Nov 2006 07:20:20 +0000 Subject: [PATCH] 0.9.18.48: Make calling methods with &OPTIONALs or &KEYs faster and non-consing. * Change fast method functions to use the normal Lisp argument passing convention, rather than the CLOS-style "required arguments as normal Lisp arguments, non-required ones passed as one list" convention. * Don't do argument parsing manually in the FMFs generated by MAKE-METHOD-INITARGS-FORM-INTERNAL1 * Use &MORE instead of &REST in DFUN lambda lists. * Clean up the lambda-list generation mess in cache.lisp / dlisp.lisp --- NEWS | 2 + src/pcl/boot.lisp | 116 ++++++++++++++++++++---------- src/pcl/cache.lisp | 72 ++++++++++++------- src/pcl/combin.lisp | 70 +++++++++++-------- src/pcl/dlisp.lisp | 53 +++++++------- src/pcl/slots-boot.lisp | 3 +- src/pcl/vector.lisp | 178 ++++++++++++++++++++++------------------------- tests/clos.impure.lisp | 121 ++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 9 files changed, 403 insertions(+), 214 deletions(-) diff --git a/NEWS b/NEWS index 3c4f8f1..b685d71 100644 --- a/NEWS +++ b/NEWS @@ -34,6 +34,8 @@ changes in sbcl-0.9.19 (1.0.0?) relative to sbcl-0.9.18: (reported by Josip Gracin) * bug fix: an error is signaled for attempts to displace arrays with incompatible element types (thanks to Mario Mommer) + * optimization: method calls with &OPTIONAL or &KEY arguments are faster + and don't cause extra consing * Improvements to the Windows port: ** floating point exceptions are now reported correctly. ** stack exhaustion detection works partially. diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 66d26ef..8c4e28e 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -918,14 +918,42 @@ bootstrapping. #-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-cell ,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-cell ,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-cell ,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)) @@ -975,13 +1003,20 @@ bootstrapping. (trace-emf-call-internal ,emf ,format ,args)))) (defmacro invoke-effective-method-function-fast - (emf restp &rest required-args+rest-arg) + (emf restp &key required-args rest-arg more-arg) `(progn - (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg)) - (invoke-fast-method-call ,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+rest-arg) + (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 @@ -992,21 +1027,21 @@ bootstrapping. ;; 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+rest-arg))) + (let ((length (length required-args))) (cond ((= 1 length) `((fixnum (let* ((.slots. (get-slots-or-nil - ,(car required-args+rest-arg))) + ,(car required-args))) (value (when .slots. (clos-slots-ref .slots. ,emf)))) (if (eq value +slot-unbound+) - (slot-unbound-internal ,(car required-args+rest-arg) + (slot-unbound-internal ,(car required-args) ,emf) value))))) ((= 2 length) `((fixnum - (let ((.new-value. ,(car required-args+rest-arg)) + (let ((.new-value. ,(car required-args)) (.slots. (get-slots-or-nil - ,(cadr required-args+rest-arg)))) + ,(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 @@ -1021,7 +1056,7 @@ bootstrapping. ;;; 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 &rest required-args+rest-arg) + `(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)) @@ -1029,19 +1064,28 @@ bootstrapping. `(locally (declare (optimize (sb-c:insert-step-conditions 0))) (let ((,emf-n ,emf)) - (trace-emf-call ,emf-n ,restp (list ,@required-args+rest-arg)) + (trace-emf-call ,emf-n ,restp (list ,@required-args ,@rest-arg)) (etypecase ,emf-n (fast-method-call - (invoke-fast-method-call ,emf-n ,@required-args+rest-arg)) + ,(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+rest-arg)) + emf-n restp required-args)) (method-call - (invoke-method-call ,emf-n ,restp ,@required-args+rest-arg)) + (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)))))))))) + `(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)) @@ -1053,27 +1097,25 @@ 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-cell 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))) @@ -1122,8 +1164,8 @@ bootstrapping. ,(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 @@ -1229,7 +1271,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))))))) @@ -1259,7 +1301,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)))))))) diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp index bdb7811..68b34ed 100644 --- a/src/pcl/cache.lisp +++ b/src/pcl/cache.lisp @@ -685,31 +685,37 @@ (dotimes (i (length metatypes)) (push (dfun-arg-symbol i) lambda-list)) (when applyp - (push '&rest lambda-list) - (push '.dfun-rest-arg. lambda-list)) + ;; Use &MORE arguments to avoid consing up an &REST list that we + ;; might not need at all. See MAKE-EMF-CALL and + ;; INVOKE-EFFECTIVE-METHOD-FUNCTION for the other pieces. + (push '&more lambda-list) + (push '.dfun-more-context. lambda-list) + (push '.dfun-more-count. lambda-list)) (nreverse lambda-list))) (defun make-dlap-lambda-list (metatypes applyp) - (let ((lambda-list nil)) + (let ((args nil) + (lambda-list nil)) (dotimes (i (length metatypes)) + (push (dfun-arg-symbol i) args) (push (dfun-arg-symbol i) lambda-list)) - ;; FIXME: This is translated directly from the old PCL code. - ;; It didn't have a (PUSH '.DFUN-REST-ARG. LAMBDA-LIST) or - ;; something similar, so we don't either. It's hard to see how - ;; this could be correct, since &REST wants an argument after - ;; it. This function works correctly because the caller - ;; magically tacks on something after &REST. The calling functions - ;; (in dlisp.lisp) should be fixed and this function rewritten. - ;; --njf 2001-12-20 (when applyp - (push '&rest lambda-list)) - (nreverse lambda-list))) + (push '&more lambda-list) + (push '.more-context. lambda-list) + (push '.more-count. lambda-list)) + ;; Return the full lambda list, the required arguments, a form + ;; that will generate a rest-list, and a list of the &MORE + ;; parameters used. + (values (nreverse lambda-list) + (nreverse args) + (when applyp + '((sb-c::%listify-rest-args + .more-context. + (the (and unsigned-byte fixnum) + .more-count.)))) + (when applyp + '(.more-context. .more-count.))))) -;; FIXME: The next two functions suffer from having a `.DFUN-REST-ARG.' -;; in their lambda lists, but no corresponding `&REST' symbol. We assume -;; this should be the case by analogy with the previous two functions. -;; It works, and I don't know why. Check the calling functions and -;; fix these too. --njf 2001-12-20 (defun make-emf-call (metatypes applyp fn-variable &optional emf-type) (let ((required (let ((required nil)) @@ -719,17 +725,29 @@ `(,(if (eq emf-type 'fast-method-call) 'invoke-effective-method-function-fast 'invoke-effective-method-function) - ,fn-variable ,applyp ,@required ,@(when applyp `(.dfun-rest-arg.))))) + ,fn-variable + ,applyp + :required-args ,required + ;; INVOKE-EFFECTIVE-METHOD-FUNCTION will decide whether to use + ;; the :REST-ARG version or the :MORE-ARG version depending on + ;; the type of the EMF. + :rest-arg ,(if applyp + ;; Creates a list from the &MORE arguments. + '((sb-c::%listify-rest-args + .dfun-more-context. + (the (and unsigned-byte fixnum) + .dfun-more-count.))) + nil) + :more-arg ,(when applyp + '(.dfun-more-context. .dfun-more-count.))))) (defun make-fast-method-call-lambda-list (metatypes applyp) - (let ((reversed-lambda-list nil)) - (push '.pv-cell. reversed-lambda-list) - (push '.next-method-call. reversed-lambda-list) - (dotimes (i (length metatypes)) - (push (dfun-arg-symbol i) reversed-lambda-list)) - (when applyp - (push '.dfun-rest-arg. reversed-lambda-list)) - (nreverse reversed-lambda-list))) + (let ((lambda-list (make-dfun-lambda-list metatypes applyp))) + ;; Reverse order + (push '.next-method-call. lambda-list) + (push '.pv-cell. lambda-list) + lambda-list)) + (defmacro with-local-cache-functions ((cache) &body body) `(let ((.cache. ,cache)) diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp index b2743d3..ba3d35a 100644 --- a/src/pcl/combin.lisp +++ b/src/pcl/combin.lisp @@ -249,7 +249,11 @@ (dotimes (i (length metatypes) (nreverse req)) (push (dfun-arg-symbol i) req)))) (gf-args (if applyp - `(list* ,@required .dfun-rest-arg.) + `(list* ,@required + (sb-c::%listify-rest-args + .dfun-more-context. + (the (and (unsigned-byte fixnum)) + .dfun-more-count.))) `(list ,@required)))) `(lambda ,ll (declare (ignore .pv-cell. .next-method-call.)) @@ -322,10 +326,11 @@ ,(make-emf-call metatypes applyp 'emf type)) (list gensym)))) (check-applicable-keywords - (values `(check-applicable-keywords - .dfun-rest-arg. .keyargs-start. .valid-keys.) + (values `(check-applicable-keywords .keyargs-start. + .valid-keys. + .dfun-more-context. + .dfun-more-count.) '(.keyargs-start. .valid-keys.))) - (t (default-code-converter form)))) @@ -488,34 +493,41 @@ (aver any-keyp) (values (if allowp t keys) nopt))))) -(defun check-applicable-keywords (args start valid-keys) +(defun check-applicable-keywords (start valid-keys more-context more-count) (let ((allow-other-keys-seen nil) (allow-other-keys nil) - (args (nthcdr start args))) - (collect ((invalid)) - (loop - (when (null args) - (when (and (invalid) (not allow-other-keys)) - (error 'simple-program-error - :format-control "~@= i more-count) + (when (and (invalid) (not allow-other-keys)) + (error 'simple-program-error + :format-control "~@" - :format-arguments (list (length (invalid)) (invalid) valid-keys))) - (return)) - (let ((key (pop args))) - (cond - ((not (symbolp key)) - (error 'simple-program-error - :format-control "~@" - :format-arguments (list key))) - ((null args) (sb-c::%odd-key-args-error)) - ((eq key :allow-other-keys) - ;; only the leftmost :ALLOW-OTHER-KEYS has any effect - (unless allow-other-keys-seen - (setq allow-other-keys-seen t - allow-other-keys (car args)))) - ((eq t valid-keys)) - ((not (memq key valid-keys)) (invalid key)))) - (pop args))))) + :format-arguments (list (length (invalid)) (invalid) valid-keys))) + (return)) + (let ((key (current-value))) + (incf i) + (cond + ((not (symbolp key)) + (error 'simple-program-error + :format-control "~@" + :format-arguments (list key))) + ((= i more-count) + (sb-c::%odd-key-args-error)) + ((eq key :allow-other-keys) + ;; only the leftmost :ALLOW-OTHER-KEYS has any effect + (unless allow-other-keys-seen + (setq allow-other-keys-seen t + allow-other-keys (current-value)))) + ((eq t valid-keys)) + ((not (memq key valid-keys)) (invalid key)))) + (incf i)))))) ;;;; the STANDARD method combination type. This is coded by hand ;;;; (rather than with DEFINE-METHOD-COMBINATION) for bootstrapping diff --git a/src/pcl/dlisp.lisp b/src/pcl/dlisp.lisp index 26419ce..35433f2 100644 --- a/src/pcl/dlisp.lisp +++ b/src/pcl/dlisp.lisp @@ -104,29 +104,26 @@ (when (and (null *precompiling-lap*) *emit-function-p*) (return-from emit-default-only (emit-default-only-function metatypes applyp)))) - (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)) - (args (remove '&rest dlap-lambda-list)) - (restl (when applyp '(.lap-rest-arg.)))) + (multiple-value-bind (lambda-list args rest-arg more-arg) + (make-dlap-lambda-list metatypes applyp) (generating-lisp '(emf) - dlap-lambda-list + lambda-list `(invoke-effective-method-function emf ,applyp - ,@args - ,@restl)))) + :required-args ,args + :more-arg ,more-arg + :rest-arg ,rest-arg)))) ;;; -------------------------------- (defun generating-lisp (closure-variables args form) - (let* ((rest (memq '&rest args)) - (ldiff (and rest (ldiff args rest))) - (args (if rest (append ldiff '(&rest .lap-rest-arg.)) args)) - (lambda `(lambda ,closure-variables - ,@(when (member 'miss-fn closure-variables) - `((declare (type function miss-fn)))) - #'(lambda ,args - (let () - (declare #.*optimize-speed*) - ,form))))) + (let ((lambda `(lambda ,closure-variables + ,@(when (member 'miss-fn closure-variables) + `((declare (type function miss-fn)))) + #'(lambda ,args + (let () + (declare #.*optimize-speed*) + ,form))))) (values (if *precompiling-lap* `#',lambda (compile nil lambda)) @@ -254,11 +251,13 @@ cached-index-p class-slot-p)))) -(defun emit-miss (miss-fn args &optional applyp) - (let ((restl (when applyp '(.lap-rest-arg.)))) - (if restl - `(apply ,miss-fn ,@args ,@restl) - `(funcall ,miss-fn ,@args ,@restl)))) +(defun emit-miss (miss-fn args applyp) + (if applyp + `(multiple-value-call ,miss-fn ,@args + (sb-c::%more-arg-values .more-context. + 0 + .more-count.)) + `(funcall ,miss-fn ,@args))) (defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp) (unless *optimize-cache-functions-p* @@ -266,19 +265,21 @@ (return-from emit-checking-or-caching (emit-checking-or-caching-function cached-emf-p return-value-p metatypes applyp)))) - (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)) - (args (remove '&rest dlap-lambda-list)) - (restl (when applyp '(.lap-rest-arg.)))) + (multiple-value-bind (lambda-list args rest-arg more-arg) + (make-dlap-lambda-list metatypes applyp) (generating-lisp `(cache ,@(unless cached-emf-p '(emf)) miss-fn) - dlap-lambda-list + lambda-list `(let (,@(when cached-emf-p '(emf))) ,(emit-dlap args metatypes (if return-value-p (if cached-emf-p 'emf t) `(invoke-effective-method-function - emf ,applyp ,@args ,@restl)) + emf ,applyp + :required-args ,args + :more-arg ,more-arg + :rest-arg ,rest-arg)) (emit-miss 'miss-fn args applyp) (when cached-emf-p 'emf)))))) diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index c69646a..e5e9d95 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -433,7 +433,8 @@ (defun get-accessor-from-svuc-method-function (class slotd sdfun name) (macrolet ((emf-funcall (emf &rest args) - `(invoke-effective-method-function ,emf nil ,@args))) + `(invoke-effective-method-function ,emf nil + :required-args ,args))) (set-fun-name (case name (reader (lambda (instance) diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index a9d8160..549c5e3 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -379,10 +379,10 @@ ;; Note that we must still call OPTIMIZE-INSTANCE-ACCESS at ;; this point (instead of when expanding ;; OPTIMIZED-SLOT-VALUE), since it mutates the structure of - ;; SLOTS. If that mutation isn't done while during the - ;; walking, MAKE-METHOD-LAMBDA-INTERNAL won't wrap a correct - ;; PV-BINDING form around the body, and compilation will fail. - ;; -- JES, 2006-09-18 + ;; SLOTS. If that mutation isn't done during the walking, + ;; MAKE-METHOD-LAMBDA-INTERNAL won't wrap a correct PV-BINDING + ;; form around the body, and compilation will fail. -- JES, + ;; 2006-09-18 `(optimized-slot-value ,form ,(car sparameter) ,optimized-form)) `(accessor-slot-value ,@(cdr form)))) @@ -509,60 +509,6 @@ `(instance-boundp ,pv-offset-form ,parameter ,position ',slot-name ',class))))))) -(defvar *unspecific-arg* '..unspecific-arg..) - -(defun optimize-gf-call-internal (form slots env) - (when (and (consp form) - (eq (car form) 'the)) - (setq form (caddr form))) - (or (and (symbolp form) - (let* ((rebound? (caddr (var-declaration '%variable-rebinding - form - env))) - (parameter-or-nil (car (assq (or rebound? form) slots)))) - (when parameter-or-nil - (let* ((class-name (caddr (var-declaration 'class - parameter-or-nil - env)))) - (when (and class-name (not (eq class-name t))) - (position parameter-or-nil slots :key #'car)))))) - (if (constantp form) - (let ((form (constant-form-value form))) - (if (symbolp form) - form - *unspecific-arg*)) - *unspecific-arg*))) - -(defun optimize-gf-call (slots calls gf-call-form nreq restp env) - (unless (eq (car gf-call-form) 'make-instance) ; XXX needs more work - (let* ((args (cdr gf-call-form)) - (all-args-p (eq (car gf-call-form) 'make-instance)) - (non-required-args (nthcdr nreq args)) - (required-args (ldiff args non-required-args)) - (call-spec (list (car gf-call-form) nreq restp - (mapcar (lambda (form) - (optimize-gf-call-internal form slots env)) - (if all-args-p - args - required-args)))) - (call-entry (assoc call-spec calls :test #'equal)) - (pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) - (unless (some #'integerp - (let ((spec-args (cdr call-spec))) - (if all-args-p - (ldiff spec-args (nthcdr nreq spec-args)) - spec-args))) - (return-from optimize-gf-call nil)) - (unless call-entry - (setq call-entry (list call-spec)) - (push call-entry (cdr calls))) - (push pv-offset-form (cdr call-entry)) - (if (eq (car call-spec) 'make-instance) - `(funcall (pv-ref .pv. ,pv-offset-form) ,@(cdr gf-call-form)) - `(let ((.emf. (pv-ref .pv. ,pv-offset-form))) - (invoke-effective-method-function .emf. ,restp - ,@required-args ,@(when restp `((list ,@non-required-args))))))))) - (define-walker-template pv-offset) ; These forms get munged by mutate slots. (defmacro pv-offset (arg) arg) (define-walker-template instance-accessor-parameter) @@ -1009,38 +955,88 @@ (make-method-initargs-form-internal1 initargs (cddr lmf) args lmf-params restp))))) +(defun lambda-list-parameter-names (lambda-list) + ;; Given a valid lambda list, extract the parameter names. + (loop for x in lambda-list + with res = nil + do (unless (member x lambda-list-keywords) + (if (consp x) + (let ((name (car x))) + (if (consp name) + ;; ... ((:BAR FOO) 1) + (push (second name) res) + ;; ... (FOO 1) + (push name res)) + ;; ... (... 1 FOO-P) + (let ((name-p (cddr x))) + (when name-p + (push (car name-p) res)))) + ;; ... FOO + (push x res))) + finally (return res))) + (defun make-method-initargs-form-internal1 (initargs body req-args lmf-params restp) - (multiple-value-bind (outer-decls inner-decls body-sans-decls) - (split-declarations - body req-args (or (getf (cdr lmf-params) :call-next-method-p) - (getf (cdr lmf-params) :setq-p))) - (let* ((rest-arg (when restp '.rest-arg.)) - (args+rest-arg (if restp - (append req-args (list rest-arg)) - req-args))) - `(list* - :function - (let* ((fmf (,(if (body-method-name body) 'named-lambda 'lambda) - ,@(when (body-method-name body) - ;; function name - (list (cons 'fast-method (body-method-name body)))) - (.pv-cell. .next-method-call. ,@args+rest-arg) ; function args - ;; body of the function - (declare (ignorable .pv-cell. .next-method-call.) - (disable-package-locks pv-env-environment)) - ,@outer-decls - (symbol-macrolet ((pv-env-environment default)) - (fast-lexical-method-functions - (,(car lmf-params) .next-method-call. ,req-args ,rest-arg - ,@(cdddr lmf-params)) - ,@inner-decls - ,@body-sans-decls)))) - (mf (%make-method-function fmf nil))) - (set-funcallable-instance-function - mf (method-function-from-fast-function fmf ',(getf initargs 'plist))) - mf) - ',initargs)))) + (let* (;; The lambda-list of the method, minus specifiers + (lambda-list (car lmf-params)) + ;; Names of the parameters that will be in the outermost lambda-list + ;; (and whose bound declarations thus need to be in OUTER-DECLS). + (outer-parameters req-args) + ;; The lambda-list used by BIND-ARGS + (bind-list lambda-list) + (setq-p (getf (cdr lmf-params) :setq-p)) + (call-next-method-p (getf (cdr lmf-params) :call-next-method-p))) + ;; Try to use the normal function call machinery instead of BIND-ARGS + ;; bindings the arguments, unless: + (unless (or ;; If all arguments are required, BIND-ARGS will be a no-op + ;; in any case. + (not restp) + ;; CALL-NEXT-METHOD wants to use BIND-ARGS, and needs a + ;; list of all non-required arguments. + call-next-method-p) + (setf ;; We don't want a binding for .REST-ARG. + restp nil + ;; Get all the parameters for declaration parsing + outer-parameters (lambda-list-parameter-names lambda-list) + ;; Ensure that BIND-ARGS won't do anything (since + ;; BIND-LIST won't contain any non-required parameters, + ;; and REQ-ARGS will be of an equal length). We still want + ;; to pass BIND-LIST to FAST-LEXICAL-METHOD-FUNCTIONS so + ;; that BIND-FAST-LEXICAL-METHOD-FUNCTIONS can take care + ;; of rebinding SETQd required arguments around the method + ;; body. + bind-list req-args)) + (multiple-value-bind (outer-decls inner-decls body-sans-decls) + (split-declarations + body outer-parameters (or call-next-method-p setq-p)) + (let* ((rest-arg (when restp + '.rest-arg.)) + (fmf-lambda-list (if rest-arg + (append req-args (list '&rest rest-arg)) + lambda-list))) + `(list* + :function + (let* ((fmf (,(if (body-method-name body) 'named-lambda 'lambda) + ,@(when (body-method-name body) + ;; function name + (list (cons 'fast-method (body-method-name body)))) + ;; The lambda-list of the FMF + (.pv-cell. .next-method-call. ,@fmf-lambda-list) + ;; body of the function + (declare (ignorable .pv-cell. .next-method-call.) + (disable-package-locks pv-env-environment)) + ,@outer-decls + (symbol-macrolet ((pv-env-environment default)) + (fast-lexical-method-functions + (,bind-list .next-method-call. ,req-args ,rest-arg + ,@(cdddr lmf-params)) + ,@inner-decls + ,@body-sans-decls)))) + (mf (%make-method-function fmf nil))) + (set-funcallable-instance-function + mf (method-function-from-fast-function fmf ',(getf initargs 'plist))) + mf) + ',initargs))))) ;;; Use arrays and hash tables and the fngen stuff to make this much ;;; better. It doesn't really matter, though, because a function @@ -1069,11 +1065,7 @@ (method-function nm) nm) :call-method-args (list nms))))) - (if restp - (let* ((rest (nthcdr nreq method-args)) - (args (ldiff method-args rest))) - (apply fmf pv-cell nmc (nconc args (list rest)))) - (apply fmf pv-cell nmc method-args))))) + (apply fmf pv-cell nmc method-args)))) ;; FIXME: this looks dangerous. (let* ((fname (%fun-name fmf))) (when (and fname (eq (car fname) 'fast-method)) diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index 0bef77f..6887485 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -1400,5 +1400,126 @@ (make-instance 'listoid :cdroid (make-instance 'listoid)))) 3))) + + + +;;;; Tests for argument parsing in fast-method-functions. + +(defvar *foo* 0) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (setf (symbol-value 'a) 'invalid)) + +(defmacro test1 (lambda-list values args &key declarations cnm) + `(progn + (fmakunbound 'll-method) + (fmakunbound 'll-function) + (defmethod ll-method ,lambda-list + ,@declarations + ,@(when cnm + `((when nil (call-next-method)))) + (list ,@values)) + (defun ll-function ,lambda-list + ,@declarations + (list ,@values)) + (dotimes (i 2) + (assert (equal (ll-method ,@args) + (ll-function ,@args)))))) + +(defmacro test (&rest args) + `(progn + (test1 ,@args :cnm nil) + (test1 ,@args :cnm t))) + +;; Just plain arguments + +(test (a) (a) (1)) +(test (a b c d e f g h i) (a b c d e f g h i) (1 2 3 4 5 6 7 8 9)) + +(test (*foo*) (*foo* (symbol-value '*foo*)) (1)) + +(test (a) (a (symbol-value 'a)) (1) + :declarations ((declare (special a)))) + +;; Optionals + +(test (a &optional b c) (a b c) (1)) +(test (a &optional b c) (a b c) (1 2)) +(test (a &optional b c) (a b c) (1 2 3)) + +(test (a &optional (b 'b b-p) (c 'c c-p)) (a b c b-p c-p) (1)) +(test (a &optional (b 'b b-p) (c 'c c-p)) (a b c b-p c-p) (1 2)) +(test (a &optional (b 'b b-p) (c 'c c-p)) (a b c b-p c-p) (1 2 3)) + +(test (&optional *foo*) (*foo* (symbol-value '*foo*)) ()) +(test (&optional *foo*) (*foo* (symbol-value '*foo*)) (1)) + +(test (&optional (*foo* 'z foo-p)) (*foo* (symbol-value '*foo*) foo-p) ()) +(test (&optional (*foo* 'z foo-p)) (*foo* (symbol-value '*foo*) foo-p) (1)) + +(test (&optional a) (a (symbol-value 'a)) () + :declarations ((declare (special a)))) +(test (&optional a) (a (symbol-value 'a)) (1) + :declarations ((declare (special a)))) + +(test (&optional (a 'z a-p)) (a (symbol-value 'a) a-p) () + :declarations ((declare (special a)))) +(test (&optional (a 'z a-p)) (a (symbol-value 'a) a-p) (1) + :declarations ((declare (special a)))) + +(defparameter *count* 0) + +(test (&optional (a (incf *count*)) (b (incf *count*))) + (a b *count* (setf *count* 0)) + ()) + +;; Keywords with some &RESTs thrown in + +(dolist (args '((1) + (1 :b 2) + (1 :c 3) + (1 :b 2 :c 3) + (1 :c 3 :b 2) + (1 :c 3 :c 1 :b 2 :b 4))) + (eval `(test (a &key b c) (a b c) ,args)) + (eval `(test (a &key (b 'b b-p) (c 'c c-p)) + (a b c b-p c-p) + ,args)) + (eval `(test (a &rest rest &key (b 'b b-p) (c 'c c-p)) + (a b c b-p c-p rest) + ,args)) + (eval `(test (a &rest *foo* &key (b 'b b-p) (c 'c c-p)) + (a b c b-p c-p *foo* (symbol-value '*foo*)) + ,args)) + (eval `(test (a &rest *foo* &key (b 'b b-p) (c 'c c-p)) + (a b c b-p c-p *foo* (symbol-value '*foo*)) + ,args + :declarations ((declare (special b-p)))))) + +(dolist (args '(() + (:*foo* 1) + (:*foo* 1 :*foo* 2))) + (eval `(test (&key *foo*) (*foo* (symbol-value '*foo*)) ,args)) + (eval `(test (&key (*foo* 'z foo-p)) (*foo* (symbol-value '*foo*) foo-p) + ,args)) + (eval `(test (&key ((:*foo* a) 'z foo-p)) (a (symbol-value 'a) foo-p) + ,args)) + (eval `(test (&key ((:*foo* a) 'z foo-p)) (a (symbol-value 'a) foo-p) + ,args + :declarations ((declare (special a)))))) + +(defparameter *count* 0) + +(test (&key (a (incf *count*)) (b (incf *count*))) + (a b *count* (setf *count* 0)) + ()) + +(test (&key a b &allow-other-keys) (a b) (:a 1 :b 2 :c 3)) + +(defmethod clim-style-lambda-list-test (a b &optional c d &key x y) + (list a b c d x y)) + +(clim-style-lambda-list-test 1 2) + ;;;; success diff --git a/version.lisp-expr b/version.lisp-expr index f5cabe0..009bd43 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".) -"0.9.18.47" +"0.9.18.48" -- 1.7.10.4