Commit 447477e7 authored by Juho Snellman's avatar Juho Snellman
Browse files

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
parent 57fed64f

NEWS

+2 −0
Original line number Diff line number Diff line
@@ -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

src/pcl/boot.lisp

+64 −18
Original line number Diff line number Diff line
@@ -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
@@ -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)
@@ -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)

src/pcl/vector.lisp

+91 −37
Original line number Diff line number Diff line
@@ -401,16 +401,50 @@ 
                      (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

      (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)))

                 (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

      (let ((optimized-form

             (destructuring-bind (ignore1 ignore2 slot-name-form new-value) form

               (declare (ignore ignore1 ignore2))

               (let ((slot-name (eval slot-name-form)))
@@ -418,26 +452,38 @@ 
                                           :write

                                           sparameter

                                           slot-name

                                    new-value)))

                                           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

      (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,

                   ;; 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
@@ -447,9 +493,17 @@ 
                                           :boundp

                                           sparameter

                                           slot-name

                                    nil)))

                                           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)

tests/clos.impure.lisp

+1 −2
Original line number Diff line number Diff line
@@ -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

version.lisp-expr

+1 −1
Original line number Diff line number Diff line
@@ -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"