- (let ((type (ecase (car form)
- (slot-value 'reader)
- (set-slot-value 'writer)
- (slot-boundp 'boundp)))
- (var (cadr form))
- (slot-name (eval (caddr form)))) ; known to be constant
- (can-optimize-access1 var required-parameters env type slot-name)))
-
-;;; FIXME: This looks like an internal helper function for CAN-OPTIMIZE-ACCESS,
-;;; and it is used that way, but
-;;; it's also called bare from several places in the code. Perhaps
-;;; the two functions should be renamed fo CAN-OPTIMIZE-ACCESS-FOR-FORM
-;;; and CAN-OPTIMIZE-ACCESS-FOR-VAR. If so, I'd just as soon use keyword
-;;; args instead of optional ones, too.
-(defun can-optimize-access1 (var required-parameters env
- &optional type slot-name)
- (when (and (consp var) (eq 'the (car var)))
- ;; FIXME: We should assert list of length 3 here. Or maybe we should just
- ;; define EXTRACT-THE, replace the whole
- ;; (WHEN ..)
- ;; form with
- ;; (AWHEN (EXTRACT-THE VAR)
- ;; (SETF VAR IT))
- ;; and then use EXTRACT-THE similarly to clean up the other tests against
- ;; 'THE scattered through the PCL code.
- (setq var (caddr var)))
- (when (symbolp var)
- (let* ((rebound? (caddr (variable-declaration 'variable-rebinding
- var
- env)))
- (parameter-or-nil (car (memq (or rebound? var)
- required-parameters))))
- (when parameter-or-nil
- (let* ((class-name (caddr (variable-declaration 'class
- parameter-or-nil
- env)))
- (class (find-class class-name nil)))
- (when (or (not (eq *boot-state* 'complete))
- (and class (not (class-finalized-p class))))
- (setq class nil))
- (when (and class-name (not (eq class-name 't)))
- (when (or (null type)
- (not (and class
- (memq *the-class-structure-object*
- (class-precedence-list class))))
- (optimize-slot-value-by-class-p class slot-name type))
- (cons parameter-or-nil (or class class-name)))))))))
-
-(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)))
- `(accessor-slot-value ,@(cdr 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)))
- `(accessor-set-slot-value ,@(cdr 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)))
- `(accessor-slot-boundp ,@(cdr form))))
-
-(defun optimize-reader (slots sparameter gf-name form)
- (if sparameter
- (optimize-accessor-call slots :read sparameter gf-name nil)
- form))
-
-(defun optimize-writer (slots sparameter gf-name form)
- (if sparameter
- (destructuring-bind (ignore1 ignore2 new-value) form
- (declare (ignore ignore1 ignore2))
- (optimize-accessor-call slots :write sparameter gf-name new-value))
- form))
-
-;;; The SLOTS argument is an alist, the CAR of each entry is the name of
-;;; a required parameter to the function. The alist is in order, so the
-;;; position of an entry in the alist corresponds to the argument's position
-;;; in the lambda list.
-(defun optimize-instance-access (slots
- read/write
- sparameter
- slot-name
- new-value)
+ (destructuring-bind (op var-form slot-name-form &optional new-value) form
+ (let ((type (ecase op
+ (slot-value 'reader)
+ (set-slot-value 'writer)
+ (slot-boundp 'boundp)))
+ (var (extract-the var-form))
+ (slot-name (constant-form-value slot-name-form env)))
+ (when (and (symbolp var) (not (var-special-p var env)))
+ (let* ((rebound? (caddr (var-declaration '%variable-rebinding var env)))
+ (parameter-or-nil (car (memq (or rebound? var)
+ required-parameters))))
+ (when parameter-or-nil
+ (let* ((class-name (caddr (var-declaration '%class
+ parameter-or-nil
+ env)))
+ (class (find-class class-name nil)))
+ (cond ((not (eq **boot-state** 'complete))
+ (setq class nil))
+ ((and class (not (class-finalized-p class)))
+ ;; The class itself is never forward-referenced
+ ;; here, but its superclasses may be.
+ (unless (try-finalize-inheritance class)
+ (when (boundp 'sb-c:*lexenv*)
+ (sb-c:compiler-notify
+ "~@<Cannot optimize slot access, inheritance of ~S is not ~
+ yet finaliable due to forward-referenced superclasses:~
+ ~% ~S~:@>"
+ class form))
+ (setf class nil))))
+ (when (and class-name (not (eq class-name t)))
+ (when (not (and class
+ (memq *the-class-structure-object*
+ (class-precedence-list class))))
+ (aver type)
+ (values (cons parameter-or-nil (or class class-name))
+ slot-name
+ new-value))))))))))
+
+;;; 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 (form slots required-parameters env)
+ (multiple-value-bind (sparameter slot-name)
+ (can-optimize-access form required-parameters env)
+ (if sparameter
+ (let ((optimized-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 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 (form slots required-parameters env)
+ (multiple-value-bind (sparameter slot-name new-value)
+ (can-optimize-access form required-parameters env)
+ (if sparameter
+ (let ((optimized-form
+ (optimize-instance-access slots :write sparameter
+ slot-name new-value (safe-code-p env))))
+ ;; 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)
+ (cond ((parameter-modified-p parameter-name env)
+ ;; ACCESSOR-SET-SLOT-VALUE doesn't do type-checking,
+ ;; so we need to use SAFE-SET-SLOT-VALUE.
+ (if (safe-code-p env)
+ `(safe-set-slot-value ,@(cdr form)))
+ `(accessor-set-slot-value ,@(cdr form)))
+ (t
+ optimized-form)))
+
+(defun optimize-slot-boundp (form slots required-parameters env)
+ (multiple-value-bind (sparameter slot-name)
+ (can-optimize-access form required-parameters env)
+ (if sparameter
+ (let ((optimized-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))
+
+;;; The SLOTS argument is an alist, the CAR of each entry is the name
+;;; of a required parameter to the function. The alist is in order, so
+;;; the position of an entry in the alist corresponds to the
+;;; argument's position in the lambda list.
+(defun optimize-instance-access (slots read/write sparameter slot-name
+ new-value &optional safep)