From: stassats <sta...@us...> - 2015-01-11 17:58:49
|
The branch "master" has been updated in SBCL: via 3b10a1c9b7f88e98a8db8b5bd03a10e1190c5ad2 (commit) from 53ad3838cd21905099217fd0c287597c2b53f516 (commit) - Log ----------------------------------------------------------------- commit 3b10a1c9b7f88e98a8db8b5bd03a10e1190c5ad2 Author: Stas Boukarev <sta...@gm...> Date: Sun Jan 11 20:51:11 2015 +0300 Make XEPs restartable. XEPs do not bind any special variables so they do not need to restore the binding stack pointer. This is mostly useful for arg-count errors, for which the exact arguments can be recovered now. --- src/code/debug-int.lisp | 4 +- src/code/debug.lisp | 28 +++++---- src/code/interr.lisp | 152 +++++++++++++++++++++++++---------------------- 3 files changed, 99 insertions(+), 85 deletions(-) diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 6e865a6..315a410 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -1247,9 +1247,7 @@ register." (defun tl-invalid-arg-count-error-p (frame) (and (eq (interrupted-frame-error frame) 'invalid-arg-count-error) - (eq (sb!c::compiled-debug-fun-kind - (compiled-debug-fun-compiler-debug-fun - (frame-debug-fun frame))) + (eq (debug-fun-kind (frame-debug-fun frame)) :external))) ;; Return the name of the closure, if named, otherwise nil. diff --git a/src/code/debug.lisp b/src/code/debug.lisp index 4392254..4d62410 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -1728,8 +1728,8 @@ forms that explicitly control this kind of evaluation.") ;; * The catch block that should be active after the unwind ;; * The values that the binding stack pointer should have after the ;; unwind. - (let* ((block (sap-int/fixnum (find-enclosing-catch-block frame))) - (unbind-to (find-binding-stack-pointer frame))) + (let ((block (sap-int/fixnum (find-enclosing-catch-block frame))) + (unbind-to (find-binding-stack-pointer frame))) ;; This VOP will run the neccessary cleanup forms, reset the fp, and ;; then call the supplied function. (sb!vm::%primitive sb!vm::unwind-to-frame-and-call @@ -1753,14 +1753,16 @@ forms that explicitly control this kind of evaluation.") #!+unwind-to-frame-and-call-vop (defun find-binding-stack-pointer (frame) - (let* ((debug-fun (sb!di:frame-debug-fun frame)) - (compiled-debug-fun (and - (typep debug-fun 'sb!di::compiled-debug-fun) - (sb!di::compiled-debug-fun-compiler-debug-fun debug-fun))) - (bsp-save-offset (and compiled-debug-fun - (sb!c::compiled-debug-fun-bsp-save compiled-debug-fun)))) - (when bsp-save-offset - (sb!di::sub-access-debug-var-slot (sb!di::frame-pointer frame) bsp-save-offset)))) + (let ((debug-fun (sb!di:frame-debug-fun frame))) + (if (eq (sb!di:debug-fun-kind debug-fun) :external) + sb!kernel::*interr-current-bsp* + (let* ((compiled-debug-fun (and + (typep debug-fun 'sb!di::compiled-debug-fun) + (sb!di::compiled-debug-fun-compiler-debug-fun debug-fun))) + (bsp-save-offset (and compiled-debug-fun + (sb!c::compiled-debug-fun-bsp-save compiled-debug-fun)))) + (when bsp-save-offset + (sb!di::sub-access-debug-var-slot (sb!di::frame-pointer frame) bsp-save-offset)))))) (defun find-enclosing-catch-block (frame) ;; Walk the catch block chain looking for the first entry with an address @@ -1840,7 +1842,11 @@ forms that explicitly control this kind of evaluation.") (defun frame-has-debug-tag-p (frame) #!+unwind-to-frame-and-call-vop - (not (null (find-binding-stack-pointer frame))) + ;; XEPs do not bind anything, nothing to restore + (and (if (eq (sb!di:debug-fun-kind (sb!di:frame-debug-fun frame)) :external) + sb!kernel::*interr-current-bsp* + (find-binding-stack-pointer frame)) + t) #!-unwind-to-frame-and-call-vop (find 'sb!c:debug-catch-tag (sb!di::frame-catches frame) :key #'car)) diff --git a/src/code/interr.lisp b/src/code/interr.lisp index 6ead586..cfebae2 100644 --- a/src/code/interr.lisp +++ b/src/code/interr.lisp @@ -227,84 +227,94 @@ ;;; results. (defvar *current-internal-error* nil) +;;; This is needed for restarting XEPs, which do not bind anything but +;;; also do not save their own BSP, and we need to discard the +;;; bindings made by the error handling machinery. +#!+unwind-to-frame-and-call-vop +(defvar *interr-current-bsp* nil) + (defun internal-error (context continuable) (declare (type system-area-pointer context)) (declare (ignore continuable)) (/show0 "entering INTERNAL-ERROR, CONTEXT=..") (/hexstr context) - (infinite-error-protect - (/show0 "about to bind ALIEN-CONTEXT") - (let* ((alien-context (locally - (declare (optimize (inhibit-warnings 3))) - (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) + (let (#!+unwind-to-frame-and-call-vop + (*interr-current-bsp* + ;; Needs to be done before anything is bound + (%primitive sb!c:current-binding-pointer))) + (infinite-error-protect + (/show0 "about to bind ALIEN-CONTEXT") + (let* ((alien-context (locally + (declare (optimize (inhibit-warnings 3))) + (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) - ;; There's a limit to how much error reporting we can usefully - ;; do before initialization is complete, but try to be a little - ;; bit helpful before we die. - (/show0 "back from INTERNAL-ERROR-ARGS, ERROR-NUMBER=..") - (/hexstr error-number) - (/show0 "cold/low ARGUMENTS=..") - (/hexstr arguments) - (unless *cold-init-complete-p* - (%primitive print "can't recover from error in cold init, halting") - (%primitive sb!c:halt)) + ;; There's a limit to how much error reporting we can usefully + ;; do before initialization is complete, but try to be a little + ;; bit helpful before we die. + (/show0 "back from INTERNAL-ERROR-ARGS, ERROR-NUMBER=..") + (/hexstr error-number) + (/show0 "cold/low ARGUMENTS=..") + (/hexstr arguments) + (unless *cold-init-complete-p* + (%primitive print "can't recover from error in cold init, halting") + (%primitive sb!c:halt)) - (with-interrupt-bindings - (multiple-value-bind (name sb!debug:*stack-top-hint*) - (find-interrupted-name-and-frame) - (/show0 "back from FIND-INTERRUPTED-NAME") - (let ((*current-internal-error* error-number) - (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 ((and (functionp handler) - (internal-error-args-ok arguments handler)) - (macrolet ((arg (n) - `(sb!di::sub-access-debug-var-slot - fp (nth ,n arguments) alien-context))) - (ecase (length arguments) - (0 (funcall handler name)) - (1 (funcall handler name (arg 0))) - (2 (funcall handler name (arg 0) (arg 1))) - (3 (funcall handler name (arg 0) (arg 1) (arg 2)))))) - ((typep handler '(or symbol cons)) - (error 'type-error - :datum (sb!di::sub-access-debug-var-slot - fp (first arguments) alien-context) - :expected-type handler)) - ((eql handler 0) ; if (DEFERR x) was inadvertently omitted - (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)))) - (t ; wtf? - (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)))))))))))) + (with-interrupt-bindings + (multiple-value-bind (name sb!debug:*stack-top-hint*) + (find-interrupted-name-and-frame) + (/show0 "back from FIND-INTERRUPTED-NAME") + (let ((*current-internal-error* error-number) + (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 ((and (functionp handler) + (internal-error-args-ok arguments handler)) + (macrolet ((arg (n) + `(sb!di::sub-access-debug-var-slot + fp (nth ,n arguments) alien-context))) + (ecase (length arguments) + (0 (funcall handler name)) + (1 (funcall handler name (arg 0))) + (2 (funcall handler name (arg 0) (arg 1))) + (3 (funcall handler name (arg 0) (arg 1) (arg 2)))))) + ((typep handler '(or symbol cons)) + (error 'type-error + :datum (sb!di::sub-access-debug-var-slot + fp (first arguments) alien-context) + :expected-type handler)) + ((eql handler 0) ; if (DEFERR x) was inadvertently omitted + (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)))) + (t ; wtf? + (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))))))))))))) (defun control-stack-exhausted-error () (let ((sb!debug:*stack-top-hint* nil)) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |