From 2a0126a7c87b01184ab5a453b13f4c7ed89d8b23 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <tunes@google.com> Date: Fri, 20 Dec 2013 00:02:12 -0500 Subject: [PATCH] Improve various backtrace implementations. --- test/script-support.lisp | 4 ++-- uiop/image.lisp | 40 ++++++++++++++++++++++++++-------------- 2 files changed, 28 insertions(+), 16 deletions(-) diff --git a/test/script-support.lisp b/test/script-support.lisp index bc97bf6a4..c3e278769 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -33,9 +33,9 @@ Some constraints: (in-package :asdf-test) -(declaim (optimize (speed 2) (safety #-gcl 3 #+gcl 1) #-(or allegro gcl genera) (debug 3) +(declaim (optimize (speed 2) (safety #-gcl 3 #+gcl 0) #-(or allegro gcl genera) (debug 3) #+(or cmu scl) (c::brevity 2))) -(proclaim '(optimize (speed #-gcl 2 #+gcl 1) (safety #-gcl 3 #+gcl 1) #-(or allegro gcl genera) (debug 3) +(proclaim '(optimize (speed #-gcl 2 #+gcl 1) (safety #-gcl 3 #+gcl 0) #-(or allegro gcl genera) (debug 3) #+(or cmu scl) (c::brevity 2) #+(or cmu scl) (ext:inhibit-warnings 3))) (defvar *trace-symbols* diff --git a/uiop/image.lisp b/uiop/image.lisp index ace1df4ac..67a5d8c88 100644 --- a/uiop/image.lisp +++ b/uiop/image.lisp @@ -90,13 +90,13 @@ This is designed to abstract away the implementation specific quit forms." (format! *stderr* "~&~?~&" format arguments))) (quit code)) - (defun raw-print-backtrace (&key (stream *debug-io*) count) + (defun raw-print-backtrace (&key (stream *debug-io*) count condition) "Print a backtrace, directly accessing the implementation" - (declare (ignorable stream count)) - #+(or abcl xcl) + (declare (ignorable stream count condition)) + #+abcl (loop :for i :from 0 - :for frame :in #+abcl (sys:backtrace) #+xcl (extensions:backtrace-as-list) :do - (safe-format! stream "~&~D: ~S~%" i frame)) + :for frame :in (sys:backtrace (or count most-positive-fixnum)) :do + (safe-format! stream "~&~D: ~A~%" i frame)) #+allegro (let ((*terminal-io* stream) (*standard-output* stream) @@ -105,7 +105,7 @@ This is designed to abstract away the implementation specific quit forms." (tpl:*zoom-print-length* *print-length*)) (tpl:do-command "zoom" :from-read-eval-print-loop nil - :count t + :count (or count t) :all t)) #+clisp (system::print-backtrace :out stream :limit count) @@ -117,15 +117,23 @@ This is designed to abstract away the implementation specific quit forms." #+(or cmu scl) (let ((debug:*debug-print-level* *print-level*) (debug:*debug-print-length* *print-length*)) - (debug:backtrace most-positive-fixnum stream)) + (debug:backtrace (or count most-positive-fixnum) stream)) #+ecl - (let* ((backtrace (loop :for ihs :from 0 :below (si:ihs-top) + (let* ((top (si:ihs-top)) + (repeats (if count (min top count) top)) + (backtrace (loop :for ihs :from 0 :below top :collect (list (si::ihs-fun ihs) (si::ihs-env ihs))))) - (dolist (frame (nreverse backtrace)) (writeln frame :stream stream))) + (loop :for i :from 0 :below repeats + :for frame :in (nreverse backtrace) :do + (safe-format! stream "~&~D: ~S~%" i frame))) #+gcl (let ((*debug-io* stream)) - (system::simple-backtrace)) + (ignore-errors + (with-safe-io-syntax () + (if condition + (conditions::condition-backtrace condition) + (system::simple-backtrace))))) #+lispworks (let ((dbg::*debugger-stack* (dbg::grab-stack nil :how-many (or count most-positive-fixnum))) @@ -136,11 +144,15 @@ This is designed to abstract away the implementation specific quit forms." #+sbcl (sb-debug:backtrace #.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream '(or count most-positive-fixnum)) - stream)) + stream) + #+xcl + (loop :for i :from 0 + :for frame :in (extensions:backtrace-as-list) :do + (safe-format! stream "~&~D: ~S~%" i frame))) - (defun print-backtrace (&rest keys &key stream count) + (defun print-backtrace (&rest keys &key stream count condition) "Print a backtrace" - (declare (ignore stream count)) + (declare (ignore stream count condition)) (with-safe-io-syntax (:package :cl) (let ((*print-readably* nil) (*print-circle* t) @@ -155,7 +167,7 @@ This is designed to abstract away the implementation specific quit forms." ;; We print the condition *after* the backtrace, ;; for the sake of who sees the backtrace at a terminal. ;; It is up to the caller to print the condition *before*, with some context. - (print-backtrace :stream stream :count count) + (print-backtrace :stream stream :count count :condition condition) (when condition (safe-format! stream "~&Above backtrace due to this condition:~%~A~&" condition))) -- GitLab