From 54d68c83743a837b59bf2f335f6261de8b0b1337 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Tue, 24 May 2011 10:09:18 +0000 Subject: [PATCH] 1.0.48.23: faster with-arguments CALL-NEXT-METHOD * Make the correctness-checking code for changed arguments in safe code check required arguments pairwise with EQL first -- if they match, the applicable methods must be the same and we can elide the expensive computation. This makes things like (apply #'call-next-method r1 r2 :foo foo rest) not suck horribly in safe code. Could still be better, but this much was quick and easy. * Make the &REST list in CALL-NEXT-METHOD dynamic-extent. This helps normal safety code as well. --- src/pcl/boot.lisp | 105 ++++++++++++++++++++++++++++++++--------------------- version.lisp-expr | 2 +- 2 files changed, 65 insertions(+), 42 deletions(-) diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index c1b3f69..1b573bc 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -956,25 +956,25 @@ bootstrapping. (,next-methods (cdr ,next-methods))) (declare (ignorable .next-method. ,next-methods)) (flet (,@(and call-next-method-p - `((call-next-method - (&rest cnm-args) - ,@(if (safe-code-p env) - `((%check-cnm-args cnm-args - ,method-args - ',method-cell)) - nil) - (if .next-method. - (funcall (if (std-instance-p .next-method.) - (method-function .next-method.) - .next-method.) ; for early methods - (or cnm-args ,method-args) - ,next-methods) - (apply #'call-no-next-method - ',method-cell - (or cnm-args ,method-args)))))) + `((call-next-method (&rest cnm-args) + (declare (dynamic-extent cnm-args)) + ,@(if (safe-code-p env) + `((%check-cnm-args cnm-args + ,method-args + ',method-cell)) + nil) + (if .next-method. + (funcall (if (std-instance-p .next-method.) + (method-function .next-method.) + .next-method.) ; for early methods + (or cnm-args ,method-args) + ,next-methods) + (apply #'call-no-next-method + ',method-cell + (or cnm-args ,method-args)))))) ,@(and next-method-p-p - '((next-method-p () - (not (null .next-method.)))))) + '((next-method-p () + (not (null .next-method.)))))) ,@body)))) (defun call-no-next-method (method-cell &rest args) @@ -1311,22 +1311,23 @@ bootstrapping. `(locally ,@body) `(flet (,@(when call-next-method-p - `((call-next-method (&rest cnm-args) - (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-cell)) - nil) - (fast-call-next-method-body (,args - ,next-method-call - ,rest-arg) + `((call-next-method (&rest cnm-args) + (declare (dynamic-extent cnm-args) + (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-cell)) + nil) + (fast-call-next-method-body (,args + ,next-method-call + ,rest-arg) ,method-cell cnm-args)))) - ,@(when next-method-p-p - `((next-method-p () - (declare (optimize (sb-c:insert-step-conditions 0))) - (not (null ,next-method-call)))))) + ,@(when next-method-p-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)))) ,@body))))) @@ -1347,17 +1348,31 @@ bootstrapping. ;;; 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-cell) + ;; 1. Check for no arguments. (when cnm-args (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) - (error "~@" - nmethods (length cnm-args) cnm-args omethods - (length orig-args) orig-args))))) + (nreq (generic-function-nreq gf))) + (declare (fixnum nreq)) + ;; 2. Requirement arguments pairwise: if all are EQL, the applicable + ;; methods must be the same. This takes care of the relatively common + ;; case of twiddling with &KEY arguments without being horribly + ;; expensive. + (unless (do ((orig orig-args (cdr orig)) + (args cnm-args (cdr args)) + (n nreq (1- nreq))) + ((zerop n) t) + (unless (and orig args (eql (car orig) (car args))) + (return nil))) + ;; 3. Only then do the full check. + (let ((omethods (compute-applicable-methods gf orig-args)) + (nmethods (compute-applicable-methods gf cnm-args))) + (unless (equal omethods nmethods) + (error "~@" + nmethods (length cnm-args) cnm-args omethods + (length orig-args) orig-args))))))) (defmacro bind-args ((lambda-list args) &body body) (let ((args-tail '.args-tail.) @@ -2298,6 +2313,14 @@ bootstrapping. nkeys arg-info)))) +(defun generic-function-nreq (gf) + (let* ((arg-info (if (early-gf-p gf) + (early-gf-arg-info gf) + (safe-gf-arg-info gf))) + (metatypes (arg-info-metatypes arg-info))) + (declare (list metatypes)) + (length metatypes))) + (defun early-make-a-method (class qualifiers arglist specializers initargs doc &key slot-name object-class method-class-function definition-source) diff --git a/version.lisp-expr b/version.lisp-expr index f2015d0..990a447 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -20,4 +20,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.48.22" +"1.0.48.23" -- 1.7.10.4