X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Finterr.lisp;h=f6b1692c96dc94abe49298ed4821fb7092ad5567;hb=0c3bbfaa2286626a2d915c8810f690aefc702661;hp=3b75632f49f15a41ba19c6358f39396bb9833589;hpb=47041c560a8e9e955ec8b403e575e7ecf3e23422;p=sbcl.git diff --git a/src/code/interr.lisp b/src/code/interr.lisp index 3b75632..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 @@ -335,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 @@ -398,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 @@ -409,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) @@ -431,14 +469,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,6 +503,20 @@ "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 @@ -491,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 unsigned-long) +(define-alien-variable current-memory-fault-address unsigned) #!-win32 (defun memory-fault-error ()