(in-package :cl-user) #| ###################################################################### CTRACE - internal tracing facility Copyright © 1994-97 Michael Travers Permission is given to use and modify this code as long as the copyright notice is preserved. Send questions, comments, and fixes to mt@media.mit.edu. ------------------------------------------------------------------------- An advanced tracing facility. The standard trace package does not work well in situations where I/O is being done, such as event handlers. This package performs tracing by creating a list structure to record function entrances and exits. This structure can be displayed or processed after the fact. The package also includes the concept of a tracing level, so that varying amount of detail can be recorded. Todo: - handle multiple processes (use let-globally, record *current-process*) - include options for live (printing) tracing as well as structure building - perhaps use objects rather than lists for recording structure Quick start: (ctrace-function 'my-function1) (ctrace-function 'my-function2) etc. (ct (my-computation)) will run (my-computation) tracing calls to my-function1 and 2, and displays the resulting trace in a Fred window. Documentation: (CTRACE item &optional level) Record item if trace level is >= to level. CTRACE is used for putting trace points in code. (WITH-CTRACE (item &optional level) . body) Record an item as in CTRACE, and all traces that occur in body will be recorded as subitems. (CTRACE-FUNCTION function-name &optional level) Advises the function so that it has a WITH-CTRACE wrapped around it. (UNCTRACE-FUNCTION &optional function-name) Remove the WITH-CTRACE wrapper from a function (or all such functions if none is specified) (CTRACE-ALL &optional (package *package*)) ctrace all functions in the given package (WITH-CTRACING (&optional name level) . body) Enables ctracing around the execution of body, and returns the the trace (START-CTRACE &optional name level) Enable ctracing globally (STOP-CTRACE) DIsable global ctracing, and returns the accumulated trace structure. (VIEW-CTRACE &optional trace) View a trace in its own window, pretty-printed. (CT &body body) Equivalent to (view-ctrace (with-ctracing () )). Todo: separate out MCL dependent parts. Can I replace advise with pure CL? History: Ancestry: Henry Lieberman's ZStep, my own PSTEP/PTRACE. 6/25/95 13:08 packaged as separate facility. 6/26/95 17:50 made level arguments optional, flushed name args, improved UNCTRACE-FUNCTION 7/10/95 23:01 fix view-ctrace to invalidate view. Clean up examples. Make trace headers (:local-ctrace, etc) into lists to make the thing easier to parse) Interface to Lynch's twist-down for viewing (very preliminary) 10/13/95 18:23: add CTRACE-ALL. Too slow though, because ADVISE is slow 10/15/95 16:52 add *last-ctrace*, cleaned up function messages 12/10/95 22:51 with-ctracing was setting rather than binding *ctrace-top* added error handling added ct for convenience 12/20/95 1:21 add fboundp check and error message to ctrace-function 1/6/96 18:13 small improvements to twist-down hack 1/8/96 17:37 updated documentation and code formatting 1/14/96 19:15 added ctt, use geneva for trace-window 3/29/96 17:14 play safe, copy all list structure before recording it. no, that's too much gunk, just do it for ctrace-function, in other cases make callers handle it 11/23/96 13:13 ADVISE internals are different in 3.1/4.0 1/12/97 17:47 fix copy-list-recursive to deal with dotted-pair arguments 3/18/97 12:36 add without-interrupts to deal with multiple processes somewhat better ###################################################################### |# ;;; CTRACE (defvar *ctrace-level* 0) (defvar *ctrace-current-item* nil) (defvar *ctrace-top*) (defvar *last-ctrace*) (defun copy-list-recursive (item) (if (consp item) (cons (copy-list-recursive (car item)) (copy-list-recursive (cdr item))) item)) (defun ctrace-item-out (item) (without-interrupts ; lock out other processes (let ((newbie (list item))) (when (cdr (last *ctrace-current-item*)) (error "foo?")) ; make sure we aren't clobbering anything (rplacd (last *ctrace-current-item*) newbie) (setf *ctrace-current-item* newbie)))) ; make a ctrace entry. this is a macro so that the computation of the item ; can be done lazily. (defmacro ctrace (item &optional (level 1)) `(when (<= ,level *ctrace-level*) (ctrace-item-out ,item) nil)) ; make an entry that includes all activity inside dynamic context (defmacro with-ctrace ((item &optional (level 1)) &body body) `(let ((*ctrace-current-item* (if (<= ,level *ctrace-level*) (car (ctrace-item-out (list ,item))) *ctrace-current-item*))) ,@body)) (defvar *ctraced-functions* nil) ;;; put a ctrace around an existing function (defun ctrace-function (function-name &optional (level 1)) (assert (fboundp function-name) () "No definition for ~A" function-name) (pushnew function-name *ctraced-functions*) #-(or :ccl-3.1 :ccl-4) (ccl::advise-1 function-name :around 'ctrace `(with-ctrace (`(calling (,',function-name ,@(copy-list-recursive arglist))) ,level) (let ((result (:do-it))) (ctrace `(,',function-name returned ,(copy-list-recursive result)) ,level) result)) nil) #+(or :ccl-3.1 :ccl-4) (let ((newsym (gensym "CTRACE"))) (ccl::advise-2 (eval (ccl::advise-global-def function-name newsym :around `(with-ctrace (`(calling (,',function-name ,@(copy-list-recursive arglist))) ,level) (let ((result (:do-it))) (ctrace `(,',function-name returned ,(copy-list-recursive result)) ,level) result)))) newsym nil function-name :around 'ctrace nil))) (defun unctrace-function (&optional function-name) (if function-name (progn (ccl::unadvise-1 function-name :around 'ctrace) (deletef function-name *ctraced-functions*)) (prog1 *ctraced-functions* (dolist (fn *ctraced-functions* ()) (unctrace-function fn))))) (defun ctrace-all (&optional (package *package*)) (let ((package (if (symbolp package) (find-package package) package))) (do-symbols (symbol package) (when (and (eq (symbol-package symbol) package) (fboundp symbol) (not (macro-function symbol))) (ctrace-function symbol))))) ; top-level form to enable ctracing (defmacro with-ctracing ((&optional (level 1)) &body body) `(let ((*ctrace-level* ,level) (*ctrace-top* (setf *ctrace-current-item* (list '(:local-ctrace))))) (catch :ctrace-err (handler-bind ((error #'(lambda (condition) (ctrace `(error ,(with-output-to-string (stream) (ccl::report-condition condition stream)))) (throw :ctrace-err *ctrace-top*)))) ,@body)) (setf *last-ctrace* *ctrace-top*))) ;;; for maximal convenience (defmacro ct (&body body) `(view-ctrace (with-ctracing () ,@body))) ;;; enable ctracing in global context (defun start-ctrace (&optional (level 1)) (setf *ctrace-level* level) (setf *ctrace-top* (setf *ctrace-current-item* (list '(:global-ctrace))))) (defun stop-ctrace () (setf *ctrace-level* 0) (prog1 (setf *last-ctrace* *ctrace-top*) (setf *ctrace-top* nil))) ; view the trace in an editor window ;;; mostly so they can all be flushed easily (defclass trace-window (fred-window) () (:default-initargs :scratch-p t)) (defun view-ctrace (&optional (trace *ctrace-top*)) (let ((w (make-instance 'trace-window :window-title (format nil "Trace ~A" (car trace)) :view-font '("Geneva" 9 :plain) :view-size #@(1000 700)))) (pprint trace w) (invalidate-view w) ; necessary to force update (beep))) ;;; the default method computes width based on the maximum width of chars. If you ;;; use Geneva, it actually fits LESS chars into a line. This is a crock to compensate. (defmethod stream-line-length ((w trace-window)) (* 2 (call-next-method))) #| ;;; Interface to twist-down ;;; very preliminary ;;; I wish opening was smoother (it redraws entiree bottom part of screen). (load "others;lynch lib:ll-init") ; oodles-of-utils must have alias in CCL folder (require :twist-down) (defun string-truncate (string length) (if (> (length string) length) (subseq string 0 length) string)) (defclass ctrace-twist-dialog (dialog) ()) (defmethod set-view-size :after ((view ctrace-twist-dialog) h &optional v) (set-view-size (elt (view-subviews view) 0) (subtract-points (view-size view) #@(22 22)))) (defun view-ctrace-twist (ctrace) (let ((w (make-instance 'ctrace-twist-dialog :view-size #@(422 422) :grow-icon-p t))) (add-subviews w (make-instance 'cl-user::twist-down :view-nick-name 'ctrace :view-font '("Geneva" 9 :plain) :view-size #@(400 400) :root ctrace :node-string-function #'(lambda (node) (string-truncate (princ-to-string (if (listp (first node)) (first node) node)) 255)) :children-function #'(lambda (node) (if (listp (first node)) (rest node) nil)))) w)) (defmacro ctt (&body body) `(view-ctrace-twist (with-ctracing () ,@body))) |# #| Examples: (defun fact (n) (declare (notinline fact)) ; necessary to trace recursive functions (if (zerop n) 1 (* n (fact (1- n))))) (ctrace-function 'fact) (ct (fact 6)) ;;; alternatively (unctrace-function 'fact) (defun fact (n) (with-ctrace (`(calling (fact ,n))) (let ((value (if (zerop n) 1 (* n (fact (1- n)))))) (ctrace `(returned ,value)) value))) (ct (fact 6)) |#