Menu
▾
▴
[Sbcl-commits] master: lazy *STACK-TOP-HINT*s
|
From: Nikodemus S. <de...@us...> - 2012-05-21 05:43:51
|
The branch "master" has been updated in SBCL:
via 6e60dc9f79037ab84f5bfd8568979c24291c9922 (commit)
from a2fd28fb6d0b3d8d230a7c933db352f80891ac1c (commit)
- Log -----------------------------------------------------------------
commit 6e60dc9f79037ab84f5bfd8568979c24291c9922
Author: Nikodemus Siivola <nik...@ra...>
Date: Sat May 19 11:44:03 2012 +0300
lazy *STACK-TOP-HINT*s
Allow binding it to a symbol, which is resolved when entering the debugger:
it denotes the name of the first uninteresting frame.
This simplifies ERROR, CERROR, BREAK, %BREAK, and makes interrupts more
efficient as we no longer need to find the interrupted frame when entering
an interupt handler.
It also makes (handler-bind ((error #'invoke-debugger)) ...) once again gain
the benefits of the stack top hint, which we lost when we ceased the provide
the hint around the call to SIGNAL for efficiency reasons. Best of both
worlds, one hopes.
---
package-data-list.lisp-expr | 1 +
src/code/cold-error.lisp | 30 +++++------------
src/code/debug.lisp | 71 +++++++++++++++++++++++++++--------------
src/code/interr.lisp | 18 ++++++++++
src/code/parse-defmacro.lisp | 2 +-
src/code/target-signal.lisp | 31 +++++++++---------
6 files changed, 91 insertions(+), 62 deletions(-)
diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 7fe92da..a52925b 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1827,6 +1827,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
"%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"
diff --git a/src/code/cold-error.lisp b/src/code/cold-error.lisp
index f61708f..966d189 100644
--- a/src/code/cold-error.lisp
+++ b/src/code/cold-error.lisp
@@ -87,15 +87,6 @@
(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.
@@ -110,16 +101,13 @@
(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
@@ -130,9 +118,8 @@
'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)
@@ -144,7 +131,7 @@
(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)
@@ -154,7 +141,8 @@
"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)
diff --git a/src/code/debug.lisp b/src/code/debug.lisp
index 2558ba3..24f3106 100644
--- a/src/code/debug.lisp
+++ b/src/code/debug.lisp
@@ -62,12 +62,13 @@ provide bindings for printer control variables.")
;;; 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)
@@ -555,35 +556,57 @@ thread, NIL otherwise."
(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)
+ (let ((*stack-top-hint* (resolve-stack-top-hint)))
- ;; 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
+ ;; 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&")
diff --git a/src/code/interr.lisp b/src/code/interr.lisp
index e00663d..3e0e9ae 100644
--- a/src/code/interr.lisp
+++ b/src/code/interr.lisp
@@ -393,6 +393,24 @@
(/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))))
;;;; INTERNAL-ERROR signal handler
diff --git a/src/code/parse-defmacro.lisp b/src/code/parse-defmacro.lisp
index 4857679..0ddf097 100644
--- a/src/code/parse-defmacro.lisp
+++ b/src/code/parse-defmacro.lisp
@@ -342,7 +342,7 @@
;;; 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
diff --git a/src/code/target-signal.lisp b/src/code/target-signal.lisp
index 840604e..7394695 100644
--- a/src/code/target-signal.lisp
+++ b/src/code/target-signal.lisp
@@ -44,23 +44,22 @@
;; 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
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|