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 (subseq lisp-stacktrace invoke-pos (and repl-loop-pos (1+ repl-loop-pos)))))) 217 (when *hide-swank-frames* 218 (let ((swank-start (position-if 'swankish-frame narrowed-lisp-stacktrace))) 219 (and swank-start 220 (setq narrowed-lisp-stacktrace 221 (append 222 (subseq narrowed-lisp-stacktrace 0 swank-start) 223 (if repl-loop-pos (last narrowed-lisp-stacktrace) nil)))))) 224 (setq narrowed-lisp-stacktrace (splice-out-spurious-error-frames narrowed-lisp-stacktrace)) 225 (if (typep condition 'java::java-exception) 226 (progn 227 (let* ((delta (difference-between-exception-stacktrace-and-after-caught-stacktrace condition)) 228 (cleaned (splice-out-java-stack-duplicating-lisp-stack (remove-unsightly-java-frames delta))) 229 (exception-frames (lisp-stack-exception-catching-frames narrowed-lisp-stacktrace))) 230 (setq *caught-frames* delta) 231 (let ((result (append exception-frames 232 (mapcar (lambda(frame) (jss::new 'javastackframe frame)) cleaned) 233 (subseq narrowed-lisp-stacktrace (length exception-frames))))) 234 result 235 ))) 236 narrowed-lisp-stacktrace))))) 237 238#| 239(defmethod ho ((a t)) (read-from-string "(#\"setLambdaName\" #<g466140 {168C36ED}> '(flet a))")) 240(defmethod no ((a t)) (read-from-string "(#\"setLambdaName\" #<g466140 {168C36ED}> '(flet a))")) 241(defmethod fo () (ho 1) (no 1)) 242(defun bar () (fo)) 243(defun foo () (funcall #'bar)) 244(defun baz () (foo)) 245 246 247caused by reader-error 248 249Checking for execute isn't enough. 250Symbol.execute might be good 251 252So maybe modify: 253Find invoke-debugger position 254go down stack until you reach a symbol.execute, then skip rest of string of java frames. 255 256Right now I skip from invoke-debugger to next list but because signal is there it gets stuck. 257 258 5: (invoke-debugger #<reader-error {4BFF7154}>) 259below here ok 260 6: (error #<reader-error {4BFF7154}>) 261 7: (#<local-function in eval-region {AC27B6F}> #<reader-error {4BFF7154}>) 262 8: (signal #<reader-error {4BFF7154}>) 263 9: org.armedbear.lisp.Lisp.error(Lisp.java:385) 264 10: org.armedbear.lisp.LispReader$22.execute(LispReader.java:350) 265 11: org.armedbear.lisp.Stream.readDispatchChar(Stream.java:813) 266 12: org.armedbear.lisp.LispReader$6.execute(LispReader.java:130) 267 13: org.armedbear.lisp.Stream.processChar(Stream.java:588) 268 14: org.armedbear.lisp.Stream.readList(Stream.java:755) 269 15: org.armedbear.lisp.LispReader$3.execute(LispReader.java:88) 270 16: org.armedbear.lisp.Stream.processChar(Stream.java:588) 271 17: org.armedbear.lisp.Stream.readPreservingWhitespace(Stream.java:557) 272 18: org.armedbear.lisp.Stream.readPreservingWhitespace(Stream.java:566) 273 19: org.armedbear.lisp.Stream.read(Stream.java:501) 274above here is ok 275 276below here junk 277 20: org.armedbear.lisp.Stream$16.execute(Stream.java:2436) 278 21: org.armedbear.lisp.Symbol.execute(Symbol.java:826) 279 22: org.armedbear.lisp.LispThread.execute(LispThread.java:851) 280 23: org.armedbear.lisp.swank_528.execute(swank.lisp:1732) 281 24: org.armedbear.lisp.Symbol.execute(Symbol.java:803) 282 25: org.armedbear.lisp.LispThread.execute(LispThread.java:814) 283 26: org.armedbear.lisp.swank_repl_47.execute(swank-repl.lisp:270) 284 27: org.armedbear.lisp.LispThread.execute(LispThread.java:798) 285 28: org.armedbear.lisp.swank_repl_48.execute(swank-repl.lisp:283) 286 29: org.armedbear.lisp.Symbol.execute(Symbol.java:803) 287 30: org.armedbear.lisp.LispThread.execute(LispThread.java:814) 288 31: org.armedbear.lisp.swank_repl_46.execute(swank-repl.lisp:270) 289 32: org.armedbear.lisp.LispThread.execute(LispThread.java:798) 290 33: org.armedbear.lisp.swank_272.execute(swank.lisp:490) 291 34: org.armedbear.lisp.Symbol.execute(Symbol.java:814) 292 35: org.armedbear.lisp.LispThread.execute(LispThread.java:832) 293 36: org.armedbear.lisp.swank_repl_45.execute(swank-repl.lisp:270) 294 37: org.armedbear.lisp.LispThread.execute(LispThread.java:798) 295 38: abcl_fcbf3596_211f_4d83_bc8b_e11e207b8d21.execute(Unknown Source) 296 39: org.armedbear.lisp.LispThread.execute(LispThread.java:814) 297 40: org.armedbear.lisp.Lisp.funcall(Lisp.java:172) 298 41: org.armedbear.lisp.Primitives$pf_apply.execute(Primitives.java:2827) 299end junk 300 301 42: (read #S(system::string-input-stream) nil #S(system::string-input-stream)) 302 43: (swank::eval-region "(#\"setLambdaName\" #<g466140 {168C36ED}> '(flet a))\n") 303 44: (#<local-function in repl-eval {B47713B}>) 304 305 306 307From a compiled function looks different 308 0: (error #<reader-error {7ED23D2A}>) 309 1: (#<local-function in eval-region {3FBB9CBD}> #<reader-error {7ED23D2A}>) 310 2: (signal #<reader-error {7ED23D2A}>) 311 3: org.armedbear.lisp.Lisp.error(Lisp.java:385) 312 4: org.armedbear.lisp.LispReader$22.execute(LispReader.java:350) 313 5: org.armedbear.lisp.Stream.readDispatchChar(Stream.java:813) 314 6: org.armedbear.lisp.LispReader$6.execute(LispReader.java:130) 315 7: org.armedbear.lisp.Stream.processChar(Stream.java:588) 316 8: org.armedbear.lisp.Stream.readList(Stream.java:755) 317 9: org.armedbear.lisp.LispReader$3.execute(LispReader.java:88) 318 10: org.armedbear.lisp.Stream.processChar(Stream.java:588) 319 11: org.armedbear.lisp.Stream.readPreservingWhitespace(Stream.java:557) 320 12: org.armedbear.lisp.Stream.readPreservingWhitespace(Stream.java:566) 321 13: org.armedbear.lisp.Stream.read(Stream.java:501) <- this is probably where we want the stack to stop. 322 323Looks like symbol.execute 324 14: org.armedbear.lisp.Stream$15.execute(Stream.java:2387) <= %read from string 325 15: org.armedbear.lisp.Symbol.execute(Symbol.java:867) 326 16: org.armedbear.lisp.LispThread.execute(LispThread.java:918) 327 17: org.armedbear.lisp.read_from_string_1.execute(read-from-string.lisp:33) 328 18: org.armedbear.lisp.CompiledClosure.execute(CompiledClosure.java:98) 329 19: org.armedbear.lisp.Symbol.execute(Symbol.java:803) 330 20: org.armedbear.lisp.LispThread.execute(LispThread.java:814) 331 21: abcl_2ad63c53_52f1_460b_91c2_1b153251d9f3.execute(Unknown Source) 332 22: org.armedbear.lisp.LispThread.execute(LispThread.java:798) 333 23: org.armedbear.lisp.Lisp.evalCall(Lisp.java:572) 334 24: org.armedbear.lisp.Lisp.eval(Lisp.java:543) 335 25: org.armedbear.lisp.Primitives$pf__eval.execute(Primitives.java:345) 336 26: (system::%read-from-string "(#\"setLambdaName\" #<g466140 {168C36ED}> '(flet a))" t nil 0 nil nil) 337 27: (read-from-string "(#\"setLambdaName\" #<g466140 {168C36ED}> '(flet a))") 338 28: (system::bar) 339 340|# 341 342 343#| 344Don't really want 456. Ban them outright? No - make a list 345 4: sun.reflect.NativeMethodAccessorImpl.invoke0(Native Method) 346 5: sun.reflect.NativeMethodAccessorImpl.invoke(NativeMethodAccessorImpl.java:62) 347 6: sun.reflect.DelegatingMethodAccessorImpl.invoke(DelegatingMethodAccessorImpl.java:43) 348 7: java.lang.reflect.Method.invoke(Method.java:497) 349|# 350 351;; (#"setLambdaName" #<g466140 {168C36ED}> '(flet a)) 352;; reader error is still ugly. Maybe anything that calls signal. 353 354(provide :stacktrace) 355