abcl-introspect.stacktrace.lisp Maven / Gradle / Ivy
Go to download
Show more of this group Show more artifacts with this name
Show all versions of abcl-contrib Show documentation
Show all versions of abcl-contrib Show documentation
Extra contributions for ABCL code not necessarily
licensed under the GPLv2 with classpath exception.
The newest version!
(in-package :system)
(require :jss) ;; for now
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; I don't understand the algorithm that sys:backtrace uses, which seems
;; broken, so here's an alternative.
;; The lisp portion of the stack backtrace is computed as it is now. It
;; will have invoke-debugger at the top then some java stack frames that
;; abcl pushes (the "i don't understand") and then the rest of the
;; backtrace. We trim that by popping off the invoke-debugger and java
;; stack frames, leaving just lisp frames.
;; If there's a java exception. In that case we compare the stacktrace of
;; the exception to the java stack trace and grab the top part of it
;; that's unique to the exception. We prepend this to the lisp stack
;; trace.
;; The result will be that we will *not* see the call to invoke debugger,
;; or any of the swank handling, just what (I think) is relative.
;; What still needs to be investigated is how this plays in cases where
;; there are callbacks to lisp from java.
;; A good test to see the difference would be
;; (#"replaceAll" "" "(?o" "")
;; which should now show the calls within the regex code leading to
;; the exception.
(defvar *use-old-backtrace* nil "set to t to fall back to the standard backtrace")
(defvar *hide-swank-frames* t "set to nil if you want to see debugger internal frames")
(defvar *unwelcome-java-frames*
'("sun.reflect.Native.*AccessorImpl\\..*"
"sun.reflect.Delegating.*AccessorImpl\\..*"
"sun.reflect.Generated.*Accessor\\d+\\.invoke")
"if a java frame matches any of these patterns, don't show it"
)
(defvar *caught-frames* nil "When backtrace is called, it sets this to
the java stack frames that are unique to the java exception, which is
then subsequently used by slime to mark them")
(defun swankish-frame (frame)
"hackish test for whether a frame is some internal function from swank"
(let ((el (car (sys::frame-to-list frame))))
(let ((package
(cond ((and (symbolp el)
(symbol-package el))
(package-name (symbol-package el)))
;; hack! really I mean anything with a function plist
((eq (type-of el) 'compiled-function)
(let ((owner (getf (function-plist el) :internal-to-function)))
(if (and (symbolp owner)
(symbol-package owner))
(package-name
(symbol-package owner))
"")))
(t ""))))
(and package (#"matches" package "SWANK.*")))))
(defun javaframe (java-stack-frame)
"Return the java StackFrame instance"
(if (java::java-object-p java-stack-frame)
java-stack-frame
(#"get" (load-time-value (java::jclass-field "org.armedbear.lisp.JavaStackFrame" "javaFrame")) java-stack-frame)))
(defun stackframe-head (frame &optional with-method)
"If a lisp frame, the function (symbol or function). In a java frame the class name, with method if with-method is t"
(if (null frame)
nil
(if (typep frame 'lisp-stack-frame)
(#"getOperator" frame)
(let ((frame (if (typep frame 'java-stack-frame) (javaframe frame) frame)))
(if with-method
(concatenate 'string (#"getClassName" frame) "." (#"getMethodName" frame))
(#"getClassName" frame))))))
(defun backtrace-invoke-debugger-position (stacktrace)
"Position of the call to invoke-debugger"
(let ((looking-for `(invoke-debugger ,#'invoke-debugger)))
(position-if (lambda(e) (memq (#"getOperator" e) looking-for)) stacktrace)))
(defun swank-p ()
"are we running with slime/swank? This should work without swank too"
(find-package 'swank))
(defun repl-loop-position (stacktrace start)
"Position of the frame starting the repl at this level"
(if (swank-p)
(position-if (lambda(e) (eq (stackframe-head e) (intern "SLDB-LOOP" 'swank))) stacktrace :start start)
(position-if (lambda(e) (eq (stackframe-head e) 'debug-loop)) stacktrace :start start)
))
(defun last-internal-calls-position (stacktrace)
"Some java frames are replicates of the lisp stack frame. This gets
the position of the closest to top non-user lisp call. It should leave
intact frames corresponding to cases where a piece of lisp implemented
in java calls another lisp function"
(let ((pos (position-if (lambda(e)
(and (not (typep e 'lisp-stack-frame))
(not (member (#"getMethodName" (javaframe e)) '("execute" "evalCall" "eval" "funcall" "apply") :test 'equal))))
stacktrace :from-end t)))
pos))
(defun java-frame-segment (stacktrace)
"Returns the bounds of the section of the backtrace that have been added with pushJavaStackFrame"
(let ((start (position-if (lambda(e) (typep e 'java-stack-frame)) stacktrace)))
(and start (list start (position-if (lambda(e) (typep e 'lisp-stack-frame)) stacktrace :start start)))))
(defun splice-out (sequence from to)
"remove elements from->to from sequence"
(append (subseq sequence 0 from) (subseq sequence to)))
(defun splice-out-java-stack-duplicating-lisp-stack (stacktrace)
"cut out a section of java frames, maximally ending at the first lisp stack frame hit"
(let ((extra-java-frames-pos (last-internal-calls-position stacktrace)))
(let ((spliced
(if extra-java-frames-pos
(append (subseq stacktrace 0 extra-java-frames-pos)
(let ((lisp-frame-pos (position 'lisp-stack-frame stacktrace :key 'type-of :start extra-java-frames-pos)))
(and lisp-frame-pos
(subseq stacktrace
(position 'lisp-stack-frame stacktrace :key 'type-of :start extra-java-frames-pos)))))
stacktrace)))
spliced)))
(defun difference-between-exception-stacktrace-and-after-caught-stacktrace (condition)
"When there's a java exception, the condition has the stack trace as
it was when the exception was thrown. Our backtrace is after it is
caught. This function gets the difference - the frames unique to the
exception"
(let* ((exception-stack-trace (coerce (#"getStackTrace" (java::java-exception-cause condition)) 'list))
(debugger-stack-trace
(coerce (subseq exception-stack-trace
(position (#"getName" (#"getClass" #'invoke-debugger))
(#"getStackTrace" (#"currentThread" 'Thread))
:key #"getClassName"
:test 'string-equal))
'list)))
(subseq exception-stack-trace
0 (position-if (lambda(frame) (find frame debugger-stack-trace :test (lambda(a b ) (eql (#"hashCode" a) (#"hashCode" b)))))
exception-stack-trace))))
(defun remove-unsightly-java-frames (stacktrace)
"Remove uninformative java frames, typically bits of the internals of the java implementation"
(remove-if (lambda(frame)
(member (stackframe-head frame t) *unwelcome-java-frames* :test #"matches"))
stacktrace))
;; 3: (invoke-debugger #)
;; 4: org.armedbear.lisp.Lisp.error(Lisp.java:385)
;; 5: (invoke-debugger #)
;; 6: (error #)
;; 7: (# #)
;; 8: (signal #)
;; 9: org.armedbear.lisp.Lisp.error(Lisp.java:385)
(defun lisp-stack-exception-catching-frames (stacktrace)
"The frames corresponding to ABCL's internal handling of an exception"
(and (eq (stackframe-head (car stacktrace)) 'invoke-debugger)
(let ((error-position (position "org.armedbear.lisp.Lisp.error" stacktrace
:key (lambda(e) (stackframe-head e t))
:test 'equal)))
(if error-position
(subseq stacktrace 0 (1+ error-position))
(list (car stacktrace))
))))
(defun splice-out-spurious-error-frames (stacktrace)
"if there are nested exceptions sometimes there are extra (error),
, (signal) frames. we only want the first error. Remove
repeated ones. Illiustrated by first getting an errors with an
inconsistent ontology and then calling (read-from-string \"#<\") to
generate a reader error. Get rid of these. Finally, if the next
next frame after error is signal of the same condition, those two
frames are also removed"
(let ((error-position (position 'error stacktrace :key 'stackframe-head)))
(if (and error-position (> (length stacktrace) (+ error-position 3)))
(loop with trash = 0
for pos = error-position then next
for next = (+ pos 3)
until (not (eq (stackframe-head (nth next stacktrace)) 'error))
do (incf trash 3)
finally (return
(let ((spliced (if (> trash 1)
(splice-out stacktrace (1+ error-position) (+ error-position trash 1))
stacktrace)))
(if (and (eq (stackframe-head (nth (+ error-position 2) spliced)) 'signal)
(eq (second (frame-to-list (nth error-position spliced)))
(second (frame-to-list (nth (+ error-position 2) spliced)))))
(splice-out spliced (1+ error-position) (+ error-position 3))
stacktrace))))
stacktrace)))
(defun new-backtrace (condition)
"New implementation of backtrace that tries to clean up the stack
trace shown when an error occurs. There are a bunch of
idiosyncrasies of what sys:backtrace generates which land up
obscuring what the problem is, or at least making it more of a hunt
than one would want. This backtrace tries to show only stuff I think
matters - user function calls and, when there's an exception, calls
inside the lisp implementation leading to the error"
(if *use-old-backtrace*
(backtrace)
(let* ((lisp-stacktrace (#"backtrace" (threads:current-thread) 0))
(invoke-pos (backtrace-invoke-debugger-position lisp-stacktrace))
(repl-loop-pos (repl-loop-position lisp-stacktrace invoke-pos)))
(let ((narrowed-lisp-stacktrace
(splice-out-java-stack-duplicating-lisp-stack
(subseq lisp-stacktrace invoke-pos (and repl-loop-pos (1+ repl-loop-pos))))))
(when *hide-swank-frames*
(let ((swank-start (position-if 'swankish-frame narrowed-lisp-stacktrace)))
(and swank-start
(setq narrowed-lisp-stacktrace
(append
(subseq narrowed-lisp-stacktrace 0 swank-start)
(if repl-loop-pos (last narrowed-lisp-stacktrace) nil))))))
(setq narrowed-lisp-stacktrace (splice-out-spurious-error-frames narrowed-lisp-stacktrace))
(if (typep condition 'java:java-exception)
(progn
(let* ((delta (difference-between-exception-stacktrace-and-after-caught-stacktrace condition))
(cleaned (splice-out-java-stack-duplicating-lisp-stack (remove-unsightly-java-frames delta)))
(exception-frames (lisp-stack-exception-catching-frames narrowed-lisp-stacktrace)))
(setq *caught-frames* delta)
(let ((result (append exception-frames
(mapcar
(lambda (frame) (java:jnew "org.armedbear.lisp.JavaStackFrame"
frame))
cleaned)
(subseq narrowed-lisp-stacktrace (length exception-frames)))))
result
)))
narrowed-lisp-stacktrace)))))
#|
(defmethod ho ((a t)) (read-from-string "(#\"setLambdaName\" # '(flet a))"))
(defmethod no ((a t)) (read-from-string "(#\"setLambdaName\" # '(flet a))"))
(defmethod fo () (ho 1) (no 1))
(defun bar () (fo))
(defun foo () (funcall #'bar))
(defun baz () (foo))
caused by reader-error
Checking for execute isn't enough.
Symbol.execute might be good
So maybe modify:
Find invoke-debugger position
go down stack until you reach a symbol.execute, then skip rest of string of java frames.
Right now I skip from invoke-debugger to next list but because signal is there it gets stuck.
5: (invoke-debugger #)
below here ok
6: (error #)
7: (# #)
8: (signal #)
9: org.armedbear.lisp.Lisp.error(Lisp.java:385)
10: org.armedbear.lisp.LispReader$22.execute(LispReader.java:350)
11: org.armedbear.lisp.Stream.readDispatchChar(Stream.java:813)
12: org.armedbear.lisp.LispReader$6.execute(LispReader.java:130)
13: org.armedbear.lisp.Stream.processChar(Stream.java:588)
14: org.armedbear.lisp.Stream.readList(Stream.java:755)
15: org.armedbear.lisp.LispReader$3.execute(LispReader.java:88)
16: org.armedbear.lisp.Stream.processChar(Stream.java:588)
17: org.armedbear.lisp.Stream.readPreservingWhitespace(Stream.java:557)
18: org.armedbear.lisp.Stream.readPreservingWhitespace(Stream.java:566)
19: org.armedbear.lisp.Stream.read(Stream.java:501)
above here is ok
below here junk
20: org.armedbear.lisp.Stream$16.execute(Stream.java:2436)
21: org.armedbear.lisp.Symbol.execute(Symbol.java:826)
22: org.armedbear.lisp.LispThread.execute(LispThread.java:851)
23: org.armedbear.lisp.swank_528.execute(swank.lisp:1732)
24: org.armedbear.lisp.Symbol.execute(Symbol.java:803)
25: org.armedbear.lisp.LispThread.execute(LispThread.java:814)
26: org.armedbear.lisp.swank_repl_47.execute(swank-repl.lisp:270)
27: org.armedbear.lisp.LispThread.execute(LispThread.java:798)
28: org.armedbear.lisp.swank_repl_48.execute(swank-repl.lisp:283)
29: org.armedbear.lisp.Symbol.execute(Symbol.java:803)
30: org.armedbear.lisp.LispThread.execute(LispThread.java:814)
31: org.armedbear.lisp.swank_repl_46.execute(swank-repl.lisp:270)
32: org.armedbear.lisp.LispThread.execute(LispThread.java:798)
33: org.armedbear.lisp.swank_272.execute(swank.lisp:490)
34: org.armedbear.lisp.Symbol.execute(Symbol.java:814)
35: org.armedbear.lisp.LispThread.execute(LispThread.java:832)
36: org.armedbear.lisp.swank_repl_45.execute(swank-repl.lisp:270)
37: org.armedbear.lisp.LispThread.execute(LispThread.java:798)
38: abcl_fcbf3596_211f_4d83_bc8b_e11e207b8d21.execute(Unknown Source)
39: org.armedbear.lisp.LispThread.execute(LispThread.java:814)
40: org.armedbear.lisp.Lisp.funcall(Lisp.java:172)
41: org.armedbear.lisp.Primitives$pf_apply.execute(Primitives.java:2827)
end junk
42: (read #S(system::string-input-stream) nil #S(system::string-input-stream))
43: (swank::eval-region "(#\"setLambdaName\" # '(flet a))\n")
44: (#)
From a compiled function looks different
0: (error #)
1: (# #)
2: (signal #)
3: org.armedbear.lisp.Lisp.error(Lisp.java:385)
4: org.armedbear.lisp.LispReader$22.execute(LispReader.java:350)
5: org.armedbear.lisp.Stream.readDispatchChar(Stream.java:813)
6: org.armedbear.lisp.LispReader$6.execute(LispReader.java:130)
7: org.armedbear.lisp.Stream.processChar(Stream.java:588)
8: org.armedbear.lisp.Stream.readList(Stream.java:755)
9: org.armedbear.lisp.LispReader$3.execute(LispReader.java:88)
10: org.armedbear.lisp.Stream.processChar(Stream.java:588)
11: org.armedbear.lisp.Stream.readPreservingWhitespace(Stream.java:557)
12: org.armedbear.lisp.Stream.readPreservingWhitespace(Stream.java:566)
13: org.armedbear.lisp.Stream.read(Stream.java:501) <- this is probably where we want the stack to stop.
Looks like symbol.execute
14: org.armedbear.lisp.Stream$15.execute(Stream.java:2387) <= %read from string
15: org.armedbear.lisp.Symbol.execute(Symbol.java:867)
16: org.armedbear.lisp.LispThread.execute(LispThread.java:918)
17: org.armedbear.lisp.read_from_string_1.execute(read-from-string.lisp:33)
18: org.armedbear.lisp.CompiledClosure.execute(CompiledClosure.java:98)
19: org.armedbear.lisp.Symbol.execute(Symbol.java:803)
20: org.armedbear.lisp.LispThread.execute(LispThread.java:814)
21: abcl_2ad63c53_52f1_460b_91c2_1b153251d9f3.execute(Unknown Source)
22: org.armedbear.lisp.LispThread.execute(LispThread.java:798)
23: org.armedbear.lisp.Lisp.evalCall(Lisp.java:572)
24: org.armedbear.lisp.Lisp.eval(Lisp.java:543)
25: org.armedbear.lisp.Primitives$pf__eval.execute(Primitives.java:345)
26: (system::%read-from-string "(#\"setLambdaName\" # '(flet a))" t nil 0 nil nil)
27: (read-from-string "(#\"setLambdaName\" # '(flet a))")
28: (system::bar)
|#
#|
Don't really want 456. Ban them outright? No - make a list
4: sun.reflect.NativeMethodAccessorImpl.invoke0(Native Method)
5: sun.reflect.NativeMethodAccessorImpl.invoke(NativeMethodAccessorImpl.java:62)
6: sun.reflect.DelegatingMethodAccessorImpl.invoke(DelegatingMethodAccessorImpl.java:43)
7: java.lang.reflect.Method.invoke(Method.java:497)
|#
;; (#"setLambdaName" # '(flet a))
;; reader error is still ugly. Maybe anything that calls signal.
(provide :stacktrace)
© 2015 - 2025 Weber Informatics LLC | Privacy Policy