From: Christophe Rhodes Date: Thu, 13 Jan 2005 10:12:11 +0000 (+0000) Subject: 0.8.18.28: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=9d36021d86b7db7561b2edc40324c8e5229f88b3;p=sbcl.git 0.8.18.28: Method tracing (only with :encapsulate nil) ... name functions SLOW-METHOD and FAST-METHOD (so no leakage with CL:METHOD) ... new :METHODS boolean option for TRACE; also DWIM in TRACE for (METHOD FOO :AROUND (INTEGER))-style names --- diff --git a/NEWS b/NEWS index a695cb3..d6f00f4 100644 --- a/NEWS +++ b/NEWS @@ -9,6 +9,9 @@ changes in sbcl-0.8.19 relative to sbcl-0.8.18: call stack for more meaningful call-graphs and accrued time reports (x86/x86-64 only). It also now reports time spent in foreign functions. + * enhancement: it is now possible to trace most individual methods + of a generic function in addition to tracing the generic function + itself. * bug fix: invalid :DEFAULT-INITARGS are detected in compiled calls to MAKE-INSTANCE. * bug fix: defaulted initargs are passed to INITIALIZE-INSTANCE and diff --git a/src/code/ntrace.lisp b/src/code/ntrace.lisp index c5c80b6..623be7b 100644 --- a/src/code/ntrace.lisp +++ b/src/code/ntrace.lisp @@ -60,7 +60,9 @@ (end-breakpoint nil :type (or sb-di:breakpoint null)) ;; the list of function names for WHEREIN, or NIL if unspecified (wherein nil :type list) - + ;; should we trace methods given a generic function to trace? + (methods nil) + ;; 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 @@ -370,6 +372,7 @@ :named named :encapsulated encapsulated :wherein (trace-info-wherein info) + :methods (trace-info-methods info) :condition (coerce-form (trace-info-condition info) loc) :break (coerce-form (trace-info-break info) loc) :print (coerce-form-list (trace-info-print info) loc) @@ -411,7 +414,24 @@ (sb-di:activate-breakpoint start) (sb-di:activate-breakpoint end))))) - (setf (gethash fun *traced-funs*) info))) + (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) + ;; 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))))) function-or-name) @@ -440,6 +460,8 @@ (if (listp (car value)) (car value) value))) (:encapsulate (setf (trace-info-encapsulated info) (car value))) + (:methods + (setf (trace-info-methods info) (car value))) (:break (setf (trace-info-break info) value)) (:break-after (setf (trace-info-break-after info) value)) (:break-all @@ -490,6 +512,16 @@ (not (macro-function symbol)) (not (special-operator-p symbol))) (forms `(trace-1 ',symbol ',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. + ((and (consp name) (eq (car name) 'method)) + (when (fboundp (list* 'sb-pcl::slow-method (cdr name))) + (forms `(trace-1 ',(list* 'sb-pcl::slow-method (cdr name)) + ',options))) + (when (fboundp (list* 'sb-pcl::fast-method (cdr name))) + (forms `(trace-1 ',(list* 'sb-pcl::fast-method (cdr name)) + ',options)))) (t (forms `(trace-1 ',name ',options)))) (setq current (parse-trace-options current options))))) @@ -577,6 +609,10 @@ The following options are defined: *not* evaluated in the function's lexical environment, but SB-DEBUG:ARG can still be used. + :METHODS {T | NIL} + If T, any function argument naming a generic function will have its + methods traced in addition to the generic function itself. + :FUNCTION Function-Form This is a not really an option, but rather another way of specifying what function to trace. The Function-Form is evaluated immediately, diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 083dfc4..d1a56b4 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -435,7 +435,7 @@ bootstrapping. specl)) specializers)) (mname `(,(if (eq (cadr initargs-form) :function) - 'method 'fast-method) + 'slow-method 'fast-method) ,name ,@qualifiers ,specls))) `(progn (defun ,mname ,(cadr fn-lambda) @@ -1411,7 +1411,7 @@ bootstrapping. method)) (defun make-method-spec (gf-spec qualifiers unparsed-specializers) - `(method ,gf-spec ,@qualifiers ,unparsed-specializers)) + `(slow-method ,gf-spec ,@qualifiers ,unparsed-specializers)) (defun initialize-method-function (initargs &optional return-function-p method) (let* ((mf (getf initargs :function)) diff --git a/src/pcl/compiler-support.lisp b/src/pcl/compiler-support.lisp index 223eaae..cd5793c 100644 --- a/src/pcl/compiler-support.lisp +++ b/src/pcl/compiler-support.lisp @@ -82,10 +82,7 @@ (define-internal-pcl-function-name-syntax sb-pcl::fast-method (list) (valid-function-name-p (cadr list))) -;;; FIXME: I don't like this name, because though it looks nice and -;;; internal, it is in fact CL:METHOD, and as such has a slight -;;; implication of supportedness. -(define-internal-pcl-function-name-syntax sb-pcl::method (list) +(define-internal-pcl-function-name-syntax sb-pcl::slow-method (list) (valid-function-name-p (cadr list))) (defun sb-pcl::random-documentation (name type) diff --git a/src/pcl/env.lisp b/src/pcl/env.lisp index d074eb6..fadcb93 100644 --- a/src/pcl/env.lisp +++ b/src/pcl/env.lisp @@ -108,6 +108,16 @@ (fdefinition name)) |# +;;;; Helper for slightly newer trace implementation, based on +;;;; breakpoint stuff. The above is potentially still useful, so it's +;;;; left in, commented. +(defun list-all-maybe-method-names (gf) + (let (result) + (dolist (method (generic-function-methods gf) (nreverse result)) + (let ((spec (nth-value 2 (parse-method-or-spec method)))) + (push spec result) + (push (list* 'fast-method (cdr spec)) result))))) + ;;;; MAKE-LOAD-FORM ;; Overwrite the old bootstrap non-generic MAKE-LOAD-FORM function with a diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index deda8ec..8a58b8e 100644 --- a/src/pcl/low.lisp +++ b/src/pcl/low.lisp @@ -189,7 +189,7 @@ ;; hasn't been defined by DEFUN. (FIXME: is this right? This logic ;; comes from CMUCL). -- CSR, 2004-12-31 (when (and (consp new-name) - (member (car new-name) '(method fast-method slot-accessor))) + (member (car new-name) '(slow-method fast-method slot-accessor))) (setf (fdefinition new-name) fun)) fun) diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index 9a8f51d..23374fa 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -1044,7 +1044,7 @@ (defun name-method-lambda (method-lambda) (let ((method-name (body-method-name (cddr method-lambda)))) (if method-name - `(named-lambda (method ,method-name) ,(rest method-lambda)) + `(named-lambda (slow-method ,method-name) ,(rest method-lambda)) method-lambda))) (defun make-method-initargs-form-internal (method-lambda initargs env) diff --git a/version.lisp-expr b/version.lisp-expr index c3e7d57..5f7a6f4 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.8.18.27" +"0.8.18.28"