X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fntrace.lisp;h=62979c36aa5cc3846c4ee8efbddfac6dfa231242;hb=63cef087068afc157283c0a05ae1f16b962303aa;hp=54afe6999bad63fc0eea8fb50a899d7972e506f4;hpb=f188d1c6cdcb9d9aa117baf617c70a2933fa1c60;p=sbcl.git diff --git a/src/code/ntrace.lisp b/src/code/ntrace.lisp index 54afe69..62979c3 100644 --- a/src/code/ntrace.lisp +++ b/src/code/ntrace.lisp @@ -9,7 +9,7 @@ ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. -(in-package "SB-DEBUG") +(in-package "SB-DEBUG") ; (SB-, not SB!, since we're built in warm load.) ;;; FIXME: Why, oh why, doesn't the SB-DEBUG package use the SB-DI ;;; package? That would let us get rid of a whole lot of stupid @@ -29,15 +29,15 @@ "If the trace indentation exceeds this value, then indentation restarts at 0.") -(defvar *trace-encapsulate-default* :default +(defvar *trace-encapsulate-default* t #+sb-doc "the default value for the :ENCAPSULATE option to TRACE") ;;;; internal state ;;; a hash table that maps each traced function to the TRACE-INFO. The -;;; entry for a closure is the shared function-entry object. -(defvar *traced-functions* (make-hash-table :test 'eq)) +;;; entry for a closure is the shared function entry object. +(defvar *traced-funs* (make-hash-table :test 'eq)) ;;; A TRACE-INFO object represents all the information we need to ;;; trace a given function. @@ -81,19 +81,18 @@ ;; list of null environment forms (print-after () :type list)) -;;; This is a list of conses (function-end-cookie . -;;; condition-satisfied), which we use to note distinct dynamic -;;; entries into functions. When we enter a traced function, we add a -;;; entry to this list holding the new end-cookie and whether the -;;; trace condition was satisfied. We must save the trace condition so -;;; that the after breakpoint knows whether to print. The length of -;;; this list tells us the indentation to use for printing TRACE -;;; messages. +;;; This is a list of conses (fun-end-cookie . condition-satisfied), +;;; which we use to note distinct dynamic entries into functions. When +;;; we enter a traced function, we add a entry to this list holding +;;; the new end-cookie and whether the trace condition was satisfied. +;;; We must save the trace condition so that the after breakpoint +;;; knows whether to print. The length of this list tells us the +;;; indentation to use for printing TRACE messages. ;;; ;;; This list also helps us synchronize the TRACE facility dynamically ;;; for detecting non-local flow of control. Whenever execution hits a -;;; :function-end breakpoint used for TRACE'ing, we look for the -;;; function-end-cookie at the top of *traced-entries*. If it is not +;;; :FUN-END breakpoint used for TRACE'ing, we look for the +;;; FUN-END-COOKIE at the top of *TRACED-ENTRIES*. If it is not ;;; there, we discard any entries that come before our cookie. ;;; ;;; When we trace using encapsulation, we bind this variable and add @@ -126,58 +125,56 @@ (values (fdefinition x) t)))) (function x) (t (values (fdefinition x) t))) - (if (sb-eval:interpreted-function-p res) - (values res named-p (if (sb-eval:interpreted-function-closure res) - :interpreted-closure :interpreted)) - (case (sb-kernel:get-type res) - (#.sb-vm:closure-header-type - (values (sb-kernel:%closure-function res) - named-p - :compiled-closure)) - (#.sb-vm:funcallable-instance-header-type - (values res named-p :funcallable-instance)) - (t (values res named-p :compiled)))))) + (case (sb-kernel:widetag-of res) + (#.sb-vm:closure-header-widetag + (values (sb-kernel:%closure-fun res) + named-p + :compiled-closure)) + (#.sb-vm:funcallable-instance-header-widetag + (values res named-p :funcallable-instance)) + (t (values res named-p :compiled))))) ;;; When a function name is redefined, and we were tracing that name, ;;; then untrace the old definition and trace the new one. (defun trace-redefined-update (fname new-value) (when (fboundp fname) (let* ((fun (trace-fdefinition fname)) - (info (gethash fun *traced-functions*))) + (info (gethash fun *traced-funs*))) (when (and info (trace-info-named info)) (untrace-1 fname) (trace-1 fname info new-value))))) -(push #'trace-redefined-update sb-int:*setf-fdefinition-hook*) +(push #'trace-redefined-update *setf-fdefinition-hook*) -;;; Annotate some forms to evaluate with pre-converted functions. Each -;;; form is really a cons (exp . function). Loc is the code location -;;; to use for the lexical environment. If Loc is NIL, evaluate in the -;;; null environment. If Form is NIL, just return NIL. +;;; Annotate a FORM to evaluate with pre-converted functions. FORM is +;;; really a cons (EXP . FUNCTION). LOC is the code location to use +;;; for the lexical environment. If LOC is NIL, evaluate in the null +;;; environment. If FORM is NIL, just return NIL. (defun coerce-form (form loc) (when form (let ((exp (car form))) (if (sb-di:code-location-p loc) (let ((fun (sb-di:preprocess-for-eval exp loc))) (cons exp - #'(lambda (frame) - (let ((*current-frame* frame)) - (funcall fun frame))))) + (lambda (frame) + (let ((*current-frame* frame)) + (funcall fun frame))))) (let* ((bod (ecase loc ((nil) exp) (:encapsulated `(flet ((sb-debug:arg (n) - (declare (special argument-list)) - (elt argument-list n))) + (declare (special arg-list)) + (elt arg-list n))) (declare (ignorable #'sb-debug:arg)) ,exp)))) (fun (coerce `(lambda () ,bod) 'function))) (cons exp - #'(lambda (frame) - (declare (ignore frame)) - (let ((*current-frame* nil)) - (funcall fun))))))))) + (lambda (frame) + (declare (ignore frame)) + (let ((*current-frame* nil)) + (funcall fun))))))))) + (defun coerce-form-list (forms loc) - (mapcar #'(lambda (x) (coerce-form x loc)) forms)) + (mapcar (lambda (x) (coerce-form x loc)) forms)) ;;; Print indentation according to the number of trace entries. ;;; Entries whose condition was false don't count. @@ -186,30 +183,29 @@ (dolist (entry *traced-entries*) (when (cdr entry) (incf depth))) (format t - "~@V,0T~D: " + "~@V,0T~W: " (+ (mod (* depth *trace-indentation-step*) (- *max-trace-indentation* *trace-indentation-step*)) *trace-indentation-step*) depth))) -;;; Return true if one of the Names appears on the stack below Frame. +;;; Return true if any of the NAMES appears on the stack below FRAME. (defun trace-wherein-p (frame names) (do ((frame (sb-di:frame-down frame) (sb-di:frame-down frame))) ((not frame) nil) - (when (member (sb-di:debug-function-name (sb-di:frame-debug-function - frame)) + (when (member (sb-di:debug-fun-name (sb-di:frame-debug-fun frame)) names :test #'equal) (return t)))) -;;; Handle print and print-after options. +;;; Handle PRINT and PRINT-AFTER options. (defun trace-print (frame forms) (dolist (ele forms) (fresh-line) (print-trace-indentation) - (format t "~S = ~S" (car ele) (funcall (cdr ele) frame)))) + (format t "~@<~S ~_= ~S~:>" (car ele) (funcall (cdr ele) frame)))) -;;; Test a break option, and break if true. +;;; Test a BREAK option, and break if true. (defun trace-maybe-break (info break where frame) (when (and break (funcall (cdr break) frame)) (sb-di:flush-frames-above frame) @@ -218,15 +214,15 @@ where (trace-info-what info))))) -;;; This function discards any invalid cookies on our simulated stack. -;;; Encapsulated entries are always valid, since we bind -;;; *TRACED-ENTRIES* in the encapsulation. +;;; Discard any invalid cookies on our simulated stack. Encapsulated +;;; entries are always valid, since we bind *TRACED-ENTRIES* in the +;;; encapsulation. (defun discard-invalid-entries (frame) (loop (when (or (null *traced-entries*) (let ((cookie (caar *traced-entries*))) (or (not cookie) - (sb-di:function-end-cookie-valid-p frame cookie)))) + (sb-di:fun-end-cookie-valid-p frame cookie)))) (return)) (pop *traced-entries*))) @@ -234,40 +230,44 @@ ;;; Return a closure that can be used for a function start breakpoint ;;; hook function and a closure that can be used as the -;;; FUNCTION-END-COOKIE function. The first communicates the sense of +;;; FUN-END-COOKIE function. The first communicates the sense of ;;; the Condition to the second via a closure variable. (defun trace-start-breakpoint-fun (info) (let (conditionp) (values - #'(lambda (frame bpt) - (declare (ignore bpt)) - (discard-invalid-entries frame) - (let ((condition (trace-info-condition info)) - (wherein (trace-info-wherein info))) - (setq conditionp - (and (not *in-trace*) - (or (not condition) - (funcall (cdr condition) frame)) - (or (not wherein) - (trace-wherein-p frame wherein))))) - - (when conditionp - (let ((sb-kernel:*current-level* 0) - (*standard-output* *trace-output*) - (*in-trace* t)) - (fresh-line) - (print-trace-indentation) - (if (trace-info-encapsulated info) - (locally (declare (special basic-definition argument-list)) - (prin1 `(,(trace-info-what info) ,@argument-list))) - (print-frame-call frame)) - (terpri) - (trace-print frame (trace-info-print info))) - (trace-maybe-break info (trace-info-break info) "before" frame))) - - #'(lambda (frame cookie) - (declare (ignore frame)) - (push (cons cookie conditionp) *traced-entries*))))) + + (lambda (frame bpt) + (declare (ignore bpt)) + (discard-invalid-entries frame) + (let ((condition (trace-info-condition info)) + (wherein (trace-info-wherein info))) + (setq conditionp + (and (not *in-trace*) + (or (not condition) + (funcall (cdr condition) frame)) + (or (not wherein) + (trace-wherein-p frame wherein))))) + (when conditionp + (let ((sb-kernel:*current-level-in-print* 0) + (*standard-output* *trace-output*) + (*in-trace* t)) + (fresh-line) + (print-trace-indentation) + (if (trace-info-encapsulated info) + ;; FIXME: These special variables should be given + ;; *FOO*-style names, and probably declared globally + ;; with DEFVAR. + (locally + (declare (special basic-definition arg-list)) + (prin1 `(,(trace-info-what info) ,@arg-list))) + (print-frame-call frame)) + (terpri) + (trace-print frame (trace-info-print info))) + (trace-maybe-break info (trace-info-break info) "before" frame))) + + (lambda (frame cookie) + (declare (ignore frame)) + (push (cons cookie conditionp) *traced-entries*))))) ;;; This prints a representation of the return values delivered. ;;; First, this checks to see that cookie is at the top of @@ -276,49 +276,49 @@ ;;; see whether the function is still traced and that the condition ;;; succeeded before printing anything. (defun trace-end-breakpoint-fun (info) - #'(lambda (frame bpt *trace-values* cookie) - (declare (ignore bpt)) - (unless (eq cookie (caar *traced-entries*)) - (setf *traced-entries* - (member cookie *traced-entries* :key #'car))) - - (let ((entry (pop *traced-entries*))) - (when (and (not (trace-info-untraced info)) - (or (cdr entry) - (let ((cond (trace-info-condition-after info))) - (and cond (funcall (cdr cond) frame))))) - (let ((sb-kernel:*current-level* 0) - (*standard-output* *trace-output*) - (*in-trace* t)) - (fresh-line) - (pprint-logical-block (*standard-output* nil) - (print-trace-indentation) - (pprint-indent :current 2) - (format t "~S returned" (trace-info-what info)) - (dolist (v *trace-values*) - (write-char #\space) - (pprint-newline :linear) - (prin1 v))) - (terpri) - (trace-print frame (trace-info-print-after info))) - (trace-maybe-break info - (trace-info-break-after info) - "after" - frame))))) + (lambda (frame bpt *trace-values* cookie) + (declare (ignore bpt)) + (unless (eq cookie (caar *traced-entries*)) + (setf *traced-entries* + (member cookie *traced-entries* :key #'car))) + + (let ((entry (pop *traced-entries*))) + (when (and (not (trace-info-untraced info)) + (or (cdr entry) + (let ((cond (trace-info-condition-after info))) + (and cond (funcall (cdr cond) frame))))) + (let ((sb-kernel:*current-level-in-print* 0) + (*standard-output* *trace-output*) + (*in-trace* t)) + (fresh-line) + (pprint-logical-block (*standard-output* nil) + (print-trace-indentation) + (pprint-indent :current 2) + (format t "~S returned" (trace-info-what info)) + (dolist (v *trace-values*) + (write-char #\space) + (pprint-newline :linear) + (prin1 v))) + (terpri) + (trace-print frame (trace-info-print-after info))) + (trace-maybe-break info + (trace-info-break-after info) + "after" + frame))))) ;;; This function is called by the trace encapsulation. It calls the -;;; breakpoint hook functions with NIL for the breakpoint and cookie, which -;;; we have cleverly contrived to work for our hook functions. +;;; breakpoint hook functions with NIL for the breakpoint and cookie, +;;; which we have cleverly contrived to work for our hook functions. (defun trace-call (info) (multiple-value-bind (start cookie) (trace-start-breakpoint-fun info) (let ((frame (sb-di:frame-down (sb-di:top-frame)))) (funcall start frame nil) (let ((*traced-entries* *traced-entries*)) - (declare (special basic-definition argument-list)) + (declare (special basic-definition arg-list)) (funcall cookie frame nil) (let ((vals (multiple-value-list - (apply basic-definition argument-list)))) + (apply basic-definition arg-list)))) (funcall (trace-end-breakpoint-fun info) frame nil vals nil) (values-list vals)))))) @@ -334,19 +334,18 @@ (values definition t (nth-value 2 (trace-fdefinition definition))) (trace-fdefinition function-or-name)) - (when (gethash fun *traced-functions*) - ;; FIXME: should be STYLE-WARNING - (warn "Function ~S is already TRACE'd, retracing it." function-or-name) + (when (gethash fun *traced-funs*) + (warn "~S is already TRACE'd, untracing it." function-or-name) (untrace-1 fun)) - (let* ((debug-fun (sb-di:function-debug-function fun)) + (let* ((debug-fun (sb-di:fun-debug-fun fun)) (encapsulated (if (eq (trace-info-encapsulated info) :default) (ecase kind (:compiled nil) (:compiled-closure (unless (functionp function-or-name) - (warn "Tracing shared code for ~S:~% ~S" + (warn "tracing shared code for ~S:~% ~S" function-or-name fun)) nil) @@ -355,7 +354,7 @@ (trace-info-encapsulated info))) (loc (if encapsulated :encapsulated - (sb-di:debug-function-start-location debug-fun))) + (sb-di:debug-fun-start-location debug-fun))) (info (make-trace-info :what function-or-name :named named @@ -381,28 +380,28 @@ (unless named (error "can't use encapsulation to trace anonymous function ~S" fun)) - (sb-int:encapsulate function-or-name 'trace `(trace-call ',info))) + (encapsulate function-or-name 'trace `(trace-call ',info))) (t (multiple-value-bind (start-fun cookie-fun) (trace-start-breakpoint-fun info) (let ((start (sb-di:make-breakpoint start-fun debug-fun - :kind :function-start)) + :kind :fun-start)) (end (sb-di:make-breakpoint (trace-end-breakpoint-fun info) - debug-fun :kind :function-end - :function-end-cookie cookie-fun))) + debug-fun :kind :fun-end + :fun-end-cookie cookie-fun))) (setf (trace-info-start-breakpoint info) start) (setf (trace-info-end-breakpoint info) end) ;; The next two forms must be in the order in which they ;; appear, since the start breakpoint must run before the - ;; function-end breakpoint's start helper (which calls the + ;; fun-end breakpoint's start helper (which calls the ;; cookie function.) One reason is that cookie function ;; requires that the CONDITIONP shared closure variable be ;; initialized. (sb-di:activate-breakpoint start) (sb-di:activate-breakpoint end))))) - (setf (gethash fun *traced-functions*) info))) + (setf (gethash fun *traced-funs*) info))) function-or-name) @@ -482,8 +481,8 @@ `(let ,(binds) (list ,@(forms))) `(list ,@(forms))))) -(defun %list-traced-functions () - (loop for x being each hash-value in *traced-functions* +(defun %list-traced-funs () + (loop for x being each hash-value in *traced-funs* collect (trace-info-what x))) (defmacro trace (&rest specs) @@ -564,30 +563,30 @@ -AFTER and -ALL forms are evaluated in the null environment." (if specs (expand-trace specs) - '(%list-traced-functions))) + '(%list-traced-funs))) ;;;; untracing ;;; Untrace one function. (defun untrace-1 (function-or-name) (let* ((fun (trace-fdefinition function-or-name)) - (info (gethash fun *traced-functions*))) + (info (gethash fun *traced-funs*))) (cond ((not info) (warn "Function is not TRACEd: ~S" function-or-name)) (t (cond ((trace-info-encapsulated info) - (sb-int:unencapsulate (trace-info-what info) 'trace)) + (unencapsulate (trace-info-what info) 'trace)) (t (sb-di:delete-breakpoint (trace-info-start-breakpoint info)) (sb-di:delete-breakpoint (trace-info-end-breakpoint info)))) (setf (trace-info-untraced info) t) - (remhash fun *traced-functions*))))) + (remhash fun *traced-funs*))))) ;;; Untrace all traced functions. (defun untrace-all () - (dolist (fun (%list-traced-functions)) + (dolist (fun (%list-traced-funs)) (untrace-1 fun)) t)