From: Juho Snellman Date: Sat, 13 May 2006 19:48:17 +0000 (+0000) Subject: 0.9.12.20: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=fcbf5a7338a1600a6a05bc8be7b42be43505d1dc;p=sbcl.git 0.9.12.20: Get rid of the PCL method-lambda macrolets completely (see also 0.9.12.6). * Replace PV-ENV with a global macro that switches its behaviour based on the environment where it's expanded. * The macrolets created by BIND-*-LEXICAL-METHOD-MACROS were only used by BIND-LEXICAL-METHOD-FUNCTIONS. Merge them into a BIND-*-LEXICAL-METHOD-FUNCTIONS without the macrolets. Also remove some dead code in the macros (I'm sure it made sense 15 years ago). --- diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 50355bb..5d4f940 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -727,7 +727,7 @@ bootstrapping. (return nil)))))) (multiple-value-bind (walked-lambda call-next-method-p closurep - next-method-p-p setq-p pv-env-p) + next-method-p-p setq-p) (walk-method-lambda method-lambda required-parameters env @@ -751,7 +751,6 @@ bootstrapping. `(: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 @@ -779,7 +778,6 @@ bootstrapping. ;; give to FIND-METHOD. :method-name-declaration ,name-decl :closurep ,closurep - :pv-env-p ,pv-env-p :applyp ,applyp) ,@walked-declarations ,@walked-lambda-body)) @@ -799,10 +797,10 @@ bootstrapping. &body body) `(progn ,method-args ,next-methods - (bind-simple-lexical-method-macros (,method-args ,next-methods ,@lmf-options) - (bind-lexical-method-functions (,@lmf-options) + (bind-simple-lexical-method-functions (,method-args ,next-methods + ,lmf-options) (bind-args (,lambda-list ,method-args) - ,@body))))) + ,@body)))) (defmacro fast-lexical-method-functions ((lambda-list next-method-call @@ -810,56 +808,42 @@ bootstrapping. rest-arg &rest lmf-options) &body body) - `(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 - &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))))) + `(bind-fast-lexical-method-functions (,args ,rest-arg ,next-method-call ,lmf-options) + (bind-args (,(nthcdr (length args) lambda-list) ,rest-arg) + ,@body))) + +(defmacro bind-simple-lexical-method-functions + ((method-args next-methods (&key call-next-method-p next-method-p-p setq-p + closurep applyp method-name-declaration)) + &body body + &environment env) + (if (not (or call-next-method-p setq-p closurep next-method-p-p applyp)) + `(locally + ,@body) + `(let ((.next-method. (car ,next-methods)) + (,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-name-declaration)) + 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-name-declaration + (or cnm-args ,method-args)))))) + ,@(and next-method-p-p + '((next-method-p () + (not (null .next-method.)))))) + ,@body)))) (defun call-no-next-method (method-name-declaration &rest args) (destructuring-bind (name) method-name-declaration @@ -1087,138 +1071,87 @@ bootstrapping. (function (apply emf args)))) -(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) + +(defmacro fast-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 slot accessor). But as far as I (WHN + ;; 2002-06-11) can tell, it's impossible for such a representation + ;; to end up as .NEXT-METHOD-CALL. By reassuring INVOKE-E-M-F that + ;; when called from this context 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)) + +(defmacro fast-call-next-method-body ((args next-method-call rest-arg) + method-name-declaration + cnm-args) + `(if ,next-method-call + ,(let ((call `(invoke-effective-method-function + (fast-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)) + (call-no-next-method ',method-name-declaration + ,@args + ,@(when rest-arg + `(,rest-arg))))) + +(defmacro bind-fast-lexical-method-functions + ((args rest-arg next-method-call (&key + call-next-method-p + setq-p + method-name-declaration + next-method-p-p + closurep + applyp)) &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))) - (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 - ;; slot accessor). But as far as I (WHN 2002-06-11) - ;; can tell, it's impossible for such a representation - ;; to end up as .NEXT-METHOD-CALL. By reassuring - ;; INVOKE-E-M-F that when called from this context - ;; 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))) - (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 + (let* ((all-params (append args (when rest-arg (list rest-arg)))) + (rebindings (when (or setq-p call-next-method-p) + (mapcar (lambda (x) (list x x)) all-params)))) + (if (not (or call-next-method-p setq-p closurep next-method-p-p applyp)) + `(locally + ,@body) + `(flet (,@(when call-next-method-p + `((call-next-method (&rest cnm-args) + (declare (muffle-conditions code-deletion-note)) + ,@(if (safe-code-p env) + `((%check-cnm-args cnm-args (list ,@args) + ',method-name-declaration)) + nil) + (fast-call-next-method-body (,args + ,next-method-call + ,rest-arg) + ,method-name-declaration + cnm-args)))) + ,@(when next-method-p-p + `((next-method-p () - `(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) + (not (null ,next-method-call)))))) + (let ,rebindings + ,@(when rebindings `((declare (ignorable ,@all-params)))) ,@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 - ((&rest lmf-options - &key call-next-method-p next-method-p-p setq-p - closurep applyp method-name-declaration pv-env-p) - &body body) - (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 - (flet (,@(and call-next-method-p - `((call-next-method (&rest cnm-args) - (check-cnm-args-body ,method-name-declaration cnm-args) - (call-next-method-body ,method-name-declaration cnm-args)))) - ,@(and next-method-p-p - '((next-method-p () - (next-method-p-body))))) - (with-rebound-original-args (,call-next-method-p ,setq-p) - ,@body)))))) - ;;; CMUCL comment (Gerd Moellmann): ;;; ;;; The standard says it's an error if CALL-NEXT-METHOD is called with @@ -1338,7 +1271,6 @@ bootstrapping. ; 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) @@ -1365,9 +1297,6 @@ bootstrapping. ;; 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) @@ -1405,8 +1334,7 @@ bootstrapping. call-next-method-p closurep next-method-p-p - setq-p - pv-env-p))))) + setq-p))))) (defun generic-function-name-p (name) (and (legal-fun-name-p name) diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index 47e4c9c..3787318 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -912,20 +912,32 @@ (declare (ignorable ,@(mapcar #'identity slot-vars))) ,@body))) -;;; This gets used only when the default MAKE-METHOD-LAMBDA is +;;; This will only be visible in PV-ENV when the default MAKE-METHOD-LAMBDA is ;;; overridden. -(defmacro pv-env ((pv calls pv-table-symbol pv-parameters) +(define-symbol-macro pv-env-environment overridden) + +(defmacro pv-env (&environment env + (pv calls pv-table-symbol pv-parameters) &rest forms) - `(let* ((.pv-table. ,pv-table-symbol) - (.pv-cell. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters)) - (,pv (car .pv-cell.)) - (,calls (cdr .pv-cell.))) - (declare ,(make-pv-type-declaration pv)) - (declare ,(make-calls-type-declaration calls)) - ,@(when (symbolp pv-table-symbol) - `((declare (special ,pv-table-symbol)))) - ,pv ,calls - ,@forms)) + ;; Decide which expansion to use based on the state of the PV-ENV-ENVIRONMENT + ;; symbol-macrolet. + (if (eq (macroexpand 'pv-env-environment env) 'default) + `(let ((,pv (car .pv-cell.)) + (,calls (cdr .pv-cell.))) + (declare ,(make-pv-type-declaration pv) + ,(make-calls-type-declaration calls)) + ,pv ,calls + ,@forms) + `(let* ((.pv-table. ,pv-table-symbol) + (.pv-cell. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters)) + (,pv (car .pv-cell.)) + (,calls (cdr .pv-cell.))) + (declare ,(make-pv-type-declaration pv)) + (declare ,(make-calls-type-declaration calls)) + ,@(when (symbolp pv-table-symbol) + `((declare (special ,pv-table-symbol)))) + ,pv ,calls + ,@forms))) (defvar *non-var-declarations* ;; FIXME: VALUES was in this list, conditionalized with #+CMU, but I @@ -1099,27 +1111,10 @@ (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.)) + (declare (ignorable .pv-cell. .next-method-call.) + (disable-package-locks pv-env-environment)) ,@outer-decls - (declare (disable-package-locks pv-env)) - (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)) + (symbol-macrolet ((pv-env-environment default)) (fast-lexical-method-functions (,(car lmf-params) .next-method-call. ,req-args ,rest-arg ,@(cdddr lmf-params)) diff --git a/version.lisp-expr b/version.lisp-expr index 7c6e98a..b9acc85 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.12.19" +"0.9.12.20"