From: Stephen Adams <edu/mit/csail/zurich/adams>
Date: Sat, 12 Jul 1997 04:23:26 +0000 (+0000)
Subject: 8.0 debugging changes.
X-Git-Tag: 20090517-FFI~5070
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=16f575348ee1d438e145ff873927abd23e46dfbd;p=mit-scheme.git

8.0 debugging changes.

Added a procedure COMPILED-CODE-BLOCK/NAME to guess the name of the
procedure in the compiled code block.  If the dbg info has only one
top-level procedure then use the name of that procedure, otherwise
return false.  Requires LOAD-DEBUGGING-INFO-ON-DEMAND? to be true to
load the dbg info.

Fixed HARDWARE-TRAP-FRAME/DESCRIBE to use the new 8.0 debugging
information - it was an oversight that it was still trying to use the
old debugging locator to identify the file name for the compiled code
block.  Also use COMPILED-CODE-BLOCK/NAME to identify the procedure.

Together, these changes mean that (with LOAD-DEBUGGING-INFO-ON-DEMAND?
true), SIGSEGVs and SIGFPEs can usually identify the offending
procedure by name.
---

diff --git a/v8/src/runtime/conpar.scm b/v8/src/runtime/conpar.scm
index bdc97c9bb..c23f31ff6 100644
--- a/v8/src/runtime/conpar.scm
+++ b/v8/src/runtime/conpar.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: conpar.scm,v 14.37 1996/07/26 00:34:49 adams Exp $
+$Id: conpar.scm,v 14.38 1997/07/12 04:23:26 adams Exp $
 
 Copyright (c) 1988-95 Massachusetts Institute of Technology
 
@@ -1136,26 +1136,25 @@ MIT in each case. |#
 	   (write-string " within ")
 	   (write (stack-frame/ref frame hardware-trap/pc-info1-index)))
 	  ((2)				; compiled code
-	   (write-string " at offset ")
-	   (write-hex (stack-frame/ref frame hardware-trap/pc-info2-index))
-	   (newline)
-	   (write-string "within ")
-	   (let ((block (stack-frame/ref frame hardware-trap/pc-info1-index)))
+	   (let ((block  (stack-frame/ref frame hardware-trap/pc-info1-index))
+		 (offset (stack-frame/ref frame hardware-trap/pc-info2-index)))
+	     (write-string " at offset ")
+	     (write-hex offset)
+	     (newline)
+	     (write-string "within ")
 	     (write block)
-	     (let loop ((info (compiled-code-block/debugging-info block)))
-	       (cond ((null? info)
-		      false)
-		     ((string? info)
-		      (begin
-			(write-string " (")
-			(write-string info)
-			(write-string ")")))
-		     ((not (pair? info))
-		      false)
-		     ((string? (car info))
-		      (loop (car info)))
-		     (else
-		      (loop (cdr info)))))))
+	     (let ((descriptor (compiled-code-block/dbg-descriptor block)))
+	       (if descriptor
+		   (begin
+		     (write-string " (")
+		     (display (dbg-locator/file (car descriptor)))
+		     (flush-output) ; incase following is slow...
+		     (let ((name (compiled-code-block/name block offset)))
+		       (if name
+			   (begin
+			     (write-string " ")
+			     (display name))))
+		     (write-string ")"))))))
 	  ((3)				; probably compiled-code
 	   (write-string " at an unknown compiled-code location."))
 	  ((4)				; builtin (i.e. hook)
diff --git a/v8/src/runtime/infutl.scm b/v8/src/runtime/infutl.scm
index 916418f5d..719cabdae 100644
--- a/v8/src/runtime/infutl.scm
+++ b/v8/src/runtime/infutl.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: infutl.scm,v 1.61 1995/08/02 20:47:38 adams Exp $
+$Id: infutl.scm,v 1.62 1997/07/12 04:23:16 adams Exp $
 
-Copyright (c) 1988-95 Massachusetts Institute of Technology
+Copyright (c) 1988-97 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -383,6 +383,29 @@ MIT in each case. |#
 	   (or (special-form-procedure-name? name)
 	       (symbol->string name))))))
 
+(define (compiled-code-block/name block offset)
+  ;; Try to come up with a name for BLOCK.  If there is one top-level
+  ;; procedure, use its name.
+  (define (top-level-proc-name proc)
+    (and (dbg-block? (dbg-procedure/block proc))
+	 (eq? 'IC (dbg-block/parent (dbg-procedure/block proc)))
+	 (let ((name (dbg-procedure/name proc)))
+	   (or (special-form-procedure-name? name)
+	       name))))
+  offset ; ignored
+  (let ((dbg-info
+	 (compiled-code-block/dbg-info block load-debugging-info-on-demand?)))
+    (and dbg-info
+	 (not (dbg-info/expression dbg-info)) ; top level or group compiled
+	 (let ((procs (dbg-info/procedures dbg-info)))
+	   (let loop ((i 0) (name #F))
+	     (cond ((= i (vector-length procs))  name)
+		   ((top-level-proc-name (vector-ref procs i))
+		    => (lambda (name*)
+			 (and (not name)
+			      (loop (+ i 1) name*))))
+		   (else (loop (+ i 1) name))))))))
+
 (define load-debugging-info-on-demand?
   false)
 
diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index 09b0aea18..d3aeeae2b 100644
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.289 1997/06/25 03:28:26 cph Exp $
+$Id: runtime.pkg,v 14.290 1997/07/12 04:23:04 adams Exp $
 
 Copyright (c) 1988-97 Massachusetts Institute of Technology
 
@@ -276,6 +276,10 @@ MIT in each case. |#
 	  dbg-expression?)
   (export (runtime unparser)
 	  compiled-entry/filename-and-index)
+  (export (runtime continuation-parser)
+	  compiled-code-block/dbg-descriptor
+	  compiled-code-block/name
+	  dbg-locator/file)
   (export (runtime compress)
 	  uncompress-internal)
   (initialization (initialize-package!)))