/[cmucl]/src/code/ntrace.lisp
ViewVC logotype

Diff of /src/code/ntrace.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.22 by gerd, Sun May 11 08:57:13 2003 UTC revision 1.23 by gerd, Thu May 15 11:24:34 2003 UTC
# Line 21  Line 21 
21    
22  (in-package "DEBUG")  (in-package "DEBUG")
23    
24  (export '(*trace-values* *max-trace-indentation* *trace-encapsulate-default*))  (export '(*trace-values* *max-trace-indentation* *trace-encapsulate-default*
25              *trace-encapsulate-package-names*))
26    
27  (defvar *trace-values* nil  (defvar *trace-values* nil
28    "This is bound to the returned values when evaluating :BREAK-AFTER and    "This is bound to the returned values when evaluating :BREAK-AFTER and
# Line 34  Line 35 
35  (defvar *trace-encapsulate-default* :default  (defvar *trace-encapsulate-default* :default
36    "The default value for the :ENCAPSULATE option to trace.")    "The default value for the :ENCAPSULATE option to trace.")
37    
38    (defvar *trace-encapsulate-package-names*
39      '("COMMON-LISP"
40        "CONDITIONS"
41        "DEBUG"
42        "EXTENSIONS"
43        "FORMAT"
44        "KERNEL"
45        "LOOP"
46        "PRETTY-PRINT"
47        "SYSTEM"
48        "TRACE")
49      "List of package names.  Encapsulate functions from these packages
50       by default.  This should at least include the packages of functions
51       used by TRACE, directly or indirectly.")
52    
53    
54  ;;;; Internal state:  ;;;; Internal state:
55    
# Line 361  Line 377 
377  ;;; we have cleverly contrived to work for our hook functions.  ;;; we have cleverly contrived to work for our hook functions.
378  ;;;  ;;;
379  (defun trace-call (info)  (defun trace-call (info)
380    (multiple-value-bind    (let* ((name (trace-info-what info))
381        (start cookie)           (fdefn (lisp::fdefinition-object name nil)))
382        (trace-start-breakpoint-fun info)      (letf (((lisp::fdefn-function fdefn) (fdefinition name)))
383      (let ((frame (di:frame-down (di:top-frame))))        (multiple-value-bind (start cookie)
384        (funcall start frame nil)            (trace-start-breakpoint-fun info)
385        (let ((*traced-entries* *traced-entries*))          (let ((frame (di:frame-down (di:top-frame))))
386          (declare (special basic-definition argument-list))            (funcall start frame nil)
387          (funcall cookie frame nil)            (let ((*traced-entries* *traced-entries*))
388          (let ((vals              (declare (special basic-definition argument-list))
389                 (multiple-value-list              (funcall cookie frame nil)
390                  (apply basic-definition argument-list))))              (let ((vals
391            (funcall (trace-end-breakpoint-fun info) frame nil vals nil)                     (multiple-value-list
392            (values-list vals))))))                      (apply basic-definition argument-list))))
393                  (funcall (trace-end-breakpoint-fun info) frame nil vals nil)
394                  (values-list vals))))))))
395    
396    
397  ;;; TRACE-1 -- Internal.  ;;; TRACE-1 -- Internal.
# Line 396  Line 414 
414        (untrace-1 fun))        (untrace-1 fun))
415    
416      (let* ((debug-fun (di:function-debug-function fun))      (let* ((debug-fun (di:function-debug-function fun))
            (end-breakpoint-p (di::can-set-function-end-breakpoint-p debug-fun))  
417             (encapsulated             (encapsulated
418              (if (eq (trace-info-encapsulated info) :default)              (if (eq (trace-info-encapsulated info) :default)
419                  (ecase kind                  (let ((encapsulate-p
420                    (:compiled (not end-breakpoint-p))                         (or (di::can-set-function-end-breakpoint-p debug-fun)
421                    (:compiled-closure                             (encapsulate-by-package-p function-or-name))))
422                     (unless (functionp function-or-name)                    (ecase kind
423                       (warn "Tracing shared code for ~S:~%  ~S"                      (:compiled
424                             function-or-name fun))                       encapsulate-p)
425                     (not end-breakpoint-p))                      (:compiled-closure
426                    ((:interpreted :interpreted-closure                       (unless (functionp function-or-name)
427                                   :funcallable-instance)                         (warn "Tracing shared code for ~S:~%  ~S"
428                     t))                               function-or-name fun))
429                         encapsulate-p)
430                        ((:interpreted :interpreted-closure
431                                       :funcallable-instance)
432                         t)))
433                  (trace-info-encapsulated info)))                  (trace-info-encapsulated info)))
434             (loc (if encapsulated             (loc (if encapsulated
435                      :encapsulated                      :encapsulated
# Line 464  Line 485 
485    
486    function-or-name)    function-or-name)
487    
488    ;;;
489    ;;; Return true if FUNCTION-OR-NAME's package indicates that TRACE
490    ;;; should use encapsulation instead of function-end breakpoints.
491    ;;;
492    (defun encapsulate-by-package-p (function-or-name)
493      (multiple-value-bind (valid block)
494          (valid-function-name-p function-or-name)
495        (when (and valid (symbolp block))
496          (let* ((pkg (symbol-package block))
497                 (pkg-name (and pkg (package-name pkg))))
498            (member pkg-name *trace-encapsulate-package-names* :test #'equal)))))
499    
500    
501  ;;;; The TRACE macro:  ;;;; The TRACE macro:
502    

Legend:
Removed from v.1.22  
changed lines
  Added in v.1.23

  ViewVC Help
Powered by ViewVC 1.1.5