X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug.lisp;h=c7f6d581ff91a59f5cf4a0f8e1eb59f1e68f7c8c;hb=672b2f6cb751566526c7f3bb3de6b7d8424760e2;hp=e47ac172f45c6088d7277611ca5c0211973ca0be;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/src/code/debug.lisp b/src/code/debug.lisp index e47ac17..c7f6d58 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 @@ -160,29 +170,40 @@ Other commands: ;;;; BACKTRACE +(defun map-backtrace (thunk &key (start 0) (count most-positive-fixnum)) + (loop + with result = nil + for index upfrom 0 + for frame = (if *in-the-debugger* + *current-frame* + (sb!di:top-frame)) + then (sb!di:frame-down frame) + until (null frame) + when (<= start index) do + (if (minusp (decf count)) + (return result) + (setf result (funcall thunk frame))) + finally (return result))) + (defun backtrace (&optional (count most-positive-fixnum) (stream *debug-io*)) #!+sb-doc "Show a listing of the call stack going down from the current frame. In the debugger, the current frame is indicated by the prompt. COUNT is how many frames to show." (fresh-line stream) - (do ((frame (if *in-the-debugger* *current-frame* (sb!di:top-frame)) - (sb!di:frame-down frame)) - (count count (1- count))) - ((or (null frame) (zerop count))) - (print-frame-call frame stream :number t)) + (map-backtrace (lambda (frame) + (print-frame-call frame stream :number t)) + :count count) (fresh-line stream) (values)) (defun backtrace-as-list (&optional (count most-positive-fixnum)) #!+sb-doc "Return a list representing the current BACKTRACE." - (do ((reversed-result nil) - (frame (if *in-the-debugger* *current-frame* (sb!di:top-frame)) - (sb!di:frame-down frame)) - (count count (1- count))) - ((or (null frame) (zerop count)) - (nreverse reversed-result)) - (push (frame-call-as-list frame) reversed-result))) + (let ((reversed-result (list))) + (map-backtrace (lambda (frame) + (push (frame-call-as-list frame) reversed-result)) + :count count) + (nreverse reversed-result))) (defun frame-call-as-list (frame) (multiple-value-bind (name args) (frame-call frame) @@ -223,51 +244,43 @@ 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 map-frame-args (thunk frame) + (let ((debug-fun (sb!di:frame-debug-fun frame))) + (dolist (element (sb!di:debug-fun-lambda-list debug-fun)) + (funcall thunk element)))) + (defun frame-args-as-list (frame) - (let ((debug-fun (sb!di:frame-debug-fun frame)) - (loc (sb!di:frame-code-location frame)) - (reversed-result nil)) - (handler-case - (progn - (dolist (ele (sb!di:debug-fun-lambda-list debug-fun)) - (lambda-list-element-dispatch ele - :required ((push (frame-call-arg ele loc frame) reversed-result)) - :optional ((push (frame-call-arg (second ele) loc frame) - reversed-result)) - :keyword ((push (second ele) reversed-result) - (push (frame-call-arg (third ele) loc frame) - reversed-result)) - :deleted ((push (frame-call-arg ele loc frame) reversed-result)) - :rest ((lambda-var-dispatch (second ele) loc - nil - (progn - (setf reversed-result - (append (reverse (sb!di:debug-var-value - (second ele) frame)) - reversed-result)) - (return)) - (push (make-unprintable-object - "unavailable &REST argument") - reversed-result))))) - ;; As long as we do an ordinary return (as opposed to SIGNALing - ;; a CONDITION) from the DOLIST above: - (nreverse reversed-result)) - (sb!di:lambda-list-unavailable - () - (make-unprintable-object "unavailable lambda list"))))) -(legal-fun-name-p '(lambda ())) + (handler-case + (let ((location (sb!di:frame-code-location frame)) + (reversed-result nil)) + (block enumerating + (map-frame-args + (lambda (element) + (lambda-list-element-dispatch element + :required ((push (frame-call-arg element location frame) reversed-result)) + :optional ((push (frame-call-arg (second element) location frame) + reversed-result)) + :keyword ((push (second element) reversed-result) + (push (frame-call-arg (third element) location frame) + reversed-result)) + :deleted ((push (frame-call-arg element location frame) reversed-result)) + :rest ((lambda-var-dispatch (second element) location + nil + (progn + (setf reversed-result + (append (reverse (sb!di:debug-var-value + (second element) frame)) + reversed-result)) + (return-from enumerating)) + (push (make-unprintable-object + "unavailable &REST argument") + reversed-result))))) + frame)) + (nreverse reversed-result)) + (sb!di:lambda-list-unavailable () + (make-unprintable-object "unavailable lambda list")))) + (defvar *show-entry-point-details* nil) (defun clean-xep (name args) @@ -318,9 +331,7 @@ is how many frames to show." (multiple-value-bind (name args) (clean-name-and-args (sb!di:debug-fun-name debug-fun) (frame-args-as-list frame)) - (values name args - (when *show-entry-point-details* - (sb!di:debug-fun-kind debug-fun))))))) + (values name args (sb!di:debug-fun-kind debug-fun)))))) (defun ensure-printable-object (object) (handler-case @@ -471,28 +482,20 @@ is how many frames to show." (nreverse (mapcar #'cdr *debug-print-variable-alist*)) (apply fun rest))))))) -;;; the ordinary ANSI case of INVOKE-DEBUGGER, when not suppressed by -;;; command-line --disable-debugger option (defun invoke-debugger (condition) #!+sb-doc "Enter the debugger." - (let ((old-hook *debugger-hook*)) - (when old-hook - (let ((*debugger-hook* nil)) - (funcall old-hook condition old-hook)))) + ;; call *INVOKE-DEBUGGER-HOOK* first, so that *DEBUGGER-HOOK* is not + ;; called when the debugger is disabled (let ((old-hook *invoke-debugger-hook*)) (when old-hook (let ((*invoke-debugger-hook* nil)) (funcall old-hook condition old-hook)))) - - ;; Note: CMU CL had (SB-UNIX:UNIX-SIGSETMASK 0) here, to reset the - ;; signal state in the case that we wind up in the debugger as a - ;; result of something done by a signal handler. It's not - ;; altogether obvious that this is necessary, and indeed SBCL has - ;; not been doing it since 0.7.8.5. But nobody seems altogether - ;; convinced yet - ;; -- dan 2003.11.11, based on earlier comment of WHN 2002-09-28 + (let ((old-hook *debugger-hook*)) + (when old-hook + (let ((*debugger-hook* nil)) + (funcall old-hook condition old-hook)))) ;; We definitely want *PACKAGE* to be of valid type. ;; @@ -515,8 +518,22 @@ reset to ~S." (funcall-with-debug-io-syntax #'%invoke-debugger condition)) -(defun %invoke-debugger (condition) +(defun %print-debugger-invocation-reason (condition stream) + (format stream "~2&") + ;; Note: Ordinarily it's only a matter of taste whether to use + ;; FORMAT "~<...~:>" or to use PPRINT-LOGICAL-BLOCK directly, but + ;; until bug 403 is fixed, PPRINT-LOGICAL-BLOCK (STREAM NIL) is + ;; definitely preferred, because the FORMAT alternative was acting odd. + (pprint-logical-block (stream nil) + (format stream + "debugger invoked on a ~S~@[ in thread ~A~]: ~2I~_~A" + (type-of condition) + #!+sb-thread sb!thread:*current-thread* + #!-sb-thread nil + condition)) + (terpri stream)) +(defun %invoke-debugger (condition) (let ((*debug-condition* condition) (*debug-restarts* (compute-restarts condition)) (*nested-debug-condition* nil)) @@ -526,13 +543,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.) - (format *error-output* - "~2&~@~%" - (type-of *debug-condition*) - #!+sb-thread sb!thread:*current-thread* - #!-sb-thread nil - *debug-condition*) + (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*))) @@ -544,12 +556,12 @@ reset to ~S." '*debug-condition* ndc-type '*nested-debug-condition*)) - (when (typep condition 'cell-error) + (when (typep *nested-debug-condition* 'cell-error) ;; what we really want to know when it's e.g. an UNBOUND-VARIABLE: (format *error-output* "~&(CELL-ERROR-NAME ~S) = ~S~%" - '*debug-condition* - (cell-error-name *debug-condition*))))) + '*nested-debug-condition* + (cell-error-name *nested-debug-condition*))))) (let ((background-p (sb!thread::debugger-wait-until-foreground-thread *debug-io*))) @@ -646,19 +658,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 () - (when (eql *invoke-debugger-hook* nil) - (setf *debug-io* *error-output* - *invoke-debugger-hook* 'debugger-disabled-hook))) + ;; *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 *debug-io* *query-io* - *invoke-debugger-hook* nil))) - -(setf *debug-io* *query-io*) + (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) @@ -696,6 +719,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 @@ -707,7 +735,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 @@ -718,6 +747,14 @@ reset to ~S." "When set, avoid calling INVOKE-DEBUGGER recursively when errors occur while executing in the debugger.") +(defun debug-read (stream) + (declare (type stream stream)) + (let* ((eof-marker (cons nil nil)) + (form (read stream nil eof-marker))) + (if (eq form eof-marker) + (abort) + form))) + (defun debug-loop-fun () (let* ((*debug-command-level* (1+ *debug-command-level*)) (*real-stack-top* (sb!di:top-frame)) @@ -729,41 +766,45 @@ 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) - (when *flush-debug-errors* - (clear-input *debug-io*) - (princ condition *debug-io*) - (format *debug-io* - "~&error flushed (because ~ + (catch 'debug-loop-catcher + (handler-bind ((error (lambda (condition) + (when *flush-debug-errors* + (clear-input *debug-io*) + (princ condition *debug-io*) + (format *debug-io* + "~&error flushed (because ~ ~S is set)" - '*flush-debug-errors*) - (/show0 "throwing DEBUG-LOOP-CATCHER") - (throw 'debug-loop-catcher nil))))) - ;; We have to bind LEVEL for the restart function created by - ;; WITH-SIMPLE-RESTART. - (let ((level *debug-command-level*) - (restart-commands (make-restart-commands))) - (with-simple-restart (abort - "~@" - level) - (debug-prompt *debug-io*) - (force-output *debug-io*) - (let* ((exp (read *debug-io*)) - (cmd-fun (debug-command-p exp restart-commands))) - (cond ((not cmd-fun) - (debug-eval-print exp)) - ((consp cmd-fun) - (format *debug-io* - "~&Your command, ~S, is ambiguous:~%" - exp) - (dolist (ele cmd-fun) - (format *debug-io* " ~A~%" ele))) - (t - (funcall cmd-fun)))))))))))) + '*flush-debug-errors*) + (/show0 "throwing DEBUG-LOOP-CATCHER") + (throw 'debug-loop-catcher nil))))) + ;; We have to bind LEVEL for the restart function created by + ;; WITH-SIMPLE-RESTART. + (let ((level *debug-command-level*) + (restart-commands (make-restart-commands))) + (flush-standard-output-streams) + (debug-prompt *debug-io*) + (force-output *debug-io*) + (let* ((exp (debug-read *debug-io*)) + (cmd-fun (debug-command-p exp restart-commands))) + (with-simple-restart (abort + "~@" + level) + (cond ((not cmd-fun) + (debug-eval-print exp)) + ((consp cmd-fun) + (format *debug-io* + "~&Your command, ~S, is ambiguous:~%" + exp) + (dolist (ele cmd-fun) + (format *debug-io* " ~A~%" ele))) + (t + (funcall cmd-fun)))))))))))) (defun debug-eval-print (expr) (/noshow "entering DEBUG-EVAL-PRINT" expr) @@ -1095,8 +1136,8 @@ reset to ~S." (let ((num (read-if-available :prompt))) (when (eq num :prompt) (show-restarts *debug-restarts* *debug-io*) - (write-string "restart: ") - (force-output) + (write-string "restart: " *debug-io*) + (force-output *debug-io*) (setf num (read *debug-io*))) (let ((restart (typecase num (unsigned-byte @@ -1301,15 +1342,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 @@ -1324,24 +1391,146 @@ reset to ~S." (!def-debug-command "SLURP" () (loop while (read-char-no-hang *standard-input*))) +;;; RETURN-FROM-FRAME and RESTART-FRAME + +(defun unwind-to-frame-and-call (frame thunk) + #!+unwind-to-frame-and-call-vop + (flet ((sap-int/fixnum (sap) + ;; On unithreaded X86 *BINDING-STACK-POINTER* and + ;; *CURRENT-CATCH-BLOCK* are negative, so we need to jump through + ;; some hoops to make these calculated values negative too. + (ash (truly-the (signed-byte #.sb!vm:n-word-bits) + (sap-int sap)) + (- sb!vm::n-fixnum-tag-bits)))) + ;; To properly unwind the stack, we need three pieces of information: + ;; * The unwind block that should be active after the unwind + ;; * 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 (sap-int/fixnum (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 + (sb!di::frame-pointer frame) + (find-enclosing-uwp frame) + (lambda () + ;; Before calling the user-specified + ;; function, we need to restore the binding + ;; stack and the catch block. The unwind block + ;; is taken care of by the VOP. + (sb!vm::%primitive sb!vm::unbind-to-here + unbind-to) + (setf sb!vm::*current-catch-block* block) + (funcall thunk))))) + #!-unwind-to-frame-and-call-vop + (let ((tag (gensym))) + (sb!di:replace-frame-catch-tag frame + 'sb!c:debug-catch-tag + tag) + (throw tag thunk))) + +(defun find-binding-stack-pointer (frame) + #!-stack-grows-downward-not-upward + (declare (ignore frame)) + #!-stack-grows-downward-not-upward + (error "Not implemented on this architecture") + #!+stack-grows-downward-not-upward + (let ((bsp (sb!vm::binding-stack-pointer-sap)) + (unbind-to nil) + (fp (sb!di::frame-pointer frame)) + (start (int-sap (ldb (byte #.sb!vm:n-word-bits 0) + (ash sb!vm:*binding-stack-start* + sb!vm:n-fixnum-tag-bits))))) + ;; Walk the binding stack looking for an entry where the symbol is + ;; an unbound-symbol marker and the value is equal to the frame + ;; pointer. These entries are inserted into the stack by the + ;; BIND-SENTINEL VOP and removed by UNBIND-SENTINEL (inserted into + ;; the function during IR2). If an entry wasn't found, the + ;; function that the frame corresponds to wasn't compiled with a + ;; high enough debug setting, and can't be restarted / returned + ;; from. + (loop until (sap= bsp start) + do (progn + (setf bsp (sap+ bsp + (- (* sb!vm:binding-size sb!vm:n-word-bytes)))) + (let ((symbol (sap-ref-word bsp (* sb!vm:binding-symbol-slot + sb!vm:n-word-bytes))) + (value (sap-ref-sap bsp (* sb!vm:binding-value-slot + sb!vm:n-word-bytes)))) + (when (eql symbol sb!vm:unbound-marker-widetag) + (when (sap= value fp) + (setf unbind-to bsp)))))) + unbind-to)) + +(defun find-enclosing-catch-block (frame) + ;; Walk the catch block chain looking for the first entry with an address + ;; higher than the pointer for FRAME or a null pointer. + (let* ((frame-pointer (sb!di::frame-pointer frame)) + (current-block (int-sap (ldb (byte #.sb!vm:n-word-bits 0) + (ash sb!vm::*current-catch-block* + sb!vm:n-fixnum-tag-bits)))) + (enclosing-block (loop for block = current-block + then (sap-ref-sap block + (* sb!vm:catch-block-previous-catch-slot + sb!vm::n-word-bytes)) + when (or (zerop (sap-int block)) + (sap> block frame-pointer)) + return block))) + enclosing-block)) + +(defun find-enclosing-uwp (frame) + ;; Walk the UWP chain looking for the first entry with an address + ;; higher than the pointer for FRAME or a null pointer. + (let* ((frame-pointer (sb!di::frame-pointer frame)) + (current-uwp (int-sap (ldb (byte #.sb!vm:n-word-bits 0) + (ash sb!vm::*current-unwind-protect-block* + sb!vm:n-fixnum-tag-bits)))) + (enclosing-uwp (loop for uwp-block = current-uwp + then (sap-ref-sap uwp-block + sb!vm:unwind-block-current-uwp-slot) + when (or (zerop (sap-int uwp-block)) + (sap> uwp-block frame-pointer)) + return uwp-block))) + enclosing-uwp)) + (!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) + #!+unwind-to-frame-and-call-vop + (not (null (find-binding-stack-pointer frame))) + #!-unwind-to-frame-and-call-vop + (find 'sb!c:debug-catch-tag (sb!di::frame-catches frame) :key #'car)) + +;; Hack: ensure that *U-T-F-F* has a tls index. +#!+unwind-to-frame-and-call-vop +(let ((sb!vm::*unwind-to-frame-function* (lambda ())))) + ;;;; debug loop command utilities