From 41d822d26e0ffee4be348ebf35e19caff0c858e1 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Wed, 16 Aug 2006 19:05:45 +0000 Subject: [PATCH] 0.9.15.36: less intrusive step instrumentation * INVOKE-EFFECTIVE-METHOD was missing a binding for the effective-method-form, causing potential multiple evaluation and also creating one source of confusion when step instrumenting CLOS code, manifesting as: Asserted type (MOD 536870911) conflicts with derived type (VALUES (OR FUNCTION SB-PCL::METHOD-CALL SB-PCL::FAST-METHOD-CALL) &OPTIONAL). * If the form being instrumented is a call to a known single-valued function we can instrument it in a way that doesn't kill the type-inference. This alone is enough to get rid of most warnings such as above. * Add rudimentary (B)acktrace command to the built-in stepper. --- NEWS | 3 ++ src/code/step.lisp | 5 ++- src/compiler/ir1-step.lisp | 40 +++++++++++++------ src/pcl/boot.lisp | 91 ++++++++++++++++++++++---------------------- tests/compiler.impure.lisp | 9 +++++ tests/type.impure.lisp | 2 +- version.lisp-expr | 2 +- 7 files changed, 92 insertions(+), 60 deletions(-) diff --git a/NEWS b/NEWS index 6949264..3f10968 100644 --- a/NEWS +++ b/NEWS @@ -13,6 +13,9 @@ changes in sbcl-0.9.16 relative to sbcl-0.9.15: profiled functions. (thanks to Troels Henriksen) * enhancement: compiler-macro expansion applies now to FUNCALL forms as well. + * enhancement: step-instrumentation no longer wraps known + single-value functions with multiple-value context, allowing + better type inference. * fixed bug #337: use of MAKE-METHOD in method combination now works even in the presence of user-defined method classes. (reported by Bruno Haible and Pascal Costanza) diff --git a/src/code/step.lisp b/src/code/step.lisp index db86838..a7222b3 100644 --- a/src/code/step.lisp +++ b/src/code/step.lisp @@ -22,6 +22,7 @@ stepper's prompt: N: Evaluate the current expression without stepping. C: Evaluate to finish without stepping. Q: Abort evaluation. + B: Backtrace. ?: Display this message. ") @@ -46,6 +47,8 @@ stepper's prompt: (let ((line (read-line *debug-io*))) (if (plusp (length line)) (case (char-upcase (schar line 0)) + (#\B + (backtrace)) (#\Q (abort condition)) (#\C @@ -57,7 +60,7 @@ stepper's prompt: (#\? (write-line *step-help* *debug-io*)))))))) -(defvar *stepper-hook* #'single-step +(defvar *stepper-hook* 'single-step #+sb-doc "Customization hook for alternative single-steppers. *STEPPER-HOOK* is bound to NIL prior to calling the bound function with the STEP-CONDITION as argument.") diff --git a/src/compiler/ir1-step.lisp b/src/compiler/ir1-step.lisp index 3d3bf41..023a265 100644 --- a/src/compiler/ir1-step.lisp +++ b/src/compiler/ir1-step.lisp @@ -37,13 +37,11 @@ (defun step-variable (symbol value) (when *step* - (signal 'step-variable-condition :form symbol :result value)) - value) + (signal 'step-variable-condition :form symbol :result value))) (defun step-values (form values) (when *step* - (signal 'step-values-condition :form form :result values)) - (values-list values)) + (signal 'step-values-condition :form form :result values))) (defun insert-step-conditions (form) `(locally (declare @@ -54,31 +52,49 @@ ;;; Flag to control instrumentation function call arguments. (defvar *step-arguments-p* nil) +(defun known-single-value-fun-p (fun) + (and (legal-fun-name-p fun) + (info :function :info fun) + (let ((type (info :function :type fun))) + (and (and (fun-type-p type)) + (type-single-value-p (fun-type-returns type)))))) + (defun ir1-convert-step (start next result form) (let ((form-string (let ((*print-pretty* t) (*print-readably* nil)) (prin1-to-string form)))) (etypecase form (symbol - (ir1-convert start next result - `(locally (declare (optimize (insert-step-conditions 0))) - (step-variable ,form-string ,form)))) + (let ((ctran (make-ctran)) + (*allow-instrumenting* nil)) + (ir1-convert start ctran nil `(step-variable ,form-string ,form)) + (ir1-convert ctran next result form))) (list (let* ((*step-arguments-p* (and *allow-instrumenting* (policy *lexenv* (= insert-step-conditions 3)))) (step-form `(step-form ,form-string ',(source-path-original-source *current-path*) *compile-file-pathname*)) - (values-form `(,(car form) + (fun (car form)) + (values-form `(,fun ,@(if *step-arguments-p* (mapcar #'insert-step-conditions (cdr form)) (cdr form))))) (ir1-convert start next result `(locally (declare (optimize (insert-step-conditions 0))) - ,(if *step-arguments-p* - `(let ((*step* ,step-form)) - (step-values ,form-string (multiple-value-list ,values-form))) - `(progn ,step-form ,values-form))))))))) + ,(if *step-arguments-p* + `(let ((*step* ,step-form)) + ,(if (known-single-value-fun-p fun) + `((lambda (value) + (step-values ,form-string (list value)) + value) + ,values-form) + `(multiple-value-call + (lambda (&rest values) + (step-values ,form-string values) + (values-list values)) + ,values-form))) + `(progn ,step-form ,values-form))))))))) (defun step-form-p (form) #+sb-xc-host (declare (ignore form)) diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index ca6d811..456c037 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -964,8 +964,8 @@ 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 restp - &rest 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 @@ -973,49 +973,50 @@ bootstrapping. ;; (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)) - `(progn - (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)))))))) + (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 invoke-emf (emf args) (trace-emf-call emf t args) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 0f6da5e..caf24e7 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -1318,4 +1318,13 @@ (declare (inline test-cmacro-4)) (test-cmacro-4))))) +;;; Step instrumentation breaking type-inference +(handler-bind ((warning #'error)) + (assert (= 42 (funcall (compile nil '(lambda (v x) + (declare (optimize sb-c:insert-step-conditions)) + (if (typep (the function x) 'fixnum) + (svref v (the function x)) + (funcall x)))) + nil (constantly 42))))) + ;;; success diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp index bf0bd45..f8ab6d2 100644 --- a/tests/type.impure.lisp +++ b/tests/type.impure.lisp @@ -511,7 +511,7 @@ (assert win)) ;; See FIXME in type method for CONS :SIMPLE-TYPE-= -#+nil +#+nil (multiple-value-bind (ok win) (sb-kernel:type= (sb-kernel:specifier-type '(cons goldbach1 integer)) (sb-kernel:specifier-type '(cons goldbach1 single-float))) diff --git a/version.lisp-expr b/version.lisp-expr index 2090cab..0f8def5 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.15.35" +"0.9.15.36" -- 1.7.10.4