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
(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.
#-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))
(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
;; 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
;;; 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))
`(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))
(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)))
,(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
(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)))))))
(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))))))))
(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))
`(,(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))
+
\f
(defmacro with-local-cache-functions ((cache) &body body)
`(let ((.cache. ,cache))
(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.))
,(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))))
(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 "~@<invalid keyword argument~P: ~
+ (i start))
+ (declare (type index i more-count)
+ (optimize speed))
+ (flet ((current-value ()
+ (sb-c::%more-arg more-context i)))
+ (declare (inline current-value))
+ (collect ((invalid))
+ (loop
+ (when (>= i more-count)
+ (when (and (invalid) (not allow-other-keys))
+ (error 'simple-program-error
+ :format-control "~@<invalid keyword argument~P: ~
~{~S~^, ~} (valid keys are ~{~S~^, ~}).~@:>"
- :format-arguments (list (length (invalid)) (invalid) valid-keys)))
- (return))
- (let ((key (pop args)))
- (cond
- ((not (symbolp key))
- (error 'simple-program-error
- :format-control "~@<keyword argument not a symbol: ~S.~@:>"
- :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 "~@<keyword argument not a symbol: ~S.~@:>"
+ :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))))))
\f
;;;; the STANDARD method combination type. This is coded by hand
;;;; (rather than with DEFINE-METHOD-COMBINATION) for bootstrapping
(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))
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*
(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))))))
(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)
;; 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))))
`(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)
(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
(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))
(make-instance 'listoid :cdroid
(make-instance 'listoid))))
3)))
+
+\f
+
+;;;; 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)
+
\f
;;;; success
;;; 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"
projects / sbcl.git / commitdiff