[Sbcl-commits] CVS: sbcl/src/code debug-int.lisp, 1.109, 1.110 interr.lisp, 1.42, 1.43

[Cyrus H. <sl...@us...>]

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv15470/src/code

Modified Files:
	debug-int.lisp interr.lisp 
Log Message:
1.0.4.31: remove *internal-error-context*
 * use nth-interrupt-context to find the context in top-frame instead
   of squirreling it away in *internal-error-context*.
 * moved the defun for nth-interrupt-context up before top-frame.
 * updated NEWS to reflect non-experimental status of x86-64/darwin
   port.


Index: debug-int.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/debug-int.lisp,v
retrieving revision 1.109
retrieving revision 1.110
diff -u -d -r1.109 -r1.110
--- debug-int.lisp	5 Apr 2007 00:42:27 -0000	1.109
+++ debug-int.lisp	6 Apr 2007 11:13:56 -0000	1.110
@@ -654,27 +654,28 @@
 (defun descriptor-sap (x)
   (int-sap (get-lisp-obj-address x)))
 
+(defun nth-interrupt-context (n)
+  (declare (type (unsigned-byte 32) n)
+           (optimize (speed 3) (safety 0)))
+  (sb!alien:sap-alien (sb!vm::current-thread-offset-sap
+                       (+ sb!vm::thread-interrupt-contexts-offset n))
+                      (* os-context-t)))
+
 ;;; Return the top frame of the control stack as it was before calling
 ;;; this function.
 (defun top-frame ()
   (/noshow0 "entering TOP-FRAME")
-  ;; if we have a stored context in *internal-error-context*, use it
-  ;; to compute the fp and pc (and rebind this variable to nil in case
-  ;; we signal another error), otherwise use the (%caller-frame-and-pc
+  ;; check to see if we can get the context by calling
+  ;; nth-interrupt-context, otherwise use the (%caller-frame-and-pc
   ;; vop).
-
-  (if sb!kernel::*internal-error-context*
-      (let* ((context sb!kernel::*internal-error-context*)
-             (sb!kernel::*internal-error-context* nil)
-             (alien-context (locally
-                                (declare (optimize (inhibit-warnings 3)))
-                              (sb!alien:sap-alien context (* os-context-t)))))
+  (let ((context (nth-interrupt-context 0)))
+    (if context
         (compute-calling-frame
-         (int-sap (sb!vm:context-register alien-context
+         (int-sap (sb!vm:context-register context
                                           sb!vm::cfp-offset))
-         (context-pc alien-context) nil))
-      (multiple-value-bind (fp pc) (%caller-frame-and-pc)
-        (compute-calling-frame (descriptor-sap fp) pc nil))))
+         (context-pc context) nil)
+        (multiple-value-bind (fp pc) (%caller-frame-and-pc)
+          (compute-calling-frame (descriptor-sap fp) pc nil)))))
 
 ;;; Flush all of the frames above FRAME, and renumber all the frames
 ;;; below FRAME.
@@ -876,13 +877,6 @@
                              (if up-frame (1+ (frame-number up-frame)) 0)
                              escaped)))))
 
-(defun nth-interrupt-context (n)
-  (declare (type (unsigned-byte 32) n)
-           (optimize (speed 3) (safety 0)))
-  (sb!alien:sap-alien (sb!vm::current-thread-offset-sap
-                       (+ sb!vm::thread-interrupt-contexts-offset n))
-                      (* os-context-t)))
-
 #!+(or x86 x86-64)
 (defun find-escaped-frame (frame-pointer)
   (declare (type system-area-pointer frame-pointer))

Index: interr.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/interr.lisp,v
retrieving revision 1.42
retrieving revision 1.43
diff -u -d -r1.42 -r1.43
--- interr.lisp	5 Apr 2007 00:42:28 -0000	1.42
+++ interr.lisp	6 Apr 2007 11:13:56 -0000	1.43
@@ -391,70 +391,62 @@
                   nil)))))
 
 
