1 | (in-package :system) |
---|
2 | |
---|
3 | (require :jss) ;; for now |
---|
4 | |
---|
5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
---|
6 | |
---|
7 | ;; I don't understand the algorithm that sys:backtrace uses, which seems |
---|
8 | ;; broken, so here's an alternative. |
---|
9 | |
---|
10 | ;; The lisp portion of the stack backtrace is computed as it is now. It |
---|
11 | ;; will have invoke-debugger at the top then some java stack frames that |
---|
12 | ;; abcl pushes (the "i don't understand") and then the rest of the |
---|
13 | ;; backtrace. We trim that by popping off the invoke-debugger and java |
---|
14 | ;; stack frames, leaving just lisp frames. |
---|
15 | |
---|
16 | ;; If there's a java exception. In that case we compare the stacktrace of |
---|
17 | ;; the exception to the java stack trace and grab the top part of it |
---|
18 | ;; that's unique to the exception. We prepend this to the lisp stack |
---|
19 | ;; trace. |
---|
20 | |
---|
21 | ;; The result will be that we will *not* see the call to invoke debugger, |
---|
22 | ;; or any of the swank handling, just what (I think) is relative. |
---|
23 | |
---|
24 | ;; What still needs to be investigated is how this plays in cases where |
---|
25 | ;; there are callbacks to lisp from java. |
---|
26 | |
---|
27 | ;; A good test to see the difference would be |
---|
28 | |
---|
29 | ;; (#"replaceAll" "" "(?o" "") |
---|
30 | |
---|
31 | ;; which should now show the calls within the regex code leading to |
---|
32 | ;; the exception. |
---|
33 | |
---|
34 | (defvar *use-old-backtrace* nil "set to t to fall back to the standard backtrace") |
---|
35 | |
---|
36 | (defvar *hide-swank-frames* t "set to nil if you want to see debugger internal frames") |
---|
37 | |
---|
38 | (defvar *unwelcome-java-frames* |
---|
39 | '("sun.reflect.Native.*AccessorImpl\\..*" |
---|
40 | "sun.reflect.Delegating.*AccessorImpl\\..*" |
---|
41 | "sun.reflect.Generated.*Accessor\\d+\\.invoke") |
---|
42 | "if a java frame matches any of these patterns, don't show it" |
---|
43 | ) |
---|
44 | |
---|
45 | (defvar *caught-frames* nil "When backtrace is called, it sets this to |
---|
46 | the java stack frames that are unique to the java exception, which is |
---|
47 | then subsequently used by slime to mark them") |
---|
48 | |
---|
49 | (defun swankish-frame (frame) |
---|
50 | "hackish test for whether a frame is some internal function from swank" |
---|
51 | (let ((el (car (sys::frame-to-list frame)))) |
---|
52 | (let ((package |
---|
53 | (cond ((and (symbolp el) |
---|
54 | (symbol-package el)) |
---|
55 | (package-name (symbol-package el))) |
---|
56 | ;; hack! really I mean anything with a function plist |
---|
57 | ((eq (type-of el) 'compiled-function) |
---|
58 | (let ((owner (getf (function-plist el) :internal-to-function))) |
---|
59 | (if (and (symbolp owner) |
---|
60 | (symbol-package owner)) |
---|
61 | (package-name |
---|
62 | (symbol-package owner)) |
---|
63 | ""))) |
---|
64 | (t "")))) |
---|
65 | (and package (#"matches" package "SWANK.*"))))) |
---|
66 | |
---|
67 | (defun javaframe (java-stack-frame) |
---|
68 | "Return the java StackFrame instance" |
---|
69 | (if (java::java-object-p java-stack-frame) |
---|
70 | java-stack-frame |
---|
71 | (#"get" (load-time-value (java::jclass-field "org.armedbear.lisp.JavaStackFrame" "javaFrame")) java-stack-frame))) |
---|
72 | |
---|
73 | (defun stackframe-head (frame &optional with-method) |
---|
74 | "If a lisp frame, the function (symbol or function). In a java frame the class name, with method if with-method is t" |
---|
75 | (if (typep frame 'lisp-stack-frame) |
---|
76 | (#"getOperator" frame) |
---|
77 | (let ((frame (if (typep frame 'java-stack-frame) (javaframe frame) frame))) |
---|
78 | (if with-method |
---|
79 | (concatenate 'string (#"getClassName" frame) "." (#"getMethodName" frame)) |
---|
80 | (#"getClassName" frame))))) |
---|
81 | |
---|
82 | (defun backtrace-invoke-debugger-position (stacktrace) |
---|
83 | "Position of the call to invoke-debugger" |
---|
84 | (let ((looking-for `(invoke-debugger ,#'invoke-debugger))) |
---|
85 | (position-if (lambda(e) (memq (#"getOperator" e) looking-for)) stacktrace))) |
---|
86 | |
---|
87 | (defun swank-p () |
---|
88 | "are we running with slime/swank? This should work without swank too" |
---|
89 | (find-package 'swank)) |
---|
90 | |
---|
91 | (defun repl-loop-position (stacktrace start) |
---|
92 | "Position of the frame starting the repl at this level" |
---|
93 | (if (swank-p) |
---|
94 | (position-if (lambda(e) (eq (stackframe-head e) (intern "SLDB-LOOP" 'swank))) stacktrace :start start) |
---|
95 | (position-if (lambda(e) (eq (stackframe-head e) 'debug-loop)) stacktrace :start start) |
---|
96 | )) |
---|
97 | |
---|
98 | (defun last-internal-calls-position (stacktrace) |
---|
99 | "Some java frames are replicates of the lisp stack frame. This gets |
---|
100 | the position of the closest to top non-user lisp call. It should leave |
---|
101 | intact frames corresponding to cases where a piece of lisp implemented |
---|
102 | in java calls another lisp function" |
---|
103 | (let ((pos (position-if (lambda(e) |
---|
104 | (and (not (typep e 'lisp-stack-frame)) |
---|
105 | (not (member (#"getMethodName" (javaframe e)) '("execute" "evalCall" "eval" "funcall" "apply") :test 'equal)))) |
---|
106 | stacktrace :from-end t))) |
---|
107 | pos)) |
---|
108 | |
---|
109 | (defun java-frame-segment (stacktrace) |
---|
110 | "Returns the bounds of the section of the backtrace that have been added with pushJavaStackFrame" |
---|
111 | (let ((start (position-if (lambda(e) (typep e 'java-stack-frame)) stacktrace))) |
---|
112 | (and start (list start (position-if (lambda(e) (typep e 'lisp-stack-frame)) stacktrace :start start))))) |
---|
113 | |
---|
114 | (defun splice-out (sequence from to) |
---|
115 | "remove elements from->to from sequence" |
---|
116 | (append (subseq sequence 0 from) (subseq sequence to))) |
---|
117 | |
---|
118 | (defun splice-out-java-stack-duplicating-lisp-stack (stacktrace) |
---|
119 | "cut out a section of java frames, maximally ending at the first lisp stack frame hit" |
---|
120 | (let ((extra-java-frames-pos (last-internal-calls-position stacktrace))) |
---|
121 | (let ((spliced |
---|
122 | (if extra-java-frames-pos |
---|
123 | (append (subseq stacktrace 0 extra-java-frames-pos) |
---|
124 | (let ((lisp-frame-pos (position 'lisp-stack-frame stacktrace :key 'type-of :start extra-java-frames-pos))) |
---|
125 | (and lisp-frame-pos |
---|
126 | (subseq stacktrace |
---|
127 | (position 'lisp-stack-frame stacktrace :key 'type-of :start extra-java-frames-pos))))) |
---|
128 | stacktrace))) |
---|
129 | spliced))) |
---|
130 | |
---|
131 | (defun difference-between-exception-stacktrace-and-after-caught-stacktrace (condition) |
---|
132 | "When there's a java exception, the condition has the stack trace as |
---|
133 | it was when the exception was thrown. Our backtrace is after it is |
---|
134 | caught. This function gets the difference - the frames unique to the |
---|
135 | exception" |
---|
136 | (let* ((exception-stack-trace (coerce (#"getStackTrace" (java::java-exception-cause condition)) 'list)) |
---|
137 | (debugger-stack-trace |
---|
138 | (coerce (subseq exception-stack-trace |
---|
139 | (position (#"getName" (#"getClass" #'invoke-debugger)) |
---|
140 | (#"getStackTrace" (#"currentThread" 'Thread)) |
---|
141 | :key #"getClassName" |
---|
142 | :test 'string-equal)) |
---|
143 | 'list))) |
---|
144 | (subseq exception-stack-trace |
---|
145 | 0 (position-if (lambda(frame) (find frame debugger-stack-trace :test (lambda(a b ) (eql (#"hashCode" a) (#"hashCode" b))))) |
---|
146 | exception-stack-trace)))) |
---|
147 | |
---|
148 | (defun remove-unsightly-java-frames (stacktrace) |
---|
149 | "Remove uninformative java frames, typically bits of the internals of the java implementation" |
---|
150 | (remove-if (lambda(frame) |
---|
151 | (member (stackframe-head frame t) *unwelcome-java-frames* :test #"matches")) |
---|
152 | stacktrace)) |
---|
153 | |
---|
154 | ;; 3: (invoke-debugger #<java-exception org.semanticweb.owlapi.reasoner.InconsistentOntologyException: Inconsistent ontology {8F97F7A}>) |
---|
155 | ;; 4: org.armedbear.lisp.Lisp.error(Lisp.java:385) |
---|
156 | |
---|
157 | ;; 5: (invoke-debugger #<reader-error {2FE2E7E6}>) |
---|
158 | ;; 6: (error #<reader-error {2FE2E7E6}>) |
---|
159 | ;; 7: (#<local-function in eval-region {D6D0A1B}> #<reader-error {2FE2E7E6}>) |
---|
160 | ;; 8: (signal #<reader-error {2FE2E7E6}>) |
---|
161 | ;; 9: org.armedbear.lisp.Lisp.error(Lisp.java:385) |
---|
162 | |
---|
163 | (defun lisp-stack-exception-catching-frames (stacktrace) |
---|
164 | "The frames corresponding to ABCL's internal handling of an exception" |
---|
165 | (and (eq (stackframe-head (car stacktrace)) 'invoke-debugger) |
---|
166 | (let ((error-position (position "org.armedbear.lisp.Lisp.error" stacktrace |
---|
167 | :key (lambda(e) (stackframe-head e t)) |
---|
168 | :test 'equal))) |
---|
169 | (if error-position |
---|
170 | (subseq stacktrace 0 (1+ error-position)) |
---|
171 | (list (car stacktrace)) |
---|
172 | )))) |
---|
173 | |
---|
174 | (defun splice-out-spurious-error-frames (stacktrace) |
---|
175 | "if there are nested exceptions sometimes there are extra (error), |
---|
176 | <function>, (signal) frames. we only want the first error. Remove |
---|
177 | repeated ones. Illiustrated by first getting an errors with an |
---|
178 | inconsistent ontology and then calling (read-from-string \"#<\") to |
---|
179 | generate a reader error. Get rid of these. Finally, if the next |
---|
180 | next frame after error is signal of the same condition, those two |
---|
181 | frames are also removed" |
---|
182 | (let ((error-position (position 'error stacktrace :key 'stackframe-head))) |
---|
183 | (if (and error-position (> (length stacktrace) (+ error-position 3))) |
---|
184 | (loop with trash = 0 |
---|
185 | for pos = error-position then next |
---|
186 | for next = (+ pos 3) |
---|
187 | until (not (eq (stackframe-head (nth next stacktrace)) 'error)) |
---|
188 | do (incf trash 3) |
---|
189 | finally (return |
---|
190 | (let ((spliced (if (> trash 1) |
---|
191 | (splice-out stacktrace (1+ error-position) (+ error-position trash 1)) |
---|
192 | stacktrace))) |
---|
193 | (if (and (eq (stackframe-head (nth (+ error-position 2) spliced)) 'signal) |
---|
194 | (eq (second (frame-to-list (nth error-position spliced))) |
---|
195 | (second (frame-to-list (nth (+ error-position 2) spliced))))) |
---|
196 | (splice-out spliced (1+ error-position) (+ error-position 3)) |
---|
197 | stacktrace)))) |
---|
198 | stacktrace))) |
---|
199 | |
---|
200 | (defun new-backtrace (condition) |
---|
201 | "New implementation of backtrace that tries to clean up the stack |
---|
202 | trace shown when an error occurs. There are a bunch of |
---|
203 | idiosyncrasies of what sys:backtrace generates which land up |
---|
204 | obscuring what the problem is, or at least making it more of a hunt |
---|
205 | than one would want. This backtrace tries to show only stuff I think |
---|
206 | matters - user function calls and, when there's an exception, calls |
---|
207 | inside the lisp implementation leading to the error" |
---|
208 | (if *use-old-backtrace* |
---|
209 | (backtrace) |
---|
210 | (let* ((lisp-stacktrace (#"backtrace" (threads::current-thread) 0)) |
---|
211 | (invoke-pos (backtrace-invoke-debugger-position lisp-stacktrace)) |
---|
212 | (repl-loop-pos (repl-loop-position lisp-stacktrace invoke-pos))) |
---|
213 | (let ((narrowed-lisp-stacktrace |
---|
214 | (splice-out-java-stack-duplicating-lisp-stack (subseq lisp-stacktrace invoke-pos (and repl-loop-pos (1+ repl-loop-pos)))))) |
---|
215 | (when *hide-swank-frames* |
---|
216 | (let ((swank-start (position-if 'swankish-frame narrowed-lisp-stacktrace))) |
---|
217 | (and swank-start |
---|
218 | (setq narrowed-lisp-stacktrace |
---|
219 | (append |
---|
220 | (subseq narrowed-lisp-stacktrace 0 swank-start) |
---|
221 | (if repl-loop-pos (last narrowed-lisp-stacktrace) nil)))))) |
---|
222 | (setq narrowed-lisp-stacktrace (splice-out-spurious-error-frames narrowed-lisp-stacktrace)) |
---|
223 | (if (typep condition 'java::java-exception) |
---|
224 | (progn |
---|
225 | (let* ((delta (difference-between-exception-stacktrace-and-after-caught-stacktrace condition)) |
---|
226 | (cleaned (splice-out-java-stack-duplicating-lisp-stack (remove-unsightly-java-frames delta))) |
---|
227 | (exception-frames (lisp-stack-exception-catching-frames narrowed-lisp-stacktrace))) |
---|
228 | (setq *caught-frames* delta) |
---|
229 | (let ((result (append exception-frames |
---|
230 | (mapcar (lambda(frame) (jss::new 'javastackframe frame)) cleaned) |
---|
231 | (subseq narrowed-lisp-stacktrace (length exception-frames))))) |
---|
232 | result |
---|
233 | ))) |
---|
234 | narrowed-lisp-stacktrace))))) |
---|
235 | |
---|
236 | #| |
---|
237 | (defmethod ho ((a t)) (read-from-string "(#\"setLambdaName\" #<g466140 {168C36ED}> '(flet a))")) |
---|
238 | (defmethod no ((a t)) (read-from-string "(#\"setLambdaName\" #<g466140 {168C36ED}> '(flet a))")) |
---|
239 | (defmethod fo () (ho 1) (no 1)) |
---|
240 | (defun bar () (fo)) |
---|
241 | (defun foo () (funcall #'bar)) |
---|
242 | (defun baz () (foo)) |
---|
243 | |
---|
244 | |
---|
245 | caused by reader-error |
---|
246 | |
---|
247 | Checking for execute isn't enough. |
---|
248 | Symbol.execute might be good |
---|
249 | |
---|
250 | So maybe modify: |
---|
251 | Find invoke-debugger position |
---|
252 | go down stack until you reach a symbol.execute, then skip rest of string of java frames. |
---|
253 | |
---|
254 | Right now I skip from invoke-debugger to next list but because signal is there it gets stuck. |
---|
255 | |
---|
256 | 5: (invoke-debugger #<reader-error {4BFF7154}>) |
---|
257 | below here ok |
---|
258 | 6: (error #<reader-error {4BFF7154}>) |
---|
259 | 7: (#<local-function in eval-region {AC27B6F}> #<reader-error {4BFF7154}>) |
---|
260 | 8: (signal #<reader-error {4BFF7154}>) |
---|
261 | 9: org.armedbear.lisp.Lisp.error(Lisp.java:385) |
---|
262 | 10: org.armedbear.lisp.LispReader$22.execute(LispReader.java:350) |
---|
263 | 11: org.armedbear.lisp.Stream.readDispatchChar(Stream.java:813) |
---|
264 | 12: org.armedbear.lisp.LispReader$6.execute(LispReader.java:130) |
---|
265 | 13: org.armedbear.lisp.Stream.processChar(Stream.java:588) |
---|
266 | 14: org.armedbear.lisp.Stream.readList(Stream.java:755) |
---|
267 | 15: org.armedbear.lisp.LispReader$3.execute(LispReader.java:88) |
---|
268 | 16: org.armedbear.lisp.Stream.processChar(Stream.java:588) |
---|
269 | 17: org.armedbear.lisp.Stream.readPreservingWhitespace(Stream.java:557) |
---|
270 | 18: org.armedbear.lisp.Stream.readPreservingWhitespace(Stream.java:566) |
---|
271 | 19: org.armedbear.lisp.Stream.read(Stream.java:501) |
---|
272 | above here is ok |
---|
273 | |
---|
274 | below here junk |
---|
275 | 20: org.armedbear.lisp.Stream$16.execute(Stream.java:2436) |
---|
276 | 21: org.armedbear.lisp.Symbol.execute(Symbol.java:826) |
---|
277 | 22: org.armedbear.lisp.LispThread.execute(LispThread.java:851) |
---|
278 | 23: org.armedbear.lisp.swank_528.execute(swank.lisp:1732) |
---|
279 | 24: org.armedbear.lisp.Symbol.execute(Symbol.java:803) |
---|
280 | 25: org.armedbear.lisp.LispThread.execute(LispThread.java:814) |
---|
281 | 26: org.armedbear.lisp.swank_repl_47.execute(swank-repl.lisp:270) |
---|
282 | 27: org.armedbear.lisp.LispThread.execute(LispThread.java:798) |
---|
283 | 28: org.armedbear.lisp.swank_repl_48.execute(swank-repl.lisp:283) |
---|
284 | 29: org.armedbear.lisp.Symbol.execute(Symbol.java:803) |
---|
285 | 30: org.armedbear.lisp.LispThread.execute(LispThread.java:814) |
---|
286 | 31: org.armedbear.lisp.swank_repl_46.execute(swank-repl.lisp:270) |
---|
287 | 32: org.armedbear.lisp.LispThread.execute(LispThread.java:798) |
---|
288 | 33: org.armedbear.lisp.swank_272.execute(swank.lisp:490) |
---|
289 | 34: org.armedbear.lisp.Symbol.execute(Symbol.java:814) |
---|
290 | 35: org.armedbear.lisp.LispThread.execute(LispThread.java:832) |
---|
291 | 36: org.armedbear.lisp.swank_repl_45.execute(swank-repl.lisp:270) |
---|
292 | 37: org.armedbear.lisp.LispThread.execute(LispThread.java:798) |
---|
293 | 38: abcl_fcbf3596_211f_4d83_bc8b_e11e207b8d21.execute(Unknown Source) |
---|
294 | 39: org.armedbear.lisp.LispThread.execute(LispThread.java:814) |
---|
295 | 40: org.armedbear.lisp.Lisp.funcall(Lisp.java:172) |
---|
296 | 41: org.armedbear.lisp.Primitives$pf_apply.execute(Primitives.java:2827) |
---|
297 | end junk |
---|
298 | |
---|
299 | 42: (read #S(system::string-input-stream) nil #S(system::string-input-stream)) |
---|
300 | 43: (swank::eval-region "(#\"setLambdaName\" #<g466140 {168C36ED}> '(flet a))\n") |
---|
301 | 44: (#<local-function in repl-eval {B47713B}>) |
---|
302 | |
---|
303 | |
---|
304 | |
---|
305 | From a compiled function looks different |
---|
306 | 0: (error #<reader-error {7ED23D2A}>) |
---|
307 | 1: (#<local-function in eval-region {3FBB9CBD}> #<reader-error {7ED23D2A}>) |
---|
308 | 2: (signal #<reader-error {7ED23D2A}>) |
---|
309 | 3: org.armedbear.lisp.Lisp.error(Lisp.java:385) |
---|
310 | 4: org.armedbear.lisp.LispReader$22.execute(LispReader.java:350) |
---|
311 | 5: org.armedbear.lisp.Stream.readDispatchChar(Stream.java:813) |
---|
312 | 6: org.armedbear.lisp.LispReader$6.execute(LispReader.java:130) |
---|
313 | 7: org.armedbear.lisp.Stream.processChar(Stream.java:588) |
---|
314 | 8: org.armedbear.lisp.Stream.readList(Stream.java:755) |
---|
315 | 9: org.armedbear.lisp.LispReader$3.execute(LispReader.java:88) |
---|
316 | 10: org.armedbear.lisp.Stream.processChar(Stream.java:588) |
---|
317 | 11: org.armedbear.lisp.Stream.readPreservingWhitespace(Stream.java:557) |
---|
318 | 12: org.armedbear.lisp.Stream.readPreservingWhitespace(Stream.java:566) |
---|
319 | 13: org.armedbear.lisp.Stream.read(Stream.java:501) <- this is probably where we want the stack to stop. |
---|
320 | |
---|
321 | Looks like symbol.execute |
---|
322 | 14: org.armedbear.lisp.Stream$15.execute(Stream.java:2387) <= %read from string |
---|
323 | 15: org.armedbear.lisp.Symbol.execute(Symbol.java:867) |
---|
324 | 16: org.armedbear.lisp.LispThread.execute(LispThread.java:918) |
---|
325 | 17: org.armedbear.lisp.read_from_string_1.execute(read-from-string.lisp:33) |
---|
326 | 18: org.armedbear.lisp.CompiledClosure.execute(CompiledClosure.java:98) |
---|
327 | 19: org.armedbear.lisp.Symbol.execute(Symbol.java:803) |
---|
328 | 20: org.armedbear.lisp.LispThread.execute(LispThread.java:814) |
---|
329 | 21: abcl_2ad63c53_52f1_460b_91c2_1b153251d9f3.execute(Unknown Source) |
---|
330 | 22: org.armedbear.lisp.LispThread.execute(LispThread.java:798) |
---|
331 | 23: org.armedbear.lisp.Lisp.evalCall(Lisp.java:572) |
---|
332 | 24: org.armedbear.lisp.Lisp.eval(Lisp.java:543) |
---|
333 | 25: org.armedbear.lisp.Primitives$pf__eval.execute(Primitives.java:345) |
---|
334 | 26: (system::%read-from-string "(#\"setLambdaName\" #<g466140 {168C36ED}> '(flet a))" t nil 0 nil nil) |
---|
335 | 27: (read-from-string "(#\"setLambdaName\" #<g466140 {168C36ED}> '(flet a))") |
---|
336 | 28: (system::bar) |
---|
337 | |
---|
338 | |# |
---|
339 | |
---|
340 | |
---|
341 | #| |
---|
342 | Don't really want 456. Ban them outright? No - make a list |
---|
343 | 4: sun.reflect.NativeMethodAccessorImpl.invoke0(Native Method) |
---|
344 | 5: sun.reflect.NativeMethodAccessorImpl.invoke(NativeMethodAccessorImpl.java:62) |
---|
345 | 6: sun.reflect.DelegatingMethodAccessorImpl.invoke(DelegatingMethodAccessorImpl.java:43) |
---|
346 | 7: java.lang.reflect.Method.invoke(Method.java:497) |
---|
347 | |# |
---|
348 | |
---|
349 | ;; (#"setLambdaName" #<g466140 {168C36ED}> '(flet a)) |
---|
350 | ;; reader error is still ugly. Maybe anything that calls signal. |
---|
351 | |
---|
352 | (provide :stacktrace) |
---|