[movitz-cvs] CVS update: movitz/procfs-image.lisp

[Frode Vatvedt Fjeld]

Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv6781

Modified Files:
	procfs-image.lisp 
Log Message:
Improved backtrace a bit.

Date: Fri Jul 23 08:32:55 2004
Author: ffjeld

Index: movitz/procfs-image.lisp
diff -u movitz/procfs-image.lisp:1.10 movitz/procfs-image.lisp:1.11
--- movitz/procfs-image.lisp:1.10	Wed Jul 21 17:28:06 2004
+++ movitz/procfs-image.lisp	Fri Jul 23 08:32:55 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Aug 24 11:39:37 2001
 ;;;;                
-;;;; $Id: procfs-image.lisp,v 1.10 2004/07/22 00:28:06 ffjeld Exp $
+;;;; $Id: procfs-image.lisp,v 1.11 2004/07/23 15:32:55 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -170,7 +170,18 @@
 		 '(nil :eflags :eip :error-code :exception :ebp nil
 		   :ecx :eax :edx :ebx :esi :edi))))
 
-(defun backtrace (&key reqs)
+(defun debug-get-object (word spartan)
+  (if spartan
+      word
+    (handler-case
+	(let ((object (movitz-word word)))
+	  (typecase object
+	    ((or movitz-funobj movitz-struct movitz-std-instance)
+	     object)
+	    (t (movitz-print object))))
+      (t () (list :unknown-word word)))))
+
+(defun backtrace (&key (reqs t) print-frames print-returns spartan)
   (format t "~&Backtracing from EIP = #x~X: "
 	  (image-register32 *image* :eip))
   ;; (search-image-funobj (image-register32 *image* :eip))
@@ -195,14 +206,17 @@
 				r eax ecx edi eip exception))))
 	     (movitz-symbol
 	      (let ((name (movitz-print movitz-name)))
-		(write-string (symbol-name name))
+		(when print-frames
+		  (format t "~S " stack-frame))
 		(when (string= name 'toplevel-function)
 		  (loop-finish))
-		(format t " (#x~X)" (stack-frame-return-address stack-frame))
 		(when reqs
-		  (format t " req1: ~S, req2: ~S"
-			  (movitz-word (get-word stack-frame -2))
-			  (movitz-word (get-word stack-frame -3))))))
+		  (format t "(~A ~S ~S)"
+			  (symbol-name name)
+			  (debug-get-object (get-word (+ stack-frame -8)) spartan)
+			  (debug-get-object (get-word (+ stack-frame -12)) spartan)))
+		(when print-returns
+		  (format t " (#x~X)" (stack-frame-return-address stack-frame)))))
 	     (t (write (movitz-print movitz-name)))))
       do (format t "~& => "))
   (values))
@@ -276,13 +290,30 @@
 	      (values)))
 
 
+(defvar *previous-image*)
+
 #+allegro
 (top-level:alias ("bochs" 0) (&optional form)
-  (with-bochs-image ()
-    (with-simple-restart (continue "Exit this bochs session [pid=~D]" (image-pid *image*))
+  (let ((*previous-image* *image*))
+    (with-bochs-image ()
+      (let ((image *image*))
+	(with-simple-restart (continue "Exit this bochs session [pid=~D]" (image-pid image))
+	  (if form
+	      (let ((x (eval form)))
+		(format t "~&~W" x)
+		x)
+	    (invoke-debugger "Established Bochs session [pid=~D]. ~S is ~S"
+			     (image-pid image)
+			     '*previous-image*
+			     *previous-image*)))))))
+
+#+allegro
+(top-level:alias ("unbochs" 3) (&optional form)
+  (let ((*image* *previous-image*)
+	(image *image*))
+    (with-simple-restart (continue "Exit this unbochs session")
       (if form
 	  (let ((x (eval form)))
 	    (format t "~&~W" x)
 	    x)
-	(invoke-debugger "Established connection to Bochs [pid=~D]."
-			 (image-pid *image*))))))
+	(invoke-debugger "Established connection to unBochs ~S" image)))))