X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Finterr.lisp;h=e00663d5006aa6dc2291addb4ca8e01f95943ba4;hb=65b5ab7e713d04e0d76bc0ee196374f6e57b922f;hp=3f2a45d9129065cee22f20acff200d1b6c6d091b;hpb=0bb093a109ec94a021e413bd0ae6ae7fdf54d774;p=sbcl.git diff --git a/src/code/interr.lisp b/src/code/interr.lisp index 3f2a45d..e00663d 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 (%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 +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 @@ -431,14 +426,6 @@ (multiple-value-bind (name sb!debug:*stack-top-hint*) (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*)) @@ -473,10 +460,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*) @@ -494,7 +496,7 @@ (error 'undefined-alien-function-error)) #!-win32 -(define-alien-variable current-memory-fault-address long) +(define-alien-variable current-memory-fault-address unsigned-long) #!-win32 (defun memory-fault-error ()