X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Finterr.lisp;h=f6b1692c96dc94abe49298ed4821fb7092ad5567;hb=18dc0069cd514c976042766ab9a785c970fe1603;hp=8fb704a943e7cf24a9f3b6e6d9a6e6262aec81d5;hpb=a7409fa0a69f733ea2460a1aeddbe04b5c4c0888;p=sbcl.git diff --git a/src/code/interr.lisp b/src/code/interr.lisp index 8fb704a..f6b1692 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 @@ -185,6 +183,17 @@ (symbol fdefn-or-symbol) (fdefn (fdefn-name fdefn-or-symbol))))) +#!+x86-64 +(deferr undefined-alien-fun-error (address) + (error 'undefined-alien-function-error + :name + (and (integerp address) + (sap-foreign-symbol (int-sap address))))) + +#!-x86-64 +(defun undefined-alien-fun-error () + (error 'undefined-alien-function-error)) + (deferr invalid-arg-count-error (nargs) (error 'simple-program-error :format-control "invalid number of arguments: ~S" @@ -238,12 +247,14 @@ :operands (list this that))) (deferr object-not-type-error (object type) - (error (if (and (%instancep object) - (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 +271,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 +288,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 @@ -326,6 +341,12 @@ :datum object :expected-type '(complex long-float))) +#!+sb-simd-pack +(deferr object-not-simd-pack-error (object) + (error 'type-error + :datum object + :expected-type 'simd-pack)) + (deferr object-not-weak-pointer-error (object) (error 'type-error :datum object @@ -389,6 +410,23 @@ (/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!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 @@ -400,9 +438,18 @@ (/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))))) + (let* ((alien-context (locally + (declare (optimize (inhibit-warnings 3))) + (sb!alien:sap-alien context (* os-context-t)))) + #!+c-stack-is-control-stack + (*saved-fp-and-pcs* + (cons (cons (%make-lisp-obj (sb!vm:context-register + alien-context + sb!vm::cfp-offset)) + (sb!vm:context-pc alien-context)) + (when (boundp '*saved-fp-and-pcs*) + *saved-fp-and-pcs*)))) + (declare (truly-dynamic-extent *saved-fp-and-pcs*)) (/show0 "about to bind ERROR-NUMBER and ARGUMENTS") (multiple-value-bind (error-number arguments) (sb!vm:internal-error-args alien-context) @@ -418,35 +465,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-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))))))))) + (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)) @@ -455,10 +503,25 @@ "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. +;;; 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*) @@ -472,11 +535,8 @@ (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) +(define-alien-variable current-memory-fault-address unsigned) #!-win32 (defun memory-fault-error () @@ -485,7 +545,7 @@ ;;; 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 this portably. +;;; 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