[movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp

[Frode Vatvedt Fjeld]

Update of /project/movitz/cvsroot/movitz/losp/x86-pc
In directory common-lisp.net:/tmp/cvs-serv6294

Modified Files:
	debugger.lisp 
Log Message:
Improved backtrace's ability to figure out what is the frame's
function-name etc, even for primitive-functions.

Date: Wed Sep 22 20:00:56 2004
Author: ffjeld

Index: movitz/losp/x86-pc/debugger.lisp
diff -u movitz/losp/x86-pc/debugger.lisp:1.24 movitz/losp/x86-pc/debugger.lisp:1.25
--- movitz/losp/x86-pc/debugger.lisp:1.24	Wed Sep 15 12:23:09 2004
+++ movitz/losp/x86-pc/debugger.lisp	Wed Sep 22 20:00:55 2004
@@ -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.24 2004/09/15 10:23:09 ffjeld Exp $
+;;;; $Id: debugger.lisp,v 1.25 2004/09/22 18:00:55 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -441,6 +441,14 @@
   (assert (location-in-object-p vector location))
   (- location (object-location vector) 2))
 
+(defun find-primitive-code-vector-by-eip (eip &optional (context (current-run-time-context)))
+  (loop with location = (truncate eip 4)
+      for (slot-name type) in (slot-value (class-of context) 'slot-map)
+      do (when (eq type 'code-vector-word)
+	   (let ((code-vector (%run-time-context-slot slot-name)))
+	     (when (location-in-object-p code-vector location)
+	       (return (values slot-name (code-vector-offset code-vector eip))))))))
+
 (defun backtrace (&key (stack nil)
 		       ((:frame initial-stack-frame-index)
 			(if stack
@@ -485,30 +493,68 @@
 		      (format t "#x~X " frame))))
 	     (typecase funobj
 	       ((eql 0)
-		(let* (#+ignore (dit-frame (if (null stack) frame (+ frame 2 (object-location stack))))
-		       (funobj (dit-frame-ref stack frame :esi)))
-		  (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))
-			    (eip (dit-frame-ref stack frame :eip :unsigned-byte32)))
-			(typecase funobj
-			  (function
-			   (let ((delta (code-vector-offset (funobj-code-vector funobj) eip)))
-			     (if delta
-				 (format t "{Exception ~D in ~W at PC offset ~D.}"
-					 exception (funobj-name funobj) delta)
-			       (format t "{Exception ~D in ~W at EIP=#x~X.}"
-				       exception (funobj-name funobj) eip))))
-			  (t (format t "{Exception ~D with ESI=~Z and EIP=#x~X.}"
-				     exception funobj eip))))))))
+		(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 (slot-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 (format t "DIT Exception ~D with ESI=~Z and EIP=#x~X."
+				       exception funobj eip)))))))))
 	       (function
 		(let ((name (funobj-name funobj)))
 		  (cond