[armedbear-cvs] r14052 - trunk/abcl/src/org/armedbear/lisp
ehuelsmann at common-lisp.net
ehuelsmann at common-lisp.net
Sat Aug 4 12:56:30 UTC 2012
Author: ehuelsmann
Date: Sat Aug 4 05:56:29 2012
New Revision: 14052
Log:
Integrate WITH-ARGS-LAMBDA-LIST in COMPUTE-METHOD-TYPE-LAMBDA
for me to understand what's going on and to open up performance
improvement opportunities in the near future.
Modified:
trunk/abcl/src/org/armedbear/lisp/clos.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Aug 4 04:41:58 2012 (r14051)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Aug 4 05:56:29 2012 (r14052)
@@ -1200,36 +1200,6 @@
(process-next-method-list next-method-list))))))
,emf-form))
-(defmacro with-args-lambda-list (args-lambda-list
- generic-function-symbol
- gf-args-symbol
- &body forms)
- (let ((gf-lambda-list (gensym))
- (nrequired (gensym))
- (noptional (gensym))
- (rest-args (gensym)))
- (multiple-value-bind (whole required optional rest keys aux)
- (parse-define-method-combination-args-lambda-list args-lambda-list)
- `(let* ((,gf-lambda-list (slot-value ,generic-function-symbol 'sys::lambda-list))
- (,nrequired (length (extract-required-part ,gf-lambda-list)))
- (,noptional (length (extract-optional-part ,gf-lambda-list)))
- (,rest-args (subseq ,gf-args-symbol (+ ,nrequired ,noptional)))
- ,@(when whole `((,whole ,gf-args-symbol)))
- ,@(loop for var in required and i upfrom 0
- collect `(,var (when (< ,i ,nrequired)
- (nth ,i ,gf-args-symbol))))
- ,@(loop for (var init-form) in optional and i upfrom 0
- collect
- `(,var (if (< ,i ,noptional)
- (nth (+ ,nrequired ,i) ,gf-args-symbol)
- ,init-form)))
- ,@(when rest `((,rest ,rest-args)))
- ,@(loop for ((key var) init-form) in keys and i upfrom 0
- collect `(,var (getk ,rest-args ',key ,init-form)))
- ,@(loop for (var init-form) in aux and i upfrom 0
- collect `(,var ,init-form)))
- , at forms))))
-
(defun assert-unambiguous-method-sorting (group-name methods)
(let ((specializers (make-hash-table :test 'equal)))
(dolist (method methods)
@@ -1284,27 +1254,72 @@
method-group-specs declarations forms &allow-other-keys)
(declare (ignore name))
(let ((methods (gensym))
- (args-var (gensym)))
+ (args-var (gensym))
+ (gf-lambda-list (gensym))
+ (emf-form (gensym)))
`(lambda (,generic-function-symbol ,methods , at lambda-list)
+ ;; This is the lambda which computes the effective method
, at declarations
(with-method-groups ,method-group-specs
,methods
,(if (null args-lambda-list)
- `(let ((emf-form (progn , at forms)))
+ `(let ((,emf-form (progn , at forms)))
`(lambda (,',args-var)
+ ;; This is the lambda which *is* the effective method
+ ;; hence gets called on every method invocation
+ ;; be as efficient in this method as we can be
,(wrap-with-call-method-macro ,generic-function-symbol
- ',args-var emf-form)))
- `(lambda (,args-var)
- (let* ((emf-form
- (with-args-lambda-list ,args-lambda-list
- ,generic-function-symbol ,args-var
- , at forms))
- (function
- `(lambda (,',args-var) ;; ugly: we're reusing it
- ;; to prevent calling gensym on every EMF invocation
- ,(wrap-with-call-method-macro ,generic-function-symbol
- ',args-var emf-form))))
- (funcall function ,args-var))))))))
+ ',args-var ,emf-form)))
+ (multiple-value-bind
+ (whole required optional rest keys aux)
+ (parse-define-method-combination-args-lambda-list args-lambda-list)
+ `(let* ((,gf-lambda-list (slot-value ,generic-function-symbol
+ 'sys::lambda-list))
+ (nreq (length (extract-required-part ,gf-lambda-list)))
+ (nopt (length (extract-optional-part ,gf-lambda-list)))
+ (,emf-form
+ (let* (,@(when whole
+ `((,whole ',args-var)))
+ ,@(when rest
+ `((,rest `(subseq ,',args-var
+ (+ ,nreq ,nopt)))))
+ ,@(loop for var in required
+ and i upfrom 0
+ collect `(,var (when (< ,i nreq)
+ `(nth ,,i ,',args-var))))
+ ,@(loop for (var initform) in optional
+ and i upfrom 0
+ ;; check for excess parameters
+ ;; only assign initform if the parameter
+ ;; isn't in excess: the spec says explicitly
+ ;; to bind those in excess to forms evaluating
+ ;; to nil.
+ ;; This leaves initforms to be used with
+ ;; parameters not supplied in excess, but
+ ;; not available arguments list
+ ;;
+ ;; Also, if specified, bind "supplied-p"
+ collect `(,var (if (< ,i nopt)
+ `(nth ,(+ ,i nreq)
+ ,',args-var)
+ ',initform)))
+ ,@(loop for ((key var) initform) in keys
+ ;; Same as optional parameters:
+ ;; even though keywords can't be supplied in
+ ;; excess, we should bind "supplied-p" in case
+ ;; the key isn't supplied in the arguments list
+ collect `(,var `(getk (subseq ,',args-var
+ (+ ,nreq ,nopt)) ,',key
+ ,',initform)))
+ ,@(loop for (var initform) in aux
+ collect `(,var ',initform)))
+ , at forms)))
+ `(lambda (,',args-var)
+ ;; This is the lambda which *is* the effective method
+ ;; hence gets called on every method invocation
+ ;; be as efficient in this method as we can be
+ ,(wrap-with-call-method-macro ,generic-function-symbol
+ ',args-var ,emf-form)))))))))
(defun declarationp (expr)
(and (consp expr) (eq (car expr) 'DECLARE)))
More information about the armedbear-cvs
mailing list