X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug.lisp;h=e9c620e44aa03a672fb2c620c263076cb80343a6;hb=f68d0f59fa6f9c448b3a147b5940937af03f940a;hp=c829c182b1c0f7a0eeb747f4c2691395c11147d0;hpb=296162b9fe8ea26c92367cfb86965d3a57937aad;p=sbcl.git diff --git a/src/code/debug.lisp b/src/code/debug.lisp index c829c18..e9c620e 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -120,9 +120,14 @@ Inspecting frames: SOURCE [n] displays frame's source form with n levels of enclosing forms. Stepping: - STEP Selects the CONTINUE restart if one exists and starts + START Selects the CONTINUE restart if one exists and starts single-stepping. Single stepping affects only code compiled with under high DEBUG optimization quality. See User Manual for details. + STEP Steps into the current form. + NEXT Steps over the current form. + OUT Stops stepping temporarily, but resumes it when the topmost frame that + was stepped into returns. + STOP Stops single-stepping. Function and macro commands: (SB-DEBUG:ARG n) @@ -136,6 +141,11 @@ Other commands: current frame, if this frame was compiled with a sufficiently high DEBUG optimization quality. + RESTART-FRAME + Restart execution of the current frame, if this frame is for a + global function which was compiled with a sufficiently high + DEBUG optimization quality. + SLURP Discard all pending input on *STANDARD-INPUT*. (This can be useful when the debugger was invoked to handle an error in @@ -223,17 +233,6 @@ is how many frames to show." ) ; EVAL-WHEN -;;; This is used in constructing arg lists for debugger printing when -;;; the arg list is unavailable, some arg is unavailable or unused, etc. -(defstruct (unprintable-object - (:constructor make-unprintable-object (string)) - (:print-object (lambda (x s) - (print-unreadable-object (x s) - (write-string (unprintable-object-string x) - s)))) - (:copier nil)) - string) - ;;; Extract the function argument values for a debug frame. (defun frame-args-as-list (frame) (let ((debug-fun (sb!di:frame-debug-fun frame)) @@ -267,7 +266,7 @@ is how many frames to show." (sb!di:lambda-list-unavailable () (make-unprintable-object "unavailable lambda list"))))) -(legal-fun-name-p '(lambda ())) + (defvar *show-entry-point-details* nil) (defun clean-xep (name args) @@ -523,7 +522,6 @@ reset to ~S." (terpri stream)) (defun %invoke-debugger (condition) - (let ((*debug-condition* condition) (*debug-restarts* (compute-restarts condition)) (*nested-debug-condition* nil)) @@ -533,7 +531,8 @@ reset to ~S." ;; when people redirect *ERROR-OUTPUT*, they could reasonably ;; expect to see error messages logged there, regardless of what ;; the debugger does afterwards.) - (%print-debugger-invocation-reason condition *error-output*) + (unless (typep condition 'step-condition) + (%print-debugger-invocation-reason condition *error-output*)) (error (condition) (setf *nested-debug-condition* condition) (let ((ndc-type (type-of *nested-debug-condition*))) @@ -647,24 +646,30 @@ reset to ~S." "Argh! error within --disable-debugger error handling")) (failure-quit :recklessly-p t))))) +(defvar *old-debugger-hook* nil) + ;;; halt-on-failures and prompt-on-failures modes, suitable for ;;; noninteractive and interactive use respectively (defun disable-debugger () - ;; Why conditionally? Why not disable it even if user has frobbed - ;; this hook? We could just save the old value in case of a later - ;; ENABLE-DEBUGGER. - (when (eql *invoke-debugger-hook* nil) - ;; *DEBUG-IO* used to be set here to *ERROR-OUTPUT* which is sort - ;; of unexpected but mostly harmless, but then ENABLE-DEBUGGER had - ;; to set it to a suitable value again and be very careful, - ;; especially if the user has also set it. -- MG 2005-07-15 - (setf *invoke-debugger-hook* 'debugger-disabled-hook) - (sb!alien:alien-funcall (sb!alien:extern-alien "disable_lossage_handler" (function sb!alien:void))))) + ;; *DEBUG-IO* used to be set here to *ERROR-OUTPUT* which is sort + ;; of unexpected but mostly harmless, but then ENABLE-DEBUGGER had + ;; to set it to a suitable value again and be very careful, + ;; especially if the user has also set it. -- MG 2005-07-15 + (unless (eq *invoke-debugger-hook* 'debugger-disabled-hook) + (setf *old-debugger-hook* *invoke-debugger-hook* + *invoke-debugger-hook* 'debugger-disabled-hook)) + ;; This is not inside the UNLESS to ensure that LDB is disabled + ;; regardless of what the old value of *INVOKE-DEBUGGER-HOOK* was. + ;; This might matter for example when restoring a core. + (sb!alien:alien-funcall (sb!alien:extern-alien "disable_lossage_handler" + (function sb!alien:void)))) (defun enable-debugger () (when (eql *invoke-debugger-hook* 'debugger-disabled-hook) - (setf *invoke-debugger-hook* nil) - (sb!alien:alien-funcall (sb!alien:extern-alien "enable_lossage_handler" (function sb!alien:void))))) + (setf *invoke-debugger-hook* *old-debugger-hook* + *old-debugger-hook* nil)) + (sb!alien:alien-funcall (sb!alien:extern-alien "enable_lossage_handler" + (function sb!alien:void)))) (defun show-restarts (restarts s) (cond ((null restarts) @@ -702,6 +707,11 @@ reset to ~S." (defvar *debug-loop-fun* #'debug-loop-fun "a function taking no parameters that starts the low-level debug loop") +;;; When the debugger is invoked due to a stepper condition, we don't +;;; want to print the current frame before the first prompt for aesthetic +;;; reasons. +(defvar *suppress-frame-print* nil) + ;;; This calls DEBUG-LOOP, performing some simple initializations ;;; before doing so. INVOKE-DEBUGGER calls this to actually get into ;;; the debugger. SB!KERNEL::ERROR-ERROR calls this in emergencies @@ -713,7 +723,8 @@ reset to ~S." (*read-suppress* nil)) (unless (typep *debug-condition* 'step-condition) (clear-input *debug-io*)) - (funcall *debug-loop-fun*))) + (let ((*suppress-frame-print* (typep *debug-condition* 'step-condition))) + (funcall *debug-loop-fun*)))) ;;;; DEBUG-LOOP @@ -743,8 +754,11 @@ reset to ~S." (princ condition *debug-io*) (/show0 "handling d-c by THROWing DEBUG-LOOP-CATCHER") (throw 'debug-loop-catcher nil)))) - (terpri *debug-io*) - (print-frame-call *current-frame* *debug-io* :verbosity 2) + (cond (*suppress-frame-print* + (setf *suppress-frame-print* nil)) + (t + (terpri *debug-io*) + (print-frame-call *current-frame* *debug-io* :verbosity 2))) (loop (catch 'debug-loop-catcher (handler-bind ((error (lambda (condition) @@ -1316,15 +1330,41 @@ reset to ~S." (svref translations form-num) context)))) -;;; step to the next steppable form -(!def-debug-command "STEP" () - (let ((restart (find-restart 'continue *debug-condition*))) - (cond (restart - (setf *stepping* t - *step* t) + +;;; start single-stepping +(!def-debug-command "START" () + (if (typep *debug-condition* 'step-condition) + (format *debug-io* "~&Already single-stepping.~%") + (let ((restart (find-restart 'continue *debug-condition*))) + (cond (restart + (sb!impl::enable-stepping) + (invoke-restart restart)) + (t + (format *debug-io* "~&Non-continuable error, cannot start stepping.~%")))))) + +(defmacro def-step-command (command-name restart-name) + `(!def-debug-command ,command-name () + (if (typep *debug-condition* 'step-condition) + (let ((restart (find-restart ',restart-name *debug-condition*))) + (aver restart) (invoke-restart restart)) - (t - (format *debug-io* "~&Non-continuable error, cannot step.~%"))))) + (format *debug-io* "~&Not currently single-stepping. (Use START to activate the single-stepper)~%")))) + +(def-step-command "STEP" step-into) +(def-step-command "NEXT" step-next) +(def-step-command "STOP" step-continue) + +(!def-debug-command-alias "S" "STEP") +(!def-debug-command-alias "N" "NEXT") + +(!def-debug-command "OUT" () + (if (typep *debug-condition* 'step-condition) + (if sb!impl::*step-out* + (let ((restart (find-restart 'step-out *debug-condition*))) + (aver restart) + (invoke-restart restart)) + (format *debug-io* "~&OUT can only be used step out of frames that were originally stepped into with STEP.~%")) + (format *debug-io* "~&Not currently single-stepping. (Use START to activate the single-stepper)~%"))) ;;; miscellaneous commands @@ -1339,24 +1379,43 @@ reset to ~S." (!def-debug-command "SLURP" () (loop while (read-char-no-hang *standard-input*))) +(defun unwind-to-frame-and-call (frame thunk) + (let ((tag (gensym))) + (sb!di:replace-frame-catch-tag frame + 'sb!c:debug-catch-tag + tag) + (throw tag thunk))) + (!def-debug-command "RETURN" (&optional (return (read-prompting-maybe "return: "))) - (let ((tag (find-if (lambda (x) - (and (typep (car x) 'symbol) - (not (symbol-package (car x))) - (string= (car x) "SB-DEBUG-CATCH-TAG"))) - (sb!di::frame-catches *current-frame*)))) - (if tag - (throw (car tag) - (funcall (sb!di:preprocess-for-eval - return - (sb!di:frame-code-location *current-frame*)) - *current-frame*)) - (format *debug-io* - "~@")))) + and recompiling)~:@>"))) + +(!def-debug-command "RESTART-FRAME" () + (if (frame-has-debug-tag-p *current-frame*) + (let* ((call-list (frame-call-as-list *current-frame*)) + (fun (fdefinition (car call-list)))) + (unwind-to-frame-and-call *current-frame* + (lambda () + (apply fun (cdr call-list))))) + (format *debug-io* + "~@"))) + +(defun frame-has-debug-tag-p (frame) + (find 'sb!c:debug-catch-tag (sb!di::frame-catches frame) :key #'car)) + ;;;; debug loop command utilities