"%COERCE-CALLABLE-TO-FUN" "FUN-SUBTYPE"
"*MAXIMUM-ERROR-DEPTH*" "%SET-SYMBOL-PLIST"
"INFINITE-ERROR-PROTECT"
+ "FIND-CALLER-OF-NAMED-FRAME"
"FIND-CALLER-NAME-AND-FRAME"
"FIND-INTERRUPTED-NAME-AND-FRAME"
"%SET-SYMBOL-VALUE" "%SET-SYMBOL-GLOBAL-VALUE" "%SET-SYMBOL-PACKAGE"
(funcall (cdr handler) condition)))))
nil))
-;;; a shared idiom in ERROR, CERROR, and BREAK: The user probably
-;;; doesn't want to hear that the error "occurred in" one of these
-;;; functions, so we try to point the top of the stack to our caller
-;;; instead.
-(eval-when (:compile-toplevel :execute)
- (defmacro-mundanely maybe-find-stack-top-hint ()
- `(or sb!debug:*stack-top-hint*
- (nth-value 1 (find-caller-name-and-frame)))))
-
(defun error (datum &rest arguments)
#!+sb-doc
"Invoke the signal facility on a condition formed from DATUM and ARGUMENTS.
(infinite-error-protect
(let ((condition (coerce-to-condition datum arguments
- 'simple-error 'error)))
+ 'simple-error 'error))
+ (sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'error)))
(/show0 "done coercing DATUM to CONDITION")
(/show0 "signalling CONDITION from within ERROR")
- (let ((sb!debug:*stack-top-hint* nil))
- (signal condition))
+ (signal condition)
(/show0 "done signalling CONDITION within ERROR")
- ;; Finding the stack top hint is pretty expensive, so don't do
- ;; it until we know we need the debugger.
- (let ((sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
- (invoke-debugger condition)))))
+ (invoke-debugger condition))))
(defun cerror (continue-string datum &rest arguments)
(infinite-error-protect
'simple-error
'cerror)))
(with-condition-restarts condition (list (find-restart 'continue))
- (let ((sb!debug:*stack-top-hint* nil))
- (signal condition))
- (let ((sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
+ (let ((sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'cerror)))
+ (signal condition)
(invoke-debugger condition))))))
nil)
(defun %break (what &optional (datum "break") &rest arguments)
(infinite-error-protect
(with-simple-restart (continue "Return from ~S." what)
- (let ((sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
+ (let ((sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* '%break)))
(invoke-debugger
(coerce-to-condition datum arguments 'simple-condition what)))))
nil)
"Print a message and invoke the debugger without allowing any possibility
of condition handling occurring."
(declare (optimize (sb!c::rest-conversion 0)))
- (let ((*debugger-hook* nil)) ; as specifically required by ANSI
+ (let ((*debugger-hook* nil) ; as specifically required by ANSI
+ (sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'break)))
(apply #'%break 'break datum arguments)))
(defun warn (datum &rest arguments)
;;; nestedness inside debugger command loops
(defvar *debug-command-level* 0)
-;;; If this is bound before the debugger is invoked, it is used as the
-;;; stack top by the debugger.
+;;; If this is bound before the debugger is invoked, it is used as the stack
+;;; top by the debugger. It can either be the first interesting frame, or the
+;;; name of the last uninteresting frame.
(defvar *stack-top-hint* nil)
-(defvar *stack-top* nil)
(defvar *real-stack-top* nil)
+(defvar *stack-top* nil)
(defvar *current-frame* nil)
(progv (list variable) (list nil)
(funcall old-hook condition old-hook)))))
+;;; We can bind *stack-top-hint* to a symbol, in which case this function will
+;;; resolve that hint lazily before we enter the debugger.
+(defun resolve-stack-top-hint ()
+ (let ((hint *stack-top-hint*)
+ (*stack-top-hint* nil))
+ (cond
+ ;; No hint, just keep the debugger guts out.
+ ((not hint)
+ (find-caller-name-and-frame))
+ ;; Interrupted. Look for the interrupted frame -- if we don't find one
+ ;; this falls back to the next case.
+ ((and (eq hint 'invoke-interruption)
+ (nth-value 1 (find-interrupted-name-and-frame))))
+ ;; Name of the first uninteresting frame.
+ ((symbolp hint)
+ (find-caller-of-named-frame hint))
+ ;; We already have a resolved hint.
+ (t
+ hint))))
+
(defun invoke-debugger (condition)
#!+sb-doc
"Enter the debugger."
- ;; call *INVOKE-DEBUGGER-HOOK* first, so that *DEBUGGER-HOOK* is not
- ;; called when the debugger is disabled
- (run-hook '*invoke-debugger-hook* condition)
- (run-hook '*debugger-hook* condition)
-
- ;; We definitely want *PACKAGE* to be of valid type.
- ;;
- ;; Elsewhere in the system, we use the SANE-PACKAGE function for
- ;; this, but here causing an exception just as we're trying to handle
- ;; an exception would be confusing, so instead we use a special hack.
- (unless (and (packagep *package*)
- (package-name *package*))
- (setf *package* (find-package :cl-user))
- (format *error-output*
- "The value of ~S was not an undeleted PACKAGE. It has been
+ (let ((*stack-top-hint* (resolve-stack-top-hint)))
+
+ ;; call *INVOKE-DEBUGGER-HOOK* first, so that *DEBUGGER-HOOK* is not
+ ;; called when the debugger is disabled
+ (run-hook '*invoke-debugger-hook* condition)
+ (run-hook '*debugger-hook* condition)
+
+ ;; We definitely want *PACKAGE* to be of valid type.
+ ;;
+ ;; Elsewhere in the system, we use the SANE-PACKAGE function for
+ ;; this, but here causing an exception just as we're trying to handle
+ ;; an exception would be confusing, so instead we use a special hack.
+ (unless (and (packagep *package*)
+ (package-name *package*))
+ (setf *package* (find-package :cl-user))
+ (format *error-output*
+ "The value of ~S was not an undeleted PACKAGE. It has been
reset to ~S."
- '*package* *package*))
+ '*package* *package*))
- ;; Before we start our own output, finish any pending output.
- ;; Otherwise, if the user tried to track the progress of his program
- ;; using PRINT statements, he'd tend to lose the last line of output
- ;; or so, which'd be confusing.
- (flush-standard-output-streams)
+ ;; Before we start our own output, finish any pending output.
+ ;; Otherwise, if the user tried to track the progress of his program
+ ;; using PRINT statements, he'd tend to lose the last line of output
+ ;; or so, which'd be confusing.
+ (flush-standard-output-streams)
- (funcall-with-debug-io-syntax #'%invoke-debugger condition))
+ (funcall-with-debug-io-syntax #'%invoke-debugger condition)))
(defun %print-debugger-invocation-reason (condition stream)
(format stream "~2&")
(/show0 "trapped DEBUG-CONDITION")
(values "<error finding interrupted name -- trapped debug-condition>"
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))))
\f
;;;; INTERNAL-ERROR signal handler
;;; We save space in macro definitions by calling this function.
(defun arg-count-error (context name args lambda-list minimum maximum)
(let (#-sb-xc-host
- (sb!debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame))))
+ (sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'arg-count-error)))
(error 'arg-count-error
:kind context
:name name
;; mechanism there are no extra frames on the stack from a
;; previous signal handler when the next signal is delivered
;; provided there is no WITH-INTERRUPTS.
- (let ((*unblock-deferrables-on-enabling-interrupts-p* t))
+ (let ((*unblock-deferrables-on-enabling-interrupts-p* t)
+ (sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'invoke-interruption)))
(with-interrupt-bindings
- (let ((sb!debug:*stack-top-hint*
- (nth-value 1 (sb!kernel:find-interrupted-name-and-frame))))
- (sb!thread::without-thread-waiting-for (:already-without-interrupts t)
- (allow-with-interrupts
- (nlx-protect (funcall function)
- ;; We've been running with deferrables
- ;; blocked in Lisp called by a C signal
- ;; handler. If we return normally the sigmask
- ;; in the interrupted context is restored.
- ;; However, if we do an nlx the operating
- ;; system will not restore it for us.
- (when *unblock-deferrables-on-enabling-interrupts-p*
- ;; This means that storms of interrupts
- ;; doing an nlx can still run out of stack.
- (unblock-deferrable-signals))))))))))
+ (sb!thread::without-thread-waiting-for (:already-without-interrupts t)
+ (allow-with-interrupts
+ (nlx-protect (funcall function)
+ ;; We've been running with deferrables
+ ;; blocked in Lisp called by a C signal
+ ;; handler. If we return normally the sigmask
+ ;; in the interrupted context is restored.
+ ;; However, if we do an nlx the operating
+ ;; system will not restore it for us.
+ (when *unblock-deferrables-on-enabling-interrupts-p*
+ ;; This means that storms of interrupts
+ ;; doing an nlx can still run out of stack.
+ (unblock-deferrable-signals)))))))))
(defmacro in-interruption ((&key) &body body)
#!+sb-doc
projects / sbcl.git / commitdiff