source: tags/1.5.0/contrib/abcl-introspect/stacktrace.lisp

Last change on this file was 14965, checked in by Mark Evenson, 9 years ago

abcl-introspect: further fixes for stacktrace (Alan Ruttenberg)

Fixes another attempt at accessing package name of nonexistent
package.

Merges <​https://github.com/armedbear/abcl/pull/34>.
File size: 16.1 KB
Line 
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
245caused by reader-error
246
247Checking for execute isn't enough.
248Symbol.execute might be good
249
250So maybe modify:
251Find invoke-debugger position
252go down stack until you reach a symbol.execute, then skip rest of string of java frames.
253
254Right 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}>)
257below 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)
272above here is ok
273
274below 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)
297end 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
305From 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
321Looks 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#|
342Don'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)
Note: See TracBrowser for help on using the repository browser.