Menu
▾
▴
[Sbcl-commits] CVS: sbcl/src/pcl boot.lisp,1.109,1.110 vector.lisp,1.37,1.38
|
From: Juho S. <js...@us...> - 2006-05-06 22:40:41
|
Update of /cvsroot/sbcl/sbcl/src/pcl In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv18718/src/pcl Modified Files: boot.lisp vector.lisp Log Message: 0.9.12.6: Speed up CLOS compilation. (For example, 45% speedup for compiling asdf.lisp, 30% for compiling McCLIM on x86-64). The code generated by PCL in MAKE-METHOD-LAMBDA has lots of macrolets, which for the most part are never expanded. Modify it to only create the macrolets that are really used in the body, so that the useless local macro-functions don't need to be compiled. You might wonder why this is done in PCL, rather than as a general purpose compiler change by lazily compiling the definitions when they're first expanded. I tried that first, and while it worked, the end result was rather messy. Since users can access the macro-functions through the environment, we need to minimally compile them to be ansixly correct, and we don't really have much useful minimal compilation infrastructure for at the moment. Ensuring that the source of the macro-functions is stored properly, e.g. for (MACROLET ((FOO ...)) (DECLAIM (INLINE BAR)) (DEFUN BAR () (FOO))) is also somewhat tricky. Index: boot.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/boot.lisp,v retrieving revision 1.109 retrieving revision 1.110 diff -u -d -r1.109 -r1.110 --- boot.lisp 27 Feb 2006 13:12:35 -0000 1.109 +++ boot.lisp 6 May 2006 22:40:31 -0000 1.110 @@ -727,7 +727,7 @@ (return nil)))))) (multiple-value-bind (walked-lambda call-next-method-p closurep - next-method-p-p setq-p) + next-method-p-p setq-p pv-env-p) (walk-method-lambda method-lambda required-parameters env @@ -746,45 +746,47 @@ (let ((pv-table-symbol (make-symbol "pv-table"))) (setq plist `(,@(when slot-name-lists - `(:slot-name-lists ,slot-name-lists)) + `(:slot-name-lists ,slot-name-lists)) ,@(when call-list - `(:call-list ,call-list)) + `(:call-list ,call-list)) :pv-table-symbol ,pv-table-symbol ,@plist)) + (setq pv-env-p t) (setq walked-lambda-body `((pv-binding (,required-parameters ,slot-name-lists ,pv-table-symbol) - ,@walked-lambda-body)))))) + ,@walked-lambda-body)))))) (when (and (memq '&key lambda-list) (not (memq '&allow-other-keys lambda-list))) (let ((aux (memq '&aux lambda-list))) - (setq lambda-list (nconc (ldiff lambda-list aux) - (list '&allow-other-keys) - aux)))) + (setq lambda-list (nconc (ldiff lambda-list aux) + (list '&allow-other-keys) + aux)))) (values `(lambda (.method-args. .next-methods.) (simple-lexical-method-functions - (,lambda-list .method-args. .next-methods. - :call-next-method-p - ,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 - :closurep ,closurep - :applyp ,applyp) - ,@walked-declarations - ,@walked-lambda-body)) + (,lambda-list .method-args. .next-methods. + :call-next-method-p + ,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 + :closurep ,closurep + :pv-env-p ,pv-env-p + :applyp ,applyp) + ,@walked-declarations + ,@walked-lambda-body)) `(,@(when plist - `(:plist ,plist)) + `(:plist ,plist)) ,@(when documentation - `(:documentation ,documentation))))))))))) + `(:documentation ,documentation))))))))))) (unless (fboundp 'make-method-lambda) (setf (gdefinition 'make-method-lambda) @@ -797,7 +799,7 @@ &body body) `(progn ,method-args ,next-methods - (bind-simple-lexical-method-macros (,method-args ,next-methods) + (bind-simple-lexical-method-macros (,method-args ,next-methods ,@lmf-options) (bind-lexical-method-functions (,@lmf-options) (bind-args (,lambda-list ,method-args) ,@body))))) @@ -808,38 +810,56 @@ rest-arg &rest lmf-options) &body body) - `(bind-fast-lexical-method-macros (,args ,rest-arg ,next-method-call) + `(bind-fast-lexical-method-macros (,args ,rest-arg ,next-method-call ,@lmf-options) (bind-lexical-method-functions (,@lmf-options) (bind-args (,(nthcdr (length args) lambda-list) ,rest-arg) ,@body)))) -(defmacro bind-simple-lexical-method-macros ((method-args next-methods) - &body body) - `(macrolet ((call-next-method-bind (&body body) - `(let ((.next-method. (car ,',next-methods)) - (,',next-methods (cdr ,',next-methods))) - .next-method. ,',next-methods - ,@body)) - (check-cnm-args-body (&environment env method-name-declaration cnm-args) - (if (safe-code-p env) - `(%check-cnm-args ,cnm-args ,',method-args ',method-name-declaration) - nil)) - (call-next-method-body (method-name-declaration cnm-args) - `(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-name-declaration - (or ,cnm-args ,',method-args)))) - (next-method-p-body () - `(not (null .next-method.))) - (with-rebound-original-args ((call-next-method-p setq-p) - &body body) - (declare (ignore call-next-method-p setq-p)) - `(let () ,@body))) - ,@body)) +(defmacro bind-simple-lexical-method-macros + ((method-args next-methods + &rest lmf-options + &key call-next-method-p next-method-p-p &allow-other-keys) + &body body) + (let* ((create-cnm-macros (apply #'create-call-next-method-macros-p + lmf-options))) + (if (not create-cnm-macros) + `(locally ,@body) + (let ((bind `(call-next-method-bind + (&body body) + `(let ((.next-method. (car ,',next-methods)) + (,',next-methods (cdr ,',next-methods))) + .next-method. ,',next-methods + ,@body))) + (check `(check-cnm-args-body + (&environment env method-name-declaration cnm-args) + (if (safe-code-p env) + `(%check-cnm-args ,cnm-args + ,',method-args + ',method-name-declaration) + nil))) + (call-body `(call-next-method-body + (method-name-declaration cnm-args) + `(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-name-declaration + (or ,cnm-args ,',method-args))))) + (next-body `(next-method-p-body + () + `(not (null .next-method.)))) + (with-args `(with-rebound-original-args + ((call-next-method-p setq-p) &body body) + (declare (ignore call-next-method-p setq-p)) + `(let () ,@body)))) + `(macrolet (,@(when call-next-method-p (list check call-body)) + ,@(when next-method-p-p (list next-body)) + ,bind + ,with-args) + ,@body))))) (defun call-no-next-method (method-name-declaration &rest args) (destructuring-bind (name) method-name-declaration @@ -1067,12 +1087,20 @@ (function (apply emf args)))) -(defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call) - &body body - &environment env) - (let* ((all-params (append args (when rest-arg (list rest-arg)))) +(defmacro bind-fast-lexical-method-macros + ((args rest-arg next-method-call + &rest lmf-options + &key call-next-method-p next-method-p-p &allow-other-keys) + &body body + &environment env) + (let* ((create-cnm-macros (apply #'create-call-next-method-macros-p + lmf-options)) + (all-params (append args (when rest-arg (list rest-arg)))) (rebindings (mapcar (lambda (x) (list x x)) all-params))) - `(macrolet ((narrowed-emf (emf) + (if (not create-cnm-macros) + `(locally ,@body) + (let ((narrowed-emf + `(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 @@ -1083,85 +1111,101 @@ ;; 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)) - (call-next-method-bind (&body body) - `(let () ,@body)) - (check-cnm-args-body (&environment env method-name-declaration cnm-args) - (if (safe-code-p env) - `(%check-cnm-args ,cnm-args (list ,@',args) - ',method-name-declaration) - nil)) - (call-next-method-body (method-name-declaration cnm-args) - `(if ,',next-method-call - ,(locally - ;; This declaration suppresses a "deleting - ;; unreachable code" note for the following IF - ;; when REST-ARG is NIL. It is not nice for - ;; debugging SBCL itself, but at least it - ;; keeps us from annoying users. - (declare (optimize (inhibit-warnings 3))) - (if (and (null ',rest-arg) - (consp cnm-args) - (eq (car cnm-args) 'list)) - `(invoke-effective-method-function - (narrowed-emf ,',next-method-call) - nil - ,@(cdr cnm-args)) - (let ((call `(invoke-effective-method-function - (narrowed-emf ,',next-method-call) - ,',(not (null rest-arg)) - ,@',args - ,@',(when rest-arg `(,rest-arg))))) - `(if ,cnm-args - (bind-args ((,@',args - ,@',(when rest-arg - `(&rest ,rest-arg))) - ,cnm-args) - ,call) - ,call)))) - ,(locally - ;; As above, this declaration suppresses code - ;; deletion notes. - (declare (optimize (inhibit-warnings 3))) - (if (and (null ',rest-arg) - (consp cnm-args) - (eq (car cnm-args) 'list)) - `(call-no-next-method ',method-name-declaration - ,@(cdr cnm-args)) - `(call-no-next-method ',method-name-declaration - ,@',args - ,@',(when rest-arg - `(,rest-arg))))))) - (next-method-p-body () - `(not (null ,',next-method-call))) - (with-rebound-original-args ((cnm-p setq-p) &body body) - (if (or cnm-p setq-p) - `(let ,',rebindings - (declare (ignorable ,@',all-params)) - ,@body) - `(let () ,@body)))) - ,@body))) + ;; 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))) + (bind `(call-next-method-bind + (&body body) + `(let () ,@body))) + (check `(check-cnm-args-body + (&environment env method-name-declaration cnm-args) + (if (safe-code-p env) + `(%check-cnm-args ,cnm-args (list ,@',args) + ',method-name-declaration) + nil))) + (call-body `(call-next-method-body + (method-name-declaration cnm-args) + `(if ,',next-method-call + ,(locally + ;; This declaration suppresses a "deleting + ;; unreachable code" note for the following IF + ;; when REST-ARG is NIL. It is not nice for + ;; debugging SBCL itself, but at least it + ;; keeps us from annoying users. + (declare (optimize (inhibit-warnings 3))) + (if (and (null ',rest-arg) + (consp cnm-args) + (eq (car cnm-args) 'list)) + `(invoke-effective-method-function + (narrowed-emf ,',next-method-call) + nil + ,@(cdr cnm-args)) + (let ((call `(invoke-effective-method-function + (narrowed-emf ,',next-method-call) + ,',(not (null rest-arg)) + ,@',args + ,@',(when rest-arg `(,rest-arg))))) + `(if ,cnm-args + (bind-args ((,@',args + ,@',(when rest-arg + `(&rest ,rest-arg))) + ,cnm-args) + ,call) + ,call)))) + ,(locally + ;; As above, this declaration suppresses code + ;; deletion notes. + (declare (optimize (inhibit-warnings 3))) + (if (and (null ',rest-arg) + (consp cnm-args) + (eq (car cnm-args) 'list)) + `(call-no-next-method ',method-name-declaration + ,@(cdr cnm-args)) + `(call-no-next-method ',method-name-declaration + ,@',args + ,@',(when rest-arg + `(,rest-arg)))))))) + (next-body `(next-method-p-body + () + `(not (null ,',next-method-call)))) + (with-args + `(with-rebound-original-args ((cnm-p setq-p) &body body) + (if (or cnm-p setq-p) + `(let ,',rebindings + (declare (ignorable ,@',all-params)) + ,@body) + `(let () ,@body))))) + `(macrolet (,@(when call-next-method-p (list narrowed-emf check call-body)) + ,@(when next-method-p-p (list next-body)) + ,bind + ,with-args) + ,@body))))) + +(defun create-call-next-method-macros-p (&key call-next-method-p + next-method-p-p setq-p + closurep applyp + &allow-other-keys) + (or call-next-method-p next-method-p-p closurep applyp setq-p)) (defmacro bind-lexical-method-functions - ((&key call-next-method-p next-method-p-p setq-p - closurep applyp method-name-declaration) + ((&rest lmf-options + &key call-next-method-p next-method-p-p setq-p + closurep applyp method-name-declaration pv-env-p) &body body) - (cond ((and (null call-next-method-p) (null next-method-p-p) - (null closurep) (null applyp) (null setq-p)) + (declare (ignore closurep applyp pv-env-p)) + (cond ((not (apply #'create-call-next-method-macros-p lmf-options)) `(let () ,@body)) (t `(call-next-method-bind @@ -1294,6 +1338,7 @@ ; 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 + (pv-env-p nil) (setq-p nil)) (flet ((walk-function (form context env) (cond ((not (eq context :eval)) form) @@ -1320,6 +1365,9 @@ ;; should be all. -- CSR, 2004-07-01 (setq setq-p t) form) + ((eq (car form) 'pv-binding1) + (setq pv-env-p t) + form) ((and (eq (car form) 'function) (cond ((eq (cadr form) 'call-next-method) (setq call-next-method-p t) @@ -1357,7 +1405,8 @@ call-next-method-p closurep next-method-p-p - setq-p))))) + setq-p + pv-env-p))))) (defun generic-function-name-p (name) (and (legal-fun-name-p name) Index: vector.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/vector.lisp,v retrieving revision 1.37 retrieving revision 1.38 diff -u -d -r1.37 -r1.38 --- vector.lisp 27 Feb 2006 13:12:35 -0000 1.37 +++ vector.lisp 6 May 2006 22:40:31 -0000 1.38 @@ -1102,21 +1102,27 @@ (declare (ignorable .pv-cell. .next-method-call.)) ,@outer-decls (declare (disable-package-locks pv-env)) - (macrolet ((pv-env ((pv calls pv-table-symbol pv-parameters) - &rest forms) - (declare (ignore pv-table-symbol - pv-parameters)) - (declare (enable-package-locks pv-env)) - `(let ((,pv (car .pv-cell.)) - (,calls (cdr .pv-cell.))) - (declare ,(make-pv-type-declaration pv) - ,(make-calls-type-declaration calls)) - ,pv ,calls - ,@forms))) - (declare (enable-package-locks pv-env)) - (fast-lexical-method-functions - (,(car lmf-params) .next-method-call. ,req-args ,rest-arg - ,@(cdddr lmf-params)) + (macrolet (;; If :PV-TABLE-SYMBOL isn't in the plist, the PV-ENV + ;; macro defined here will never get expanded. To + ;; speed up compilation of CLOS code, don't emit it + ;; in the first place. + ,@(when (getf (cdr lmf-params) :pv-env-p) + `((pv-env + ((pv calls pv-table-symbol pv-parameters) + &rest forms) + (declare (ignore pv-table-symbol + pv-parameters)) + (declare (enable-package-locks pv-env)) + `(let ((,pv (car .pv-cell.)) + (,calls (cdr .pv-cell.))) + (declare ,(make-pv-type-declaration pv) + ,(make-calls-type-declaration calls)) + ,pv ,calls + ,@forms))))) + (declare (enable-package-locks pv-env)) + (fast-lexical-method-functions + (,(car lmf-params) .next-method-call. ,req-args ,rest-arg + ,@(cdddr lmf-params)) ,@inner-decls ,@body-sans-decls))) ',initargs)))) |