((: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, ~
(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
(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
(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)))
: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
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
;; 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)
((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)
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)
(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)
projects / sbcl.git / commitdiff