/src/debug-utils.lisp

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