[movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Mon Feb 28 16:15:58 UTC 2005
Update of /project/movitz/cvsroot/movitz/losp/x86-pc
In directory common-lisp.net:/tmp/cvs-serv15120
Modified Files:
debugger.lisp
Log Message:
Improved error-handling in backtrace.
Date: Mon Feb 28 17:15:55 2005
Author: ffjeld
Index: movitz/losp/x86-pc/debugger.lisp
diff -u movitz/losp/x86-pc/debugger.lisp:1.32 movitz/losp/x86-pc/debugger.lisp:1.33
--- movitz/losp/x86-pc/debugger.lisp:1.32 Wed Feb 2 11:23:07 2005
+++ movitz/losp/x86-pc/debugger.lisp Mon Feb 28 17:15:53 2005
@@ -10,7 +10,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef at acm.org>
;;;; Created at: Fri Nov 22 10:09:18 2002
;;;;
-;;;; $Id: debugger.lisp,v 1.32 2005/02/02 10:23:07 ffjeld Exp $
+;;;; $Id: debugger.lisp,v 1.33 2005/02/28 16:15:53 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -507,115 +507,102 @@
(format t "{< ~D}" (stack-frame-call-site stack frame)))
(when *backtrace-print-frames*
(format t "#x~X " frame))))
- (typecase funobj
- ((eql 0)
- (let ((eip (dit-frame-ref stack frame :eip :unsigned-byte32))
- (casf (dit-frame-casf stack frame)))
- (multiple-value-bind (function-name code-vector-offset)
- (let ((casf-funobj (stack-frame-funobj stack casf)))
- (cond
- ((eq 0 casf-funobj)
- (values 'default-interrupt-trampoline
- (code-vector-offset (symbol-value 'default-interrupt-trampoline)
- eip)))
- ((not (typep casf-funobj 'function))
- ;; Hm.. very suspicius
- (warn "Weird frame ~S" frame)
- (values nil))
- (t (let ((x (code-vector-offset (funobj-code-vector casf-funobj) eip)))
- (cond
- ((not (eq nil x))
- (values (funobj-name casf-funobj) x))
- ((not (logbitp 10 (dit-frame-ref stack frame :eflags :unsigned-byte16)))
- (let ((funobj2 (dit-frame-ref stack frame :esi :lisp)))
- (or (when (typep funobj2 'function)
- (let ((x (code-vector-offset (funobj-code-vector funobj2) eip)))
- (when x
- (values (funobj-name funobj2) x))))
- (find-primitive-code-vector-by-eip eip)))))))))
- (setf next-frame (dit-frame-casf stack frame))
- (if (and conflate-interrupts conflate
- ;; When the interrupted function has a stack-frame, conflate it.
- (typep funobj 'function)
- (= 1 (ldb (byte 1 5) (funobj-debug-info funobj))))
- (incf conflate-count)
- (progn
- (incf count)
- (print-leadin stack frame count conflate-count)
- (setf conflate-count 0)
- (let ((exception (dit-frame-ref stack frame :exception-vector :unsigned-byte32)))
- (if function-name
- (format t "DIT exception ~D in ~W at PC offset ~D."
- exception
- function-name
- code-vector-offset)
- (format t "DIT exception ~D at EIP=~S with ESI=~S."
- exception
- eip
- (dit-frame-ref stack frame :esi :unsigned-byte32)))
- #+ignore
- (typecase funobj
- (function
- (let ((delta (code-vector-offset (funobj-code-vector funobj) eip)))
- (if delta
- (format t "DIT Exception ~D in ~W at PC offset ~D."
- exception (funobj-name funobj) delta)
- (multiple-value-bind (primitive-name primitive-vector)
- (find-primitive-code-vector-by-location (truncate eip 4))
- (if (not primitive-name)
- (format t "DIT Exception ~D in ~W at EIP=#x~X."
- exception (funobj-name funobj) eip)
- (format t "DIT Exception ~D in primitive-function ~A at PC offset ~D."
- exception
- primitive-name
- (code-vector-offset primitive-vector eip)))))))
- (t ;; This should in principle never happen, but since this
- ;; is a debugger, making this an error or break would probably
- ;; just be a nuisance.
- (format t "DIT Exception ~D. Unable to determine current function (!) with ESI=~Z and EIP=#x~X."
- exception funobj eip)))))))))
- (function
- (let ((name (funobj-name funobj)))
- (cond
- ((and conflate (member name *backtrace-conflate-names* :test #'equal))
- (incf conflate-count))
- (t (incf count)
- #+ignore (when (and *backtrace-stack-frame-barrier*
- (<= *backtrace-stack-frame-barrier* stack-frame))
- (write-string " --|")
- (return))
- (unless (or (not (integerp length))
- (< count length))
- (write-string " ...")
- (return))
- (print-leadin stack frame count conflate-count)
- (setf conflate-count 0)
- (write-char #\()
- (let* ((numargs (stack-frame-numargs stack frame))
- (map (and funobj (funobj-stack-frame-map funobj numargs))))
- (cond
- ((and (car map) (eq name 'unbound-function))
- (let ((real-name (stack-frame-ref stack frame (car map))))
- (format t "{unbound ~S}" real-name)))
- ((and (car map)
- (member name +backtrace-gf-discriminatior-functions+))
- (let ((gf (stack-frame-ref stack frame (car map))))
+ (handler-case
+ (typecase funobj
+ ((eql 0)
+ (let ((eip (dit-frame-ref stack frame :eip :unsigned-byte32))
+ (casf (dit-frame-casf stack frame)))
+ (multiple-value-bind (function-name code-vector-offset)
+ (let ((casf-funobj (stack-frame-funobj stack casf)))
(cond
- ((typep gf 'muerte::standard-gf-instance)
- (format t "{gf ~S}" (funobj-name gf)))
- (t (write-string "[not a gf??]")))
- (safe-print-stack-frame-arglist stack frame map :numargs numargs)))
- (t (write name)
- (safe-print-stack-frame-arglist stack frame map
- :numargs numargs
- :edx-p (eq 'muerte::&edx
- (car (funobj-lambda-list funobj)))))))
- (write-char #\))
- (when (and (symbolp name)
- (string= name 'toplevel-function))
- (write-char #\.)
- (return))))))
- (t (print-leadin stack frame count conflate-count)
- (format t "?: ~Z" funobj))))))
+ ((eq 0 casf-funobj)
+ (values 'default-interrupt-trampoline
+ (code-vector-offset (symbol-value 'default-interrupt-trampoline)
+ eip)))
+ ((not (typep casf-funobj 'function))
+ ;; Hm.. very suspicius
+ (warn "Weird frame ~S" frame)
+ (values nil))
+ (t (let ((x (code-vector-offset (funobj-code-vector casf-funobj) eip)))
+ (cond
+ ((not (eq nil x))
+ (values (funobj-name casf-funobj) x))
+ ((not (logbitp 10 (dit-frame-ref stack frame :eflags :unsigned-byte16)))
+ (let ((funobj2 (dit-frame-ref stack frame :esi :lisp)))
+ (or (when (typep funobj2 'function)
+ (let ((x (code-vector-offset (funobj-code-vector funobj2) eip)))
+ (when x
+ (values (funobj-name funobj2) x))))
+ (find-primitive-code-vector-by-eip eip)))))))))
+ ;; (setf next-frame (dit-frame-casf stack frame))
+ (if (and conflate-interrupts conflate
+ ;; When the interrupted function has a stack-frame, conflate it.
+ (typep funobj 'function)
+ (= 1 (ldb (byte 1 5) (funobj-debug-info funobj))))
+ (incf conflate-count)
+ (progn
+ (incf count)
+ (print-leadin stack frame count conflate-count)
+ (setf conflate-count 0)
+ (let ((exception (dit-frame-ref stack frame :exception-vector :unsigned-byte32)))
+ (if function-name
+ (format t "DIT exception ~D in ~W at PC offset ~D."
+ exception
+ function-name
+ code-vector-offset)
+ (format t "DIT exception ~D at EIP=~S with ESI=~S."
+ exception
+ eip
+ (dit-frame-ref stack frame :esi :unsigned-byte32)))))))))
+ (function
+ (let ((name (funobj-name funobj)))
+ (cond
+ ((and conflate (member name *backtrace-conflate-names* :test #'equal))
+ (incf conflate-count))
+ (t (incf count)
+ #+ignore (when (and *backtrace-stack-frame-barrier*
+ (<= *backtrace-stack-frame-barrier* stack-frame))
+ (write-string " --|")
+ (return))
+ (unless (or (not (integerp length))
+ (< count length))
+ (write-string " ...")
+ (return))
+ (print-leadin stack frame count conflate-count)
+ (setf conflate-count 0)
+ (write-char #\()
+ (let* ((numargs (stack-frame-numargs stack frame))
+ (map (and funobj (funobj-stack-frame-map funobj numargs))))
+ (cond
+ ((and (car map) (eq name 'unbound-function))
+ (let ((real-name (stack-frame-ref stack frame (car map))))
+ (format t "{unbound ~S}" real-name)))
+ ((and (car map)
+ (member name +backtrace-gf-discriminatior-functions+))
+ (let ((gf (stack-frame-ref stack frame (car map))))
+ (cond
+ ((typep gf 'muerte::standard-gf-instance)
+ (format t "{gf ~S}" (funobj-name gf)))
+ (t (write-string "[not a gf??]")))
+ (safe-print-stack-frame-arglist stack frame map :numargs numargs)))
+ (t (write name)
+ (safe-print-stack-frame-arglist stack frame map
+ :numargs numargs
+ :edx-p (eq 'muerte::&edx
+ (car (funobj-lambda-list funobj)))))))
+ (write-char #\))
+ (when (and (symbolp name)
+ (string= name 'toplevel-function))
+ (write-char #\.)
+ (return))
+ (write-char #\newline)))))
+ (t (print-leadin stack frame count conflate-count)
+ (format t "?: ~Z" funobj)))
+ (serious-condition (c)
+ (let ((*print-safely* t))
+ (format t " - Error at ~S funobj ~S: ~A"
+ frame
+ (stack-frame-funobj nil frame)
+ c)))))))
(values))
More information about the Movitz-cvs
mailing list