From: Nikodemus Siivola Date: Sat, 2 Sep 2006 11:38:23 +0000 (+0000) Subject: 0.9.16.15: stamp down on warnings due to step instrumentation X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=d984db0864aa7ba5155ec684462840ec1a49ca5b;p=sbcl.git 0.9.16.15: stamp down on warnings due to step instrumentation * CALL-NEXT-METHOD body compiled without step-instumentation. * Get rid of the FAST-NARROWED-EMF kludge, replace it with another one: in addition to INVOKE-EFFECTIVE-METHOD-FUNCTION we now also have INVOKE-NARROW-EFFECTIVE-METHOD-FUNCTION. * Test. --- diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 46aa611..f6846d4 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -967,59 +967,70 @@ bootstrapping. (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg)) (invoke-fast-method-call ,emf ,@required-args+rest-arg))) -(defmacro invoke-effective-method-function (emf-form restp - &rest required-args+rest-arg) - (unless (constantp restp) - (error "The RESTP argument is not constant.")) - ;; FIXME: The RESTP handling here is confusing and maybe slightly - ;; broken if RESTP evaluates to a non-self-evaluating form. E.g. if - ;; (INVOKE-EFFECTIVE-METHOD-FUNCTION EMF '(ERROR "gotcha") ...) - ;; then TRACE-EMF-CALL-CALL-INTERNAL might die on a gotcha error. - (setq restp (constant-form-value restp)) - (with-unique-names (emf) - `(let ((,emf ,emf-form)) - (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg)) - (cond ((typep ,emf 'fast-method-call) - (invoke-fast-method-call ,emf ,@required-args+rest-arg)) - ;; "What," you may wonder, "do these next two clauses do?" - ;; In that case, you are not a PCL implementor, for they - ;; considered this to be self-documenting.:-| Or CSR, for - ;; that matter, since he can also figure it out by looking - ;; at it without breaking stride. For the rest of us, - ;; though: From what the code is doing with .SLOTS. and - ;; whatnot, evidently it's implementing SLOT-VALUEish and - ;; GET-SLOT-VALUEish things. Then we can reason backwards - ;; and conclude that setting EMF to a FIXNUM is an - ;; optimized way to represent these slot access operations. - ,@(when (and (null restp) (= 1 (length required-args+rest-arg))) - `(((typep ,emf 'fixnum) - (let* ((.slots. (get-slots-or-nil - ,(car required-args+rest-arg))) - (value (when .slots. (clos-slots-ref .slots. ,emf)))) - (if (eq value +slot-unbound+) - (slot-unbound-internal ,(car required-args+rest-arg) - ,emf) - value))))) - ,@(when (and (null restp) (= 2 (length required-args+rest-arg))) - `(((typep ,emf 'fixnum) - (let ((.new-value. ,(car required-args+rest-arg)) - (.slots. (get-slots-or-nil - ,(cadr required-args+rest-arg)))) - (when .slots. - (setf (clos-slots-ref .slots. ,emf) .new-value.)))))) - ;; (In cmucl-2.4.8 there was a commented-out third ,@(WHEN - ;; ...) clause here to handle SLOT-BOUNDish stuff. Since - ;; there was no explanation and presumably the code is 10+ - ;; years stale, I simply deleted it. -- WHN) - (t - (etypecase ,emf - (method-call - (invoke-method-call ,emf ,restp ,@required-args+rest-arg)) - (function - ,(if restp - `(apply (the function ,emf) ,@required-args+rest-arg) - `(funcall (the function ,emf) - ,@required-args+rest-arg))))))))) +(defun effective-method-optimized-slot-access-clause + (emf restp required-args+rest-arg) + ;; "What," you may wonder, "do these next two clauses do?" In that + ;; case, you are not a PCL implementor, for they considered this to + ;; be self-documenting.:-| Or CSR, for that matter, since he can + ;; also figure it out by looking at it without breaking stride. For + ;; the rest of us, though: From what the code is doing with .SLOTS. + ;; and whatnot, evidently it's implementing SLOT-VALUEish and + ;; GET-SLOT-VALUEish things. Then we can reason backwards and + ;; conclude that setting EMF to a FIXNUM is an optimized way to + ;; represent these slot access operations. + (when (not restp) + (let ((length (length required-args+rest-arg))) + (cond ((= 1 length) + `((fixnum + (let* ((.slots. (get-slots-or-nil + ,(car required-args+rest-arg))) + (value (when .slots. (clos-slots-ref .slots. ,emf)))) + (if (eq value +slot-unbound+) + (slot-unbound-internal ,(car required-args+rest-arg) + ,emf) + value))))) + ((= 2 length) + `((fixnum + (let ((.new-value. ,(car required-args+rest-arg)) + (.slots. (get-slots-or-nil + ,(cadr required-args+rest-arg)))) + (when .slots. + (setf (clos-slots-ref .slots. ,emf) .new-value.))))))) + ;; (In cmucl-2.4.8 there was a commented-out third ,@(WHEN + ;; ...) clause here to handle SLOT-BOUNDish stuff. Since + ;; there was no explanation and presumably the code is 10+ + ;; years stale, I simply deleted it. -- WHN) + ))) + +;;; Before SBCL 0.9.16.7 instead of +;;; INVOKE-NARROW-EFFECTIVE-METHOD-FUNCTION we passed a (THE (OR +;;; FUNCTION METHOD-CALL FAST-METHOD-CALL) EMF) form as the EMF. Now, +;;; to make less work for the compiler we take a path that doesn't +;;; involve the slot-accessor clause (where EMF is a FIXNUM) at all. +(macrolet ((def (name &optional narrow) + `(defmacro ,name (emf restp &rest required-args+rest-arg) + (unless (constantp restp) + (error "The RESTP argument is not constant.")) + (setq restp (constant-form-value restp)) + (with-unique-names (emf-n) + `(locally + (declare (optimize (sb-c:insert-step-conditions 0))) + (let ((,emf-n ,emf)) + (trace-emf-call ,emf-n ,restp (list ,@required-args+rest-arg)) + (etypecase ,emf-n + (fast-method-call + (invoke-fast-method-call ,emf-n ,@required-args+rest-arg)) + ,@,(unless narrow + `(effective-method-optimized-slot-access-clause + emf-n restp required-args+rest-arg)) + (method-call + (invoke-method-call ,emf-n ,restp ,@required-args+rest-arg)) + (function + ,(if restp + `(apply ,emf-n ,@required-args+rest-arg) + `(funcall ,emf-n ,@required-args+rest-arg)))))))))) + (def invoke-effective-method-function nil) + (def invoke-narrow-effective-method-function t)) (defun invoke-emf (emf args) (trace-emf-call emf t args) @@ -1091,35 +1102,12 @@ bootstrapping. (apply emf args)))) -(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) + ,(let ((call `(invoke-narrow-effective-method-function + ,next-method-call ,(not (null rest-arg)) ,@args ,@(when rest-arg `(,rest-arg))))) @@ -1153,7 +1141,8 @@ bootstrapping. ,@body) `(flet (,@(when call-next-method-p `((call-next-method (&rest cnm-args) - (declare (muffle-conditions code-deletion-note)) + (declare (muffle-conditions code-deletion-note) + (optimize (sb-c:insert-step-conditions 0))) ,@(if (safe-code-p env) `((%check-cnm-args cnm-args (list ,@args) ',method-name-declaration)) @@ -1164,8 +1153,8 @@ bootstrapping. ,method-name-declaration cnm-args)))) ,@(when next-method-p-p - `((next-method-p - () + `((next-method-p () + (declare (optimize (sb-c:insert-step-conditions 0))) (not (null ,next-method-call)))))) (let ,rebindings ,@(when rebindings `((declare (ignorable ,@all-params)))) diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index b192b02..d0e5c04 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -1243,7 +1243,8 @@ (if (atom form) (default-test-converter form) (case (car form) - ((invoke-effective-method-function invoke-fast-method-call) + ((invoke-effective-method-function invoke-fast-method-call + invoke-effective-narrow-method-function) '.call.) (methods '.methods.) @@ -1345,8 +1346,7 @@ (get-fun1 `(lambda ,arglist ,@(unless function-p - `((declare (ignore .pv-cell. - .next-method-call.)))) + `((declare (ignore .pv-cell. .next-method-call.)))) (locally (declare #.*optimize-speed*) (let ((emf ,net)) ,(make-emf-call metatypes applyp 'emf)))) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index ae57aa9..8bd3d9e 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -1388,4 +1388,14 @@ (storage-condition (e) (error e))) +;;; warnings due to step-insturmentation +(defclass debug-test-class () ()) +(handler-case + (compile nil '(lambda () + (declare (optimize (debug 3))) + (defmethod print-object ((x debug-test-class) s) + (call-next-method)))) + ((and (not style-warning) warning) (e) + (error e))) + ;;; success diff --git a/version.lisp-expr b/version.lisp-expr index a7377a2..f2dca4d 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.14" +"0.9.16.15"