|
0
|
1 ;;; -*- Mode: EMACS-LISP; Syntax: E-Lisp; Base: 10 -*-
|
|
|
2 ;;;
|
|
|
3 ;;;; backtrace-logging.el
|
|
|
4 ;;;
|
|
|
5 ;;; User code for interacting with backtrace logging.
|
|
|
6 ;;;
|
|
|
7 ;;; ***************************************************************************
|
|
|
8 ;;;
|
|
|
9 ;;; Revision: 29-Jan-92 12:14:49
|
|
|
10 ;;;
|
|
|
11 ;;; Programmer: Harlan Sexton
|
|
|
12 ;;;
|
|
|
13 ;;; Edit-History:
|
|
|
14 ;;;
|
|
|
15 ;;; Created: 30-Aug-91 by hbs
|
|
|
16 ;;;
|
|
|
17 ;;; End-of-Edit-History
|
|
|
18
|
|
|
19 (defvar *btl-index-counter* 1)
|
|
|
20 (defvar *btl-data-file* nil)
|
|
|
21 (defvar *btl-indices-assigned* nil)
|
|
|
22 (defvar elisp-only-btl nil)
|
|
|
23 (defvar cadillac-id-tag-save 'cadillac-id-tag-save)
|
|
|
24
|
|
|
25 (defun assign-btl-indices (&optional force)
|
|
|
26 (if (or force
|
|
|
27 (not *btl-indices-assigned*))
|
|
|
28 (progn
|
|
|
29 (mapatoms 'assign-btl-index)
|
|
|
30 (setq *btl-indices-assigned* t))))
|
|
|
31
|
|
|
32 (defun btl-compiled-p (function)
|
|
|
33 (or (subrp function)
|
|
|
34 (compiled-function-p function)
|
|
|
35 (and (consp function)
|
|
|
36 (eq (car function) 'lambda)
|
|
|
37 (let ((rest (cdr (cdr function)))
|
|
|
38 (quit nil))
|
|
|
39 (while (and rest (not quit))
|
|
|
40 (let ((trial (car rest)))
|
|
|
41 (if (consp trial)
|
|
|
42 (setq quit (eq (car trial) 'byte-code)))
|
|
|
43 (setq rest (cdr rest))))
|
|
|
44 quit))))
|
|
|
45
|
|
|
46 (defun get-btl-index (symbol)
|
|
|
47 (if (symbolp symbol)
|
|
|
48 (let ((val (or (get symbol cadillac-id-tag)
|
|
|
49 (get symbol 'cadillac-id-tag-save))))
|
|
|
50 (if (and val (integerp val) (> val 0))
|
|
|
51 val
|
|
|
52 (progn
|
|
|
53 (setq val *btl-index-counter*)
|
|
|
54 (setq *btl-index-counter* (1+ *btl-index-counter*))
|
|
|
55 val)))))
|
|
|
56
|
|
|
57 (defun disable-btl-index (symbol)
|
|
|
58 (if (symbolp symbol)
|
|
|
59 (let ((val (or (get symbol cadillac-id-tag)
|
|
|
60 (get symbol 'cadillac-id-tag-save))))
|
|
|
61 (if (and val (integerp val) (> val 0))
|
|
|
62 (put symbol 'cadillac-id-tag-save val))
|
|
|
63 (remprop symbol cadillac-id-tag))))
|
|
|
64
|
|
|
65 (defun assign-btl-index (symbol)
|
|
|
66 (if (and (symbolp symbol)
|
|
|
67 (fboundp symbol))
|
|
|
68 (let* ((function (symbol-function symbol))
|
|
|
69 (subr-function (subrp function))
|
|
|
70 (compiled-function (btl-compiled-p function))
|
|
|
71 (tagged-function (get symbol cadillac-id-tag)))
|
|
|
72 (cond ((and elisp-only-btl compiled-function (not tagged-function))
|
|
|
73 (put symbol cadillac-id-tag (get-btl-index symbol)))
|
|
|
74 ((and (not elisp-only-btl) subr-function tagged-function)
|
|
|
75 (disable-btl-index symbol))))))
|
|
|
76
|
|
|
77 (defun file-to-btl-data-file (file)
|
|
|
78 (let ((base-dir (expand-file-name "")))
|
|
|
79 (if (string-equal base-dir file)
|
|
|
80 (setq file nil)))
|
|
|
81 (setq file (or file *btl-data-file*))
|
|
|
82 (let ((go-ahead nil))
|
|
|
83 (if (or (not (stringp file))
|
|
|
84 (file-directory-p file))
|
|
|
85 (setq go-ahead nil)
|
|
|
86 (if (file-exists-p file)
|
|
|
87 (setq go-ahead
|
|
|
88 (y-or-n-p (message "File exists -- overwrite %s? "
|
|
|
89 file)))
|
|
|
90 (setq go-ahead t)))
|
|
|
91 (if (not go-ahead)
|
|
|
92 (error "Bad data file.")))
|
|
|
93 file)
|
|
|
94
|
|
|
95 (defun btl-init (file &optional pc-logging)
|
|
|
96 (setq file (file-to-btl-data-file file))
|
|
|
97 (let ((log-type (if pc-logging "PC logging" "btl")))
|
|
70
|
98 (message "Initializing %s..." log-type)
|
|
0
|
99 (sit-for 0)
|
|
|
100 (assign-btl-indices t)
|
|
|
101 (setq *btl-data-file* file)
|
|
|
102 (if pc-logging
|
|
|
103 (initialize-pc-logging-internal file)
|
|
|
104 (initialize-backtrace-logging-internal file))
|
|
70
|
105 (message "Initializing %s...done." log-type)
|
|
0
|
106 (sit-for 1)
|
|
|
107 (message "")
|
|
|
108 (sit-for 0)))
|
|
|
109
|
|
|
110 (defun start-btl (file &optional elisp-flag-val)
|
|
|
111 (interactive "FFile in which to write data: ")
|
|
|
112 (terminate-logging)
|
|
|
113 (setq elisp-only-btl elisp-flag-val)
|
|
|
114 (btl-init file)
|
|
|
115 (start-logging))
|
|
|
116
|
|
|
117 (defun start-btl-elisp (file)
|
|
|
118 (interactive "FFile in which to write data: ")
|
|
|
119 (start-btl file t))
|
|
|
120
|
|
|
121 (defun consing-btl (file &optional elisp-flag-val)
|
|
|
122 (interactive "FFile in which to write data: ")
|
|
|
123 (terminate-logging)
|
|
|
124 (setq elisp-only-btl elisp-flag-val)
|
|
|
125 (set-log-signal 0)
|
|
|
126 (btl-init file)
|
|
|
127 (start-logging))
|
|
|
128
|
|
|
129 (defun consing-btl-elisp (file)
|
|
|
130 (interactive "FFile in which to write data: ")
|
|
|
131 (consing-btl file t))
|
|
|
132
|
|
|
133 (defun set-elisp-btl (arg)
|
|
|
134 (interactive "p")
|
|
|
135 (setq elisp-only-btl (eql arg 1)))
|
|
|
136
|
|
|
137 (defun start-pcl (file &optional elisp-flag-val)
|
|
|
138 (interactive "FFile in which to write data: ")
|
|
|
139 (setq elisp-only-btl elisp-flag-val)
|
|
|
140 (btl-init file t)
|
|
|
141 (start-logging))
|
|
|
142
|
|
|
143 (defun start-pcl-elisp (file)
|
|
|
144 (interactive "FFile in which to write data: ")
|
|
|
145 (start-pcl file t))
|
|
|
146
|
|
|
147 (defun suspend-btl ()
|
|
|
148 (interactive)
|
|
|
149 (stop-logging))
|
|
|
150
|
|
|
151 (defun suspend-pcl ()
|
|
|
152 (interactive)
|
|
|
153 (stop-logging))
|
|
|
154
|
|
|
155 (defun resume-btl ()
|
|
|
156 (interactive)
|
|
|
157 (start-logging))
|
|
|
158
|
|
|
159 (defun resume-pcl ()
|
|
|
160 (interactive)
|
|
|
161 (start-logging))
|
|
|
162
|
|
|
163 (defun stop-btl ()
|
|
|
164 (interactive)
|
|
|
165 (terminate-logging))
|
|
|
166
|
|
|
167 (defun stop-pcl ()
|
|
|
168 (interactive)
|
|
|
169 (terminate-logging))
|
|
|
170
|
|
|
171 (defun show-btl ()
|
|
|
172 (interactive)
|
|
|
173 (terminate-logging)
|
|
|
174 (switch-to-buffer (get-buffer-create "*BTL Log Info*"))
|
|
|
175 (goto-char (point-max))
|
|
|
176 (buffer-disable-undo (current-buffer))
|
|
|
177 (if *btl-data-file*
|
|
|
178 (summarize-logging *btl-data-file*)))
|
