X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=inline;f=src%2Fcode%2Fntrace.lisp;h=cdf16608c8b0bdbd2ea2332f246fbadb94f4ba4e;hb=5277a0cbf1a72243cad6808883a4847acefc8e6b;hp=2ac8fc1293590f235c155194c6a87a66d494f81f;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/code/ntrace.lisp b/src/code/ntrace.lisp index 2ac8fc1..cdf1660 100644 --- a/src/code/ntrace.lisp +++ b/src/code/ntrace.lisp @@ -9,13 +9,11 @@ ;;;; 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.) -(file-comment - "$Header$") - -;;; 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 prefixes.. +;;; 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 +;;; prefixes.. (defvar *trace-values* nil #+sb-doc @@ -37,12 +35,12 @@ ;;;; 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. +;;; 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)) -;;; A TRACE-INFO object represents all the information we need to trace a -;;; given function. +;;; A TRACE-INFO object represents all the information we need to +;;; trace a given function. (def!struct (trace-info (:make-load-form-fun sb-kernel:just-dump-it-normally) (:print-object (lambda (x stream) @@ -63,13 +61,14 @@ ;; the list of function names for WHEREIN, or NIL if unspecified (wherein nil :type list) - ;; The following slots represent the forms that we are supposed to evaluate - ;; on each iteration. Each form is represented by a cons (Form . Function), - ;; where the Function is the cached result of coercing Form to a function. - ;; Forms which use the current environment are converted with - ;; PREPROCESS-FOR-EVAL, which gives us a one-arg function. - ;; Null environment forms also have one-arg functions, but the argument is - ;; ignored. NIL means unspecified (the default.) + ;; The following slots represent the forms that we are supposed to + ;; evaluate on each iteration. Each form is represented by a cons + ;; (Form . Function), where the Function is the cached result of + ;; coercing Form to a function. Forms which use the current + ;; environment are converted with PREPROCESS-FOR-EVAL, which gives + ;; us a one-arg function. Null environment forms also have one-arg + ;; functions, but the argument is ignored. NIL means unspecified + ;; (the default.) ;; current environment forms (condition nil) @@ -82,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 @@ -103,19 +101,19 @@ (defvar *traced-entries* ()) (declaim (list *traced-entries*)) -;;; This variable is used to discourage infinite recursions when some trace -;;; action invokes a function that is itself traced. In this case, we quietly -;;; ignore the inner tracing. +;;; This variable is used to discourage infinite recursions when some +;;; trace action invokes a function that is itself traced. In this +;;; case, we quietly ignore the inner tracing. (defvar *in-trace* nil) ;;;; utilities -;;; Given a function name, a function or a macro name, return the raw -;;; definition and some information. "Raw" means that if the result is a -;;; closure, we strip off the closure and return the bare code. The second -;;; value is T if the argument was a function name. The third value is one of -;;; :COMPILED, :COMPILED-CLOSURE, :INTERPRETED, :INTERPRETED-CLOSURE and -;;; :FUNCALLABLE-INSTANCE. +;;; Given a function name, a function or a macro name, return the raw +;;; definition and some information. "Raw" means that if the result is +;;; a closure, we strip off the closure and return the bare code. The +;;; second value is T if the argument was a function name. The third +;;; value is one of :COMPILED, :COMPILED-CLOSURE, :INTERPRETED, +;;; :INTERPRETED-CLOSURE and :FUNCALLABLE-INSTANCE. (defun trace-fdefinition (x) (multiple-value-bind (res named-p) (typecase x @@ -127,20 +125,17 @@ (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)))))) - -;;; When a function name is redefined, and we were tracing that name, then -;;; untrace the old definition and trace the new one. + (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)) @@ -148,12 +143,12 @@ (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 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. (defun coerce-form (form loc) (when form (let ((exp (car form))) @@ -193,24 +188,23 @@ *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)))) -;;; 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) @@ -219,24 +213,24 @@ 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*))) ;;;; hook functions -;;; 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 the Condition to the second -;;; via a closure variable. +;;; Return a closure that can be used for a function start breakpoint +;;; hook function and a closure that can be used as the +;;; 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 @@ -272,7 +266,7 @@ ;;; This prints a representation of the return values delivered. ;;; First, this checks to see that cookie is at the top of -;;; *traced-entries*; if it is not, then we need to adjust this list +;;; *TRACED-ENTRIES*; if it is not, then we need to adjust this list ;;; to determine the correct indentation for output. We then check to ;;; see whether the function is still traced and that the condition ;;; succeeded before printing anything. @@ -308,8 +302,8 @@ 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)))) @@ -324,11 +318,11 @@ (values-list vals)))))) ;;; Trace one function according to the specified options. We copy the -;;; trace info (it was a quoted constant), fill in the functions, and then -;;; install the breakpoints or encapsulation. +;;; trace info (it was a quoted constant), fill in the functions, and +;;; then install the breakpoints or encapsulation. ;;; -;;; If non-null, Definition is the new definition of a function that we are -;;; automatically retracing. +;;; If non-null, DEFINITION is the new definition of a function that +;;; we are automatically retracing. (defun trace-1 (function-or-name info &optional definition) (multiple-value-bind (fun named kind) (if definition @@ -336,18 +330,17 @@ (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) + (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) @@ -356,7 +349,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 @@ -382,23 +375,24 @@ (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 cookie function.) - ;; One reason is that cookie function requires that the CONDITIONP - ;; shared closure variable be initialized. + ;; The next two forms must be in the order in which they + ;; appear, since the start breakpoint must run before 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))))) @@ -408,9 +402,9 @@ ;;;; the TRACE macro -;;; Parse leading trace options off of SPECS, modifying INFO accordingly. The -;;; remaining portion of the list is returned when we encounter a plausible -;;; function name. +;;; Parse leading trace options off of SPECS, modifying INFO +;;; accordingly. The remaining portion of the list is returned when we +;;; encounter a plausible function name. (defun parse-trace-options (specs info) (let ((current specs)) (loop @@ -455,8 +449,8 @@ current)) ;;; Compute the expansion of TRACE in the non-trivial case (arguments -;;; specified.) If there are no :FUNCTION specs, then don't use a LET. This -;;; allows TRACE to be used without the full interpreter. +;;; specified.) If there are no :FUNCTION specs, then don't use a LET. +;;; This allows TRACE to be used without the full interpreter. (defun expand-trace (specs) (collect ((binds) (forms)) @@ -578,7 +572,7 @@ (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))))