/src/debug-utils.lisp

http://github.com/mtravers/wuwei · Lisp · 106 lines · 74 code · 14 blank · 18 comment · 1 complexity · 7ce7f6cb69a551fb3ccfd41f8bd85f30 MD5 · raw file

  1. (in-package :wuwei)
  2. #|
  3. Borrowed from BioBike
  4. |#
  5. ;;; This also works: (top-level.debug:zoom *standard-output*)
  6. ;;; Used to use functions in debug: package, appears to have changed
  7. #+:allegro
  8. (defun get-frames-list ()
  9. (let ((*terminal-io* excl::*null-stream*)
  10. prev cur lis old frames-before-error)
  11. ;; This isn't supposed to be able to error out, but in
  12. ;; a weird case that seems like every other error to us, but
  13. ;; must be different somehow, this function errors out
  14. ;; calling DEBUG:FRAME-EXPRESSION on CUR in the second loop,
  15. ;; generating a `NIL' is not of the expected type `REAL' error.
  16. ;; This unexpected signaling of an error was masking the real
  17. ;; error we are trying to get information on and report.
  18. ;; The only solution I could come up with was to trap this
  19. ;; bizarre error signal and ignore it. The only effect doing this
  20. ;; has is that when this bizarre error occurs, typing (explain)
  21. ;; at the weblistener won't get you any stack listing.
  22. (handler-case
  23. (progn
  24. (setq prev (excl::int-newest-frame))
  25. (setq old (excl::int-oldest-frame))
  26. (loop
  27. (setq cur (excl::int-next-older-frame prev))
  28. (when (null cur)
  29. (return-from get-frames-list (nreverse frames-before-error)))
  30. (push (debug:frame-expression cur) frames-before-error)
  31. (when (eq 'error (car (debug:frame-expression cur)))
  32. (setq prev cur) (return))
  33. (setq prev cur))
  34. (loop
  35. (setq cur (excl::int-next-older-frame prev))
  36. ;; We want to see every frame and make a decision ourselves.
  37. (if t ;(excl::int-frame-visible-p cur)
  38. (push (debug:frame-expression cur) lis))
  39. (if (excl::int-frame-reference-eq cur old)
  40. (return))
  41. (setq prev cur))
  42. )
  43. (error () (setq lis nil))
  44. )
  45. (nreverse lis)))
  46. (defparameter *stack-frame-limit* 30)
  47. #+:ccl
  48. (defun get-frames-list ()
  49. ;; discard uninteresting get-frames-list frame
  50. (cdr (ccl::backtrace-as-list :count *stack-frame-limit*)))
  51. #+:sbcl
  52. (defun get-frames-list ()
  53. (sb-debug::backtrace-as-list *stack-frame-limit*))
  54. #-(or :ccl :sbcl :allegro)
  55. (defun get-frames-list ()
  56. nil)
  57. (defun dump-stack (&optional (stream *standard-output*))
  58. (loop for frame in (get-frames-list) do
  59. (format stream " ~a~%" frame)))
  60. (defun stack-trace ()
  61. (with-output-to-string (s)
  62. (dump-stack s)))
  63. (defmacro logging-errors (&body body)
  64. `(restart-case
  65. (handler-bind
  66. ((condition #'(lambda (c)
  67. (invoke-restart 'total-lossage c (stack-trace)))))
  68. ,@body
  69. )
  70. (total-lossage (c trace)
  71. (format t "~%Pretending to log ~a~%~a~%" c trace)
  72. )
  73. )
  74. )
  75. (defmacro without-unwinding-restart ((restart &rest args) &body body)
  76. `(restart-case
  77. (handler-bind
  78. ((serious-condition
  79. #'(lambda (c)
  80. (if *developer-mode*
  81. (signal c) ;rethrow if dev mode
  82. (progn
  83. (ignore-errors (format t "~a ~a~%" (net.aserve::universal-time-to-date (get-universal-time)) c))
  84. (dump-stack)
  85. (invoke-restart 'total-lossage c (stack-trace)))))))
  86. ,@body
  87. )
  88. (total-lossage (c stack-trace)
  89. (ignore-errors (,restart ,@args :error c :stack-trace stack-trace))
  90. )
  91. )
  92. )