#!-stack-grows-downward-not-upward
(and (sap< x (current-sp))
(sap<= control-stack-start x)
- (zerop (logand (sap-int x) #b11)))
+ (zerop (logand (sap-int x) sb!vm:fixnum-tag-mask)))
#!+stack-grows-downward-not-upward
(and (sap>= x (current-sp))
(sap> control-stack-end x)
- (zerop (logand (sap-int x) #b11)))))
+ (zerop (logand (sap-int x) sb!vm:fixnum-tag-mask)))))
(declaim (inline component-ptr-from-pc))
(sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer)
;;; this function.
(defun top-frame ()
(/noshow0 "entering TOP-FRAME")
- (multiple-value-bind (fp pc) (%caller-frame-and-pc)
- (compute-calling-frame (descriptor-sap fp) pc nil)))
+ ;; 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
+ ;; 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)))))
+ (compute-calling-frame
+ (int-sap (sb!vm:context-register alien-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))))
;;; Flush all of the frames above FRAME, and renumber all the frames
;;; below FRAME.
(values "<error finding interrupted name -- trapped debug-condition>"
nil)))))
\f
+
+;;; 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))
- (/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)))))))))
+ (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))))))))))
(defun control-stack-exhausted-error ()
(let ((sb!debug:*stack-top-hint* nil))
projects / sbcl.git / commitdiff