X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fntrace.lisp;h=5476378baa4446462039d1accc9997925d72176a;hb=9aac8cfe0d3b3dd27b292e5661104221ddbd1bee;hp=a400ff777a61c200abc833e2ff1f6e3e2af91ff7;hpb=c6721c2ec4145261b74cef7fba96b303a277e931;p=sbcl.git diff --git a/src/code/ntrace.lisp b/src/code/ntrace.lisp index a400ff7..5476378 100644 --- a/src/code/ntrace.lisp +++ b/src/code/ntrace.lisp @@ -37,7 +37,7 @@ ;;; 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-funs* (make-hash-table :test 'eq)) +(defvar *traced-funs* (make-hash-table :test 'eq :synchronized t)) ;;; A TRACE-INFO object represents all the information we need to ;;; trace a given function. @@ -124,17 +124,24 @@ (error "can't trace special form ~S" x)) ((macro-function x)) (t - (values (fdefinition x) t)))) + (values (when (fboundp x) + (fdefinition x)) + t)))) (function x) - (t (values (fdefinition x) t))) - (case (sb-kernel:widetag-of res) - (#.sb-vm:closure-header-widetag + (t (values (when (fboundp x) + (fdefinition x)) + t))) + (typecase res + (closure (values (sb-kernel:%closure-fun res) named-p :compiled-closure)) - (#.sb-vm:funcallable-instance-header-widetag + (funcallable-instance (values res named-p :funcallable-instance)) - (t (values res named-p :compiled))))) + ;; FIXME: What about SB!EVAL:INTERPRETED-FUNCTION -- it gets picked off + ;; by the FIN above, is that right? + (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. @@ -421,21 +428,23 @@ (setf (gethash fun *traced-funs*) info)) (when (and (typep fun 'generic-function) - (trace-info-methods info)) - (dolist (method-name (sb-pcl::list-all-maybe-method-names fun)) - (when (fboundp method-name) + (trace-info-methods info) + ;; we are going to trace the method functions directly. + (not (trace-info-encapsulated info))) + (dolist (method (sb-mop:generic-function-methods fun)) + (let ((mf (sb-mop:method-function method))) ;; NOTE: this direct style of tracing methods -- tracing the ;; pcl-internal method functions -- is only one possible ;; alternative. It fails (a) when encapulation is ;; requested, because the function objects themselves are ;; stored in the method object; (b) when the method in ;; question is particularly simple, when the method - ;; functionality is in the dfun. There is an alternative - ;; technique: to replace any currently active methods with - ;; methods which encapsulate the current one. Steps towards - ;; this are currently commented out in src/pcl/env.lisp. -- - ;; CSR, 2005-01-03 - (trace-1 method-name info))))) + ;; functionality is in the dfun. See src/pcl/env.lisp for a + ;; stub implementation of encapsulating through a + ;; traced-method class. + (trace-1 mf info) + (when (typep mf 'sb-pcl::%method-function) + (trace-1 (sb-pcl::%method-function-fast-function mf) info)))))) function-or-name) @@ -511,11 +520,14 @@ ((stringp name) (let ((package (find-undeleted-package-or-lose name))) (do-all-symbols (symbol (find-package name)) - (when (and (eql package (symbol-package symbol)) - (fboundp symbol) - (not (macro-function symbol)) - (not (special-operator-p symbol))) - (forms `(trace-1 ',symbol ',options)))))) + (when (eql package (symbol-package symbol)) + (when (and (fboundp symbol) + (not (macro-function symbol)) + (not (special-operator-p symbol))) + (forms `(trace-1 ',symbol ',options))) + (let ((setf-name `(setf ,symbol))) + (when (fboundp setf-name) + (forms `(trace-1 ',setf-name ',options)))))))) ;; special-case METHOD: it itself is not a general function ;; name symbol, but it (at least here) designates one of a ;; pair of such. @@ -636,19 +648,27 @@ are evaluated in the null environment." ;;; Untrace one function. (defun untrace-1 (function-or-name) (let* ((fun (trace-fdefinition function-or-name)) - (info (gethash fun *traced-funs*))) + (info (when fun (gethash fun *traced-funs*)))) (cond - ((not info) - (warn "Function is not TRACEd: ~S" function-or-name)) - (t - (cond - ((trace-info-encapsulated info) - (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-funs*))))) + ((and fun (not info)) + (warn "Function is not TRACEd: ~S" function-or-name)) + ((not fun) + ;; Someone has FMAKUNBOUND it. + (let ((table *traced-funs*)) + (with-locked-hash-table (table) + (maphash (lambda (fun info) + (when (equal function-or-name (trace-info-what info)) + (remhash fun table))) + table)))) + (t + (cond + ((trace-info-encapsulated info) + (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-funs*))))) ;;; Untrace all traced functions. (defun untrace-all () @@ -656,23 +676,30 @@ are evaluated in the null environment." (untrace-1 fun)) t) +(defun untrace-package (name) + (let ((package (find-package name))) + (when package + (dolist (fun (%list-traced-funs)) + (cond ((and (symbolp fun) (eq package (symbol-package fun))) + (untrace-1 fun)) + ((and (consp fun) (eq 'setf (car fun)) + (symbolp (second fun)) + (eq package (symbol-package (second fun)))) + (untrace-1 fun))))))) + (defmacro untrace (&rest specs) #+sb-doc - "Remove tracing from the specified functions. With no args, untrace all - functions." - ;; KLUDGE: Since we now allow (TRACE FOO BAR "SB-EXT") to trace not - ;; only #'FOO and #'BAR but also all the functions in #, - ;; it would be probably be best for consistency to do something similar - ;; with UNTRACE. (But I leave it to someone who uses and cares about - ;; UNTRACE-with-args more often than I do.) -- WHN 2003-12-17 + "Remove tracing from the specified functions. Untraces all +functions when called with no arguments." (if specs - (collect ((res)) - (let ((current specs)) - (loop - (unless current (return)) - (let ((name (pop current))) - (res (if (eq name :function) - `(untrace-1 ,(pop current)) - `(untrace-1 ',name))))) - `(progn ,@(res) t))) + `(progn + ,@(loop while specs + for name = (pop specs) + collect (cond ((eq name :function) + `(untrace-1 ,(pop specs))) + ((stringp name) + `(untrace-package ,name)) + (t + `(untrace-1 ',name)))) + t) '(untrace-all)))