Skip to content
Snippets Groups Projects
Commit 2a0126a7 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Improve various backtrace implementations.

parent ff8e9287
No related branches found
No related tags found
No related merge requests found
...@@ -33,9 +33,9 @@ Some constraints: ...@@ -33,9 +33,9 @@ Some constraints:
(in-package :asdf-test) (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))) #+(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))) #+(or cmu scl) (c::brevity 2) #+(or cmu scl) (ext:inhibit-warnings 3)))
(defvar *trace-symbols* (defvar *trace-symbols*
......
...@@ -90,13 +90,13 @@ This is designed to abstract away the implementation specific quit forms." ...@@ -90,13 +90,13 @@ This is designed to abstract away the implementation specific quit forms."
(format! *stderr* "~&~?~&" format arguments))) (format! *stderr* "~&~?~&" format arguments)))
(quit code)) (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" "Print a backtrace, directly accessing the implementation"
(declare (ignorable stream count)) (declare (ignorable stream count condition))
#+(or abcl xcl) #+abcl
(loop :for i :from 0 (loop :for i :from 0
:for frame :in #+abcl (sys:backtrace) #+xcl (extensions:backtrace-as-list) :do :for frame :in (sys:backtrace (or count most-positive-fixnum)) :do
(safe-format! stream "~&~D: ~S~%" i frame)) (safe-format! stream "~&~D: ~A~%" i frame))
#+allegro #+allegro
(let ((*terminal-io* stream) (let ((*terminal-io* stream)
(*standard-output* stream) (*standard-output* stream)
...@@ -105,7 +105,7 @@ This is designed to abstract away the implementation specific quit forms." ...@@ -105,7 +105,7 @@ This is designed to abstract away the implementation specific quit forms."
(tpl:*zoom-print-length* *print-length*)) (tpl:*zoom-print-length* *print-length*))
(tpl:do-command "zoom" (tpl:do-command "zoom"
:from-read-eval-print-loop nil :from-read-eval-print-loop nil
:count t :count (or count t)
:all t)) :all t))
#+clisp #+clisp
(system::print-backtrace :out stream :limit count) (system::print-backtrace :out stream :limit count)
...@@ -117,15 +117,23 @@ This is designed to abstract away the implementation specific quit forms." ...@@ -117,15 +117,23 @@ This is designed to abstract away the implementation specific quit forms."
#+(or cmu scl) #+(or cmu scl)
(let ((debug:*debug-print-level* *print-level*) (let ((debug:*debug-print-level* *print-level*)
(debug:*debug-print-length* *print-length*)) (debug:*debug-print-length* *print-length*))
(debug:backtrace most-positive-fixnum stream)) (debug:backtrace (or count most-positive-fixnum) stream))
#+ecl #+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) :collect (list (si::ihs-fun ihs)
(si::ihs-env 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 #+gcl
(let ((*debug-io* stream)) (let ((*debug-io* stream))
(system::simple-backtrace)) (ignore-errors
(with-safe-io-syntax ()
(if condition
(conditions::condition-backtrace condition)
(system::simple-backtrace)))))
#+lispworks #+lispworks
(let ((dbg::*debugger-stack* (let ((dbg::*debugger-stack*
(dbg::grab-stack nil :how-many (or count most-positive-fixnum))) (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." ...@@ -136,11 +144,15 @@ This is designed to abstract away the implementation specific quit forms."
#+sbcl #+sbcl
(sb-debug:backtrace (sb-debug:backtrace
#.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream '(or count most-positive-fixnum)) #.(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" "Print a backtrace"
(declare (ignore stream count)) (declare (ignore stream count condition))
(with-safe-io-syntax (:package :cl) (with-safe-io-syntax (:package :cl)
(let ((*print-readably* nil) (let ((*print-readably* nil)
(*print-circle* t) (*print-circle* t)
...@@ -155,7 +167,7 @@ This is designed to abstract away the implementation specific quit forms." ...@@ -155,7 +167,7 @@ This is designed to abstract away the implementation specific quit forms."
;; We print the condition *after* the backtrace, ;; We print the condition *after* the backtrace,
;; for the sake of who sees the backtrace at a terminal. ;; 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. ;; 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 (when condition
(safe-format! stream "~&Above backtrace due to this condition:~%~A~&" (safe-format! stream "~&Above backtrace due to this condition:~%~A~&"
condition))) condition)))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment