source: trunk/abcl/contrib/abcl-introspect/stacktrace.lisp

Last change on this file was 15632, checked in by Mark Evenson, 15 months ago

abcl-introspect: scope JavaStackFrame? reference

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