(values "<error finding caller name -- trapped debug-condition>"
nil)))))
-(defun find-interrupted-name ()
- (/show0 "entering FIND-INTERRUPTED-NAME")
+(defun find-interrupted-name-and-frame ()
+ (/show0 "entering FIND-INTERRUPTED-NAME-AND-FRAME")
(if *finding-name*
(values "<error finding interrupted name -- already finding name>" nil)
(handler-case
(values "<error finding interrupted name -- trapped debug-condition>"
nil)))))
\f
+
;;;; INTERNAL-ERROR signal handler
(defun internal-error (context continuable)
(infinite-error-protect
(/show0 "about to bind ALIEN-CONTEXT")
(let ((alien-context (locally
- (declare (optimize (inhibit-warnings 3)))
+ (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)
(%primitive sb!c:halt))
(multiple-value-bind (name sb!debug:*stack-top-hint*)
- (find-interrupted-name)
+ (find-interrupted-name-and-frame)
(/show0 "back from FIND-INTERRUPTED-NAME")
+ ;; Unblock trap signal here, we unwound the stack and can't return.
+ ;; FIXME: Should we not reset the _entire_ mask, but just
+ ;; restore it to the state before we got the condition?
+ ;; FIXME 2: Signals are currently unblocked in
+ ;; interrupt.c:internal_error before we do stack unwinding, can this
+ ;; introduce a race condition?
+ #!+(and linux mips)
+ (sb!unix::reset-signal-mask)
(let ((fp (int-sap (sb!vm:context-register alien-context
sb!vm::cfp-offset)))
(handler (and (< -1 error-number (length *internal-errors*))
"Control stack guard page temporarily disabled: proceed with caution~%")
(error 'control-stack-exhausted))))
+;;; KLUDGE: we keep a single HEAP-EXHAUSTED-ERROR object around, so
+;;; that we don't need to allocate it when running out of memory. Similarly
+;;; we pass the amounts in special variables as there may be multiple threads
+;;; running into trouble at the same time. The condition is created by GC-REINIT.
+(defvar *heap-exhausted-error-condition*)
+(defvar *heap-exhausted-error-available-bytes*)
+(defvar *heap-exhausted-error-requested-bytes*)
+
+(defun heap-exhausted-error (available requested)
+ (infinite-error-protect
+ (let ((*heap-exhausted-error-available-bytes* available)
+ (*heap-exhausted-error-requested-bytes* requested))
+ (error *heap-exhausted-error-condition*))))
+
(defun undefined-alien-variable-error ()
(error 'undefined-alien-variable-error))
(defun undefined-alien-function-error ()
(error 'undefined-alien-function-error))
+#!-win32
+(define-alien-variable current-memory-fault-address long)
+
+#!-win32
(defun memory-fault-error ()
- (error 'memory-fault-error))
+ (error 'memory-fault-error
+ :address current-memory-fault-address))
+
+;;; This is SIGTRAP / EXCEPTION_BREAKPOINT that runtime could not deal
+;;; with. Prior to Windows we just had a Lisp side handler for
+;;; SIGTRAP, but now we need to deal with this portably.
+(defun unhandled-trap-error (context-sap)
+ (declare (type system-area-pointer context-sap))
+ (infinite-error-protect
+ (let ((context (sap-alien context-sap (* os-context-t))))
+ (error 'breakpoint-error
+ :context context
+ :address (sap-int (sb!vm:context-pc context))))))