X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Finterr.lisp;h=3e0e9aef5b927193d5eaf7457e3e1ec7ee51ab3b;hb=04a651e749befd65ffd8bf49f689b6e7d55607e2;hp=9a42a0cc1d824626ed85d8c4783c398e6ddbe153;hpb=481348f2f96f364374f669786f9fc61348decabc;p=sbcl.git diff --git a/src/code/interr.lisp b/src/code/interr.lisp index 9a42a0c..3e0e9ae 100644 --- a/src/code/interr.lisp +++ b/src/code/interr.lisp @@ -22,40 +22,38 @@ (sb!xc:defmacro deferr (name args &rest body) (let* ((rest-pos (position '&rest args)) (required (if rest-pos (subseq args 0 rest-pos) args)) - (fp (gensym)) - (context (gensym)) - (sc-offsets (gensym)) (fn-name (symbolicate name "-HANDLER"))) - `(progn - ;; FIXME: Having a separate full DEFUN for each error doesn't - ;; seem to add much value, and it takes a lot of space. Perhaps - ;; we could do this dispatch with a big CASE statement instead? - (defun ,fn-name (name ,fp ,context ,sc-offsets) - ;; FIXME: It would probably be good to do *STACK-TOP-HINT* - ;; tricks to hide this internal error-handling logic from the - ;; poor high level user, so his debugger tells him about - ;; where his error was detected instead of telling him where - ;; he ended up inside the system error-handling logic. - (declare (ignorable name ,fp ,context ,sc-offsets)) - (let (,@(let ((offset -1)) - (mapcar (lambda (var) - `(,var (sb!di::sub-access-debug-var-slot - ,fp - (nth ,(incf offset) - ,sc-offsets) - ,context))) - required)) - ,@(when rest-pos - `((,(nth (1+ rest-pos) args) - (mapcar (lambda (sc-offset) - (sb!di::sub-access-debug-var-slot - ,fp - sc-offset - ,context)) - (nthcdr ,rest-pos ,sc-offsets)))))) - ,@body)) - (setf (svref *internal-errors* ,(error-number-or-lose name)) - #',fn-name)))) + (with-unique-names (fp context sc-offsets) + `(progn + ;; FIXME: Having a separate full DEFUN for each error doesn't + ;; seem to add much value, and it takes a lot of space. Perhaps + ;; we could do this dispatch with a big CASE statement instead? + (defun ,fn-name (name ,fp ,context ,sc-offsets) + ;; FIXME: It would probably be good to do *STACK-TOP-HINT* + ;; tricks to hide this internal error-handling logic from the + ;; poor high level user, so his debugger tells him about + ;; where his error was detected instead of telling him where + ;; he ended up inside the system error-handling logic. + (declare (ignorable name ,fp ,context ,sc-offsets)) + (let (,@(let ((offset -1)) + (mapcar (lambda (var) + `(,var (sb!di::sub-access-debug-var-slot + ,fp + (nth ,(incf offset) + ,sc-offsets) + ,context))) + required)) + ,@(when rest-pos + `((,(nth (1+ rest-pos) args) + (mapcar (lambda (sc-offset) + (sb!di::sub-access-debug-var-slot + ,fp + sc-offset + ,context)) + (nthcdr ,rest-pos ,sc-offsets)))))) + ,@body)) + (setf (svref *internal-errors* ,(error-number-or-lose name)) + #',fn-name))))) ) ; EVAL-WHEN @@ -238,12 +236,14 @@ :operands (list this that))) (deferr object-not-type-error (object type) - (error (if (and (typep object 'instance) - (layout-invalid (%instance-layout object))) - 'layout-invalid - 'type-error) - :datum object - :expected-type type)) + (if (invalid-array-p object) + (invalid-array-error object) + (error (if (and (%instancep object) + (layout-invalid (%instance-layout object))) + 'layout-invalid + 'type-error) + :datum object + :expected-type type))) (deferr layout-invalid-error (object layout) (error 'layout-invalid @@ -260,12 +260,7 @@ :format-arguments (list key-name))) (deferr invalid-array-index-error (array bound index) - (error 'simple-type-error - :format-control - "invalid array index ~W for ~S (should be nonnegative and <~W)" - :format-arguments (list index array bound) - :datum index - :expected-type `(integer 0 (,bound)))) + (invalid-array-index-error array index bound)) (deferr object-not-simple-array-error (object) (error 'type-error @@ -282,6 +277,15 @@ :datum object :expected-type '(unsigned-byte 32))) +(deferr tls-exhausted-error () + ;; There is nothing we can do about it. A number of entries in the + ;; tls could be reserved and made available for recovery but since + ;; tls indices are never reused it would be kind of silly and + ;; without it signalling an error is more than likely to end in a + ;; recursive error. + (%primitive print "Thread local storage exhausted.") + (sb!impl::%halt)) + (macrolet ((define-simple-array-internal-errors () `(progn @@ -363,8 +367,8 @@ (values "" 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 "" nil) (handler-case @@ -389,10 +393,27 @@ (/show0 "trapped DEBUG-CONDITION") (values "" nil))))) + +(defun find-caller-of-named-frame (name) + (unless *finding-name* + (handler-case + (let ((*finding-name* t)) + (do ((frame (sb!di:top-frame) (sb!di:frame-down frame))) + ((null frame)) + (when (and (sb!di::compiled-frame-p frame) + (eq name (sb!debug::clean-debug-fun-name + (sb!di:debug-fun-name + (sb!di:frame-debug-fun frame))))) + (let ((caller (sb!di:frame-down frame))) + (sb!di:flush-frames-above caller) + (return caller))))) + ((or error sb!di:debug-condition) () + nil) + (sb!di:debug-condition () + nil)))) -;;;; INTERNAL-ERROR signal handler -(defvar *internal-error-args*) +;;;; INTERNAL-ERROR signal handler (defun internal-error (context continuable) (declare (type system-area-pointer context)) @@ -402,7 +423,7 @@ (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) @@ -419,35 +440,36 @@ (%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) - (/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))))))))) + (with-interrupt-bindings + (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)) @@ -456,11 +478,56 @@ "Control stack guard page temporarily disabled: proceed with caution~%") (error 'control-stack-exhausted)))) +(defun binding-stack-exhausted-error () + (let ((sb!debug:*stack-top-hint* nil)) + (infinite-error-protect + (format *error-output* + "Binding stack guard page temporarily disabled: proceed with caution~%") + (error 'binding-stack-exhausted)))) + +(defun alien-stack-exhausted-error () + (let ((sb!debug:*stack-top-hint* nil)) + (infinite-error-protect + (format *error-output* + "Alien stack guard page temporarily disabled: proceed with caution~%") + (error 'alien-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 unsigned-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))))))