From: Juho Snellman Date: Tue, 19 Sep 2006 23:38:32 +0000 (+0000) Subject: 0.9.16.40: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=447477e72bd4fe54e678a28bdcc4a2802797d6ed;p=sbcl.git 0.9.16.40: Don't do permutation vector optimization for SLOT-VALUE on method parameters that are SETQd [see the test ((:setq :method-parameter) slot-value) in clos.impure.lisp]. * WALK-METHOD-LAMBDA detects parameters whose bindings are modified, and returns them as a list * MAKE-METHOD-LAMBDA-INTERNAL adds a symbol-macrolet %PARAMETER-BINDING-MODIFIED with that list as a value around the method body * OPTIMIZED-SLOT-VALUE and friends no longer directly return the optimized form when the method is being walked, but a macro that expands to either the optimized or unoptimized form, based on %PARAMETER-BINDING-MODIFIED * As a side effect, SETQ-P becomes a little more accurate --- diff --git a/NEWS b/NEWS index a6bcb69..ba9c047 100644 --- a/NEWS +++ b/NEWS @@ -47,6 +47,8 @@ changes in sbcl-0.9.17 (0.9.99?) relative to sbcl-0.9.16: * bug fix: thanks to more lightweight single-stepper instrumentation, code compiled with (DEBUG 3) will compile and execute significantly faster, and will have more accurate type-inferencing than before + * bug fix: SLOT-VALUE optimizations are no longer done on method parameters + whose bindings are modified * improvements to the win32 port (thanks to Yaroslav Kavenchuk): * bug fix: arguments to RUN-PROGRAM are escaped correctly * replace dummy implementations of CL:MACHINE-INSTANCE and diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index f6846d4..3051e17 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -652,6 +652,11 @@ bootstrapping. ((:forthcoming-defclass-type) '(ignorable)))))))) +;;; For passing a list (groveled by the walker) of the required +;;; parameters whose bindings are modified in the method body to the +;;; optimized-slot-value* macros. +(define-symbol-macro %parameter-binding-modified ()) + (defun make-method-lambda-internal (method-lambda &optional env) (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda)) (error "The METHOD-LAMBDA argument to MAKE-METHOD-LAMBDA, ~S, ~ @@ -741,7 +746,8 @@ bootstrapping. (return nil)))))) (multiple-value-bind (walked-lambda call-next-method-p closurep - next-method-p-p setq-p) + next-method-p-p setq-p + parameters-setqd) (walk-method-lambda method-lambda required-parameters env @@ -758,9 +764,9 @@ bootstrapping. (setq plist `(,@(when slot-name-lists `(:slot-name-lists ,slot-name-lists)) - ,@(when call-list - `(:call-list ,call-list)) - ,@plist)) + ,@(when call-list + `(:call-list ,call-list)) + ,@plist)) (setq walked-lambda-body `((pv-binding (,required-parameters ,slot-name-lists @@ -768,7 +774,7 @@ bootstrapping. (intern-pv-table :slot-name-lists ',slot-name-lists :call-list ',call-list))) - ,@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))) @@ -793,7 +799,14 @@ bootstrapping. :closurep ,closurep :applyp ,applyp) ,@walked-declarations - ,@walked-lambda-body)) + (locally + (declare (disable-package-locks + %parameter-binding-modified)) + (symbol-macrolet ((%parameter-binding-modified + ',@parameters-setqd)) + (declare (enable-package-locks + %parameter-binding-modified)) + ,@walked-lambda-body)))) `(,@(when plist `(plist ,plist)) ,@(when documentation @@ -1273,13 +1286,18 @@ bootstrapping. return tail)) (defun walk-method-lambda (method-lambda required-parameters env slots calls) - (let ((call-next-method-p nil) ; flag indicating that CALL-NEXT-METHOD - ; should be in the method definition - (closurep nil) ; flag indicating that #'CALL-NEXT-METHOD - ; 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 - (setq-p nil)) + (let (;; flag indicating that CALL-NEXT-METHOD should be in the + ;; method definition + (call-next-method-p nil) + ;; flag indicating that #'CALL-NEXT-METHOD was seen in the + ;; body of a method + (closurep nil) + ;; flag indicating that NEXT-METHOD-P should be in the method + ;; definition + (next-method-p-p nil) + ;; a list of all required parameters whose bindings might be + ;; modified in the method body. + (parameters-setqd nil)) (flet ((walk-function (form context env) (cond ((not (eq context :eval)) form) ;; FIXME: Jumping to a conclusion from the way it's used @@ -1303,7 +1321,34 @@ bootstrapping. ;; force method doesn't really cost much; a little ;; loss of discrimination over IGNORED variables ;; should be all. -- CSR, 2004-07-01 - (setq setq-p t) + ;; + ;; As of 2006-09-18 modified parameter bindings + ;; are now tracked with more granularity than just + ;; one SETQ-P flag, in order to disable SLOT-VALUE + ;; optimizations for parameters that are SETQd. + ;; The old binary SETQ-P flag is still used for + ;; all other purposes, since as noted above, the + ;; extra cost is minimal. -- JES, 2006-09-18 + ;; + ;; The walker will split (SETQ A 1 B 2) to + ;; separate (SETQ A 1) and (SETQ B 2) forms, so we + ;; only need to handle the simple case of SETQ + ;; here. + (let ((vars (if (eq (car form) 'setq) + (list (second form)) + (second form)))) + (dolist (var vars) + ;; Note that we don't need to check for + ;; %VARIABLE-REBINDING declarations like is + ;; done in CAN-OPTIMIZE-ACCESS1, since the + ;; bindings that will have that declation will + ;; never be SETQd. + (when (var-declaration '%class var env) + ;; If a parameter binding is shadowed by + ;; another binding it won't have a %CLASS + ;; declaration anymore, and this won't get + ;; executed. + (pushnew var parameters-setqd)))) form) ((and (eq (car form) 'function) (cond ((eq (cadr form) 'call-next-method) @@ -1318,9 +1363,9 @@ bootstrapping. ((and (memq (car form) '(slot-value set-slot-value slot-boundp)) (constantp (caddr form))) - (let ((parameter (can-optimize-access form - required-parameters - env))) + (let ((parameter (can-optimize-access form + required-parameters + env))) (let ((fun (ecase (car form) (slot-value #'optimize-slot-value) (set-slot-value #'optimize-set-slot-value) @@ -1342,7 +1387,8 @@ bootstrapping. call-next-method-p closurep next-method-p-p - setq-p))))) + (not (null parameters-setqd)) + parameters-setqd))))) (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 4750fac..902a89e 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -401,55 +401,109 @@ (optimize-slot-value-by-class-p class slot-name type)) (cons parameter-or-nil (or class class-name))))))))) +;;; Check whether the binding of the named variable is modified in the +;;; method body. +(defun parameter-modified-p (parameter-name env) + (let ((modified-variables (macroexpand '%parameter-binding-modified env))) + (memq parameter-name modified-variables))) + (defun optimize-slot-value (slots sparameter form) (if sparameter - (destructuring-bind (ignore1 ignore2 slot-name-form) form - (declare (ignore ignore1 ignore2)) - (let ((slot-name (eval slot-name-form))) - (optimize-instance-access slots :read sparameter slot-name nil))) + (let ((optimized-form + (destructuring-bind (ignore1 ignore2 slot-name-form) form + (declare (ignore ignore1 ignore2)) + (let ((slot-name (eval slot-name-form))) + (optimize-instance-access slots :read sparameter + slot-name nil))))) + ;; We don't return the optimized form directly, since there's + ;; still a chance that we'll find out later on that the + ;; optimization should not have been done, for example due to + ;; the walker encountering a SETQ on SPARAMETER later on in + ;; the body [ see for example clos.impure.lisp test with :name + ;; ((:setq :method-parameter) slot-value)) ]. Instead we defer + ;; the decision until the compiler macroexpands + ;; OPTIMIZED-SLOT-VALUE. + ;; + ;; 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 + `(optimized-slot-value ,form ,(car sparameter) ,optimized-form)) `(accessor-slot-value ,@(cdr form)))) +(defmacro optimized-slot-value (form parameter-name optimized-form + &environment env) + ;; Either use OPTIMIZED-FORM or fall back to the safe + ;; ACCESSOR-SLOT-VALUE. + (if (parameter-modified-p parameter-name env) + `(accessor-slot-value ,@(cdr form)) + optimized-form)) + (defun optimize-set-slot-value (slots sparameter form) (if sparameter - (destructuring-bind (ignore1 ignore2 slot-name-form new-value) form - (declare (ignore ignore1 ignore2)) - (let ((slot-name (eval slot-name-form))) - (optimize-instance-access slots - :write - sparameter - slot-name - new-value))) + (let ((optimized-form + (destructuring-bind (ignore1 ignore2 slot-name-form new-value) form + (declare (ignore ignore1 ignore2)) + (let ((slot-name (eval slot-name-form))) + (optimize-instance-access slots + :write + sparameter + slot-name + new-value))))) + ;; See OPTIMIZE-SLOT-VALUE + `(optimized-set-slot-value ,form ,(car sparameter) ,optimized-form)) `(accessor-set-slot-value ,@(cdr form)))) +(defmacro optimized-set-slot-value (form parameter-name optimized-form + &environment env) + (if (parameter-modified-p parameter-name env) + `(accessor-set-slot-value ,@(cdr form)) + optimized-form)) + (defun optimize-slot-boundp (slots sparameter form) (if sparameter - (destructuring-bind - ;; FIXME: In CMU CL ca. 19991205, this binding list had a - ;; fourth element in it, NEW-VALUE. It's hard to see how - ;; that could possibly be right, since SLOT-BOUNDP has no - ;; NEW-VALUE. Since it was causing a failure in building PCL - ;; for SBCL, so I changed it to match the definition of - ;; SLOT-BOUNDP (and also to match the list used in the - ;; similar OPTIMIZE-SLOT-VALUE, above). However, I'm weirded - ;; out by this, since this is old code which has worked for - ;; ages to build PCL for CMU CL, so it's hard to see why it - ;; should need a patch like this in order to build PCL for - ;; SBCL. I'd like to return to this and find a test case - ;; which exercises this function both in CMU CL, to see - ;; whether it's really a previously-unexercised bug or - ;; whether I've misunderstood something (and, presumably, - ;; patched it wrong). - (slot-boundp-symbol instance slot-name-form) - form - (declare (ignore slot-boundp-symbol instance)) - (let ((slot-name (eval slot-name-form))) - (optimize-instance-access slots - :boundp - sparameter - slot-name - nil))) + (let ((optimized-form + (destructuring-bind + ;; FIXME: In CMU CL ca. 19991205, this binding list + ;; had a fourth element in it, NEW-VALUE. It's hard + ;; to see how that could possibly be right, since + ;; SLOT-BOUNDP has no NEW-VALUE. Since it was + ;; causing a failure in building PCL for SBCL, so I + ;; changed it to match the definition of + ;; SLOT-BOUNDP (and also to match the list used in + ;; the similar OPTIMIZE-SLOT-VALUE, + ;; above). However, I'm weirded out by this, since + ;; this is old code which has worked for ages to + ;; build PCL for CMU CL, so it's hard to see why it + ;; should need a patch like this in order to build + ;; PCL for SBCL. I'd like to return to this and + ;; find a test case which exercises this function + ;; both in CMU CL, to see whether it's really a + ;; previously-unexercised bug or whether I've + ;; misunderstood something (and, presumably, + ;; patched it wrong). + (slot-boundp-symbol instance slot-name-form) + form + (declare (ignore slot-boundp-symbol instance)) + (let ((slot-name (eval slot-name-form))) + (optimize-instance-access slots + :boundp + sparameter + slot-name + nil))))) + ;; See OPTIMIZE-SLOT-VALUE + `(optimized-slot-boundp ,form ,(car sparameter) ,optimized-form)) `(accessor-slot-boundp ,@(cdr form)))) +(defmacro optimized-slot-boundp (form parameter-name optimized-form + &environment env) + (if (parameter-modified-p parameter-name env) + `(accessor-slot-boundp ,@(cdr form)) + optimized-form)) + (defun optimize-reader (slots sparameter gf-name form) (if sparameter (optimize-accessor-call slots :read sparameter gf-name nil) diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index a5b1085..0bef77f 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -1393,9 +1393,8 @@ (loop until (null x) do (incf result) (setq x (slot-value x 'cdroid))) result)) -(with-test (:name ((:setq :method-parameter) slot-value) :fails-on :sbcl) +(with-test (:name ((:setq :method-parameter) slot-value)) (assert (= (lengthoid (make-instance 'listoid)) 1)) - (error "the failure mode is an infinite loop") (assert (= (lengthoid (make-instance 'listoid :cdroid (make-instance 'listoid :cdroid diff --git a/version.lisp-expr b/version.lisp-expr index 63f1aa5..5b37fcc 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.16.39" +"0.9.16.40"