From 17532463fa19f2fc2aba53b65c32e200a27ccd6a Mon Sep 17 00:00:00 2001 From: Cyrus Harmon Date: Fri, 6 Apr 2007 11:13:54 +0000 Subject: [PATCH] 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. --- NEWS | 2 + src/code/debug-int.lisp | 36 +++++++--------- src/code/interr.lisp | 110 ++++++++++++++++++++++------------------------- version.lisp-expr | 2 +- 4 files changed, 69 insertions(+), 81 deletions(-) diff --git a/NEWS b/NEWS index bb3cb54..f25fa38 100644 --- a/NEWS +++ b/NEWS @@ -17,6 +17,8 @@ changes in sbcl-1.0.5 relative to sbcl-1.0.4: * bug fix: some GC deadlocks caused by asynchronous interrupts have been fixed by inhibiting interrupts for when GC is disbled. * bug fix: GETHASH, PUTHASH, CLRHASH and REMHASH are now interrupt safe. + * improvement: the x86-64/darwin port now passes all tests and + should be considered non-experimental. changes in sbcl-1.0.4 relative to sbcl-1.0.3: * new platform: experimental support for x86-64/darwin (MacOS). diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index a7ee641..3d375e8 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -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)) diff --git a/src/code/interr.lisp b/src/code/interr.lisp index e89f43c..b441516 100644 --- a/src/code/interr.lisp +++ b/src/code/interr.lisp @@ -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) - - ;; 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)))))))))) + (/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)) + + (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)) diff --git a/version.lisp-expr b/version.lisp-expr index 562aa24..54d78eb 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.4.30" +"1.0.4.31" -- 1.7.10.4