-;;; Special variable to store away the signal context passed to
-;;; internal error. internal-error stores the context for use by
-;;; sb-di:top-frame to figure out what the frame pointer and pc were
-;;; when the error was signalled. This is done since on some platforms
-;;; we have problems tracing through signal handler frames.
-(defparameter *internal-error-context* nil)
-
 ;;;; INTERNAL-ERROR signal handler
 
 (defun internal-error (context continuable)
   (declare (type system-area-pointer context))
   (declare (ignore continuable))
-  (let ((*internal-error-context* context))
-    (/show0 "entering INTERNAL-ERROR, CONTEXT=..")
-    (/hexstr context)
-    (infinite-error-protect
-     (/show0 "about to bind ALIEN-CONTEXT")
-     (let ((alien-context (locally
-                              (declare (optimize (inhibit-warnings 3)))
-                            (sb!alien:sap-alien context (* os-context-t)))))
-       (/show0 "about to bind ERROR-NUMBER and ARGUMENTS")
-       (multiple-value-bind (error-number arguments)
-           (sb!vm:internal-error-args alien-context)
+  (/show0 "entering INTERNAL-ERROR, CONTEXT=..")
+  (/hexstr context)
+  (infinite-error-protect
+   (/show0 "about to bind ALIEN-CONTEXT")
+   (let ((alien-context (locally
+                            (declare (optimize (inhibit-warnings 3)))
+                          (sb!alien:sap-alien context (* os-context-t)))))
+     (/show0 "about to bind ERROR-NUMBER and ARGUMENTS")
+     (multiple-value-bind (error-number arguments)
+         (sb!vm:internal-error-args alien-context)
 
-         ;; There's a limit to how much error reporting we can usefully
-         ;; do before initialization is complete, but try to be a little
-         ;; bit helpful before we die.
-         (/show0 "back from INTERNAL-ERROR-ARGS, ERROR-NUMBER=..")
-         (/hexstr error-number)
-         (/show0 "cold/low ARGUMENTS=..")
-         (/hexstr arguments)
-         (unless *cold-init-complete-p*
-           (%primitive print "can't recover from error in cold init, halting")
-           (%primitive sb!c:halt))
+       ;; There's a limit to how much error reporting we can usefully
+       ;; do before initialization is complete, but try to be a little
+       ;; bit helpful before we die.
+       (/show0 "back from INTERNAL-ERROR-ARGS, ERROR-NUMBER=..")
+       (/hexstr error-number)
+       (/show0 "cold/low ARGUMENTS=..")
+       (/hexstr arguments)
+       (unless *cold-init-complete-p*
+         (%primitive print "can't recover from error in cold init, halting")
+         (%primitive sb!c:halt))
 
-         (multiple-value-bind (name sb!debug:*stack-top-hint*)
-             (find-interrupted-name-and-frame)
-           (/show0 "back from FIND-INTERRUPTED-NAME")
-           (let ((fp (int-sap (sb!vm:context-register alien-context
-                                                      sb!vm::cfp-offset)))
-                 (handler (and (< -1 error-number (length *internal-errors*))
-                               (svref *internal-errors* error-number))))
-             (cond ((null handler)
-                    (error 'simple-error
-                           :format-control
-                           "unknown internal error, ~D, args=~S"
-                           :format-arguments
-                           (list error-number
-                                 (mapcar (lambda (sc-offset)
-                                           (sb!di::sub-access-debug-var-slot
-                                            fp sc-offset alien-context))
-                                         arguments))))
-                   ((not (functionp handler))
-                    (error 'simple-error
-                           :format-control "internal error ~D: ~A; args=~S"
-                           :format-arguments
-                           (list error-number
-                                 handler
-                                 (mapcar (lambda (sc-offset)
-                                           (sb!di::sub-access-debug-var-slot
-                                            fp sc-offset alien-context))
-                                         arguments))))
-                   (t
-                    (funcall handler name fp alien-context arguments))))))))))
+       (multiple-value-bind (name sb!debug:*stack-top-hint*)
+           (find-interrupted-name-and-frame)
+         (/show0 "back from FIND-INTERRUPTED-NAME")
+         (let ((fp (int-sap (sb!vm:context-register alien-context
+                                                    sb!vm::cfp-offset)))
+               (handler (and (< -1 error-number (length *internal-errors*))
+                             (svref *internal-errors* error-number))))
+           (cond ((null handler)
+                  (error 'simple-error
+                         :format-control
+                         "unknown internal error, ~D, args=~S"
+                         :format-arguments
+                         (list error-number
+                               (mapcar (lambda (sc-offset)
+                                         (sb!di::sub-access-debug-var-slot
+                                          fp sc-offset alien-context))
+                                       arguments))))
+                 ((not (functionp handler))
+                  (error 'simple-error
+                         :format-control "internal error ~D: ~A; args=~S"
+                         :format-arguments
+                         (list error-number
+                               handler
+                               (mapcar (lambda (sc-offset)
+                                         (sb!di::sub-access-debug-var-slot
+                                          fp sc-offset alien-context))
+                                       arguments))))
+                 (t
+                  (funcall handler name fp alien-context arguments)))))))))
 
 (defun control-stack-exhausted-error ()
   (let ((sb!debug:*stack-top-hint* nil))