X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug.lisp;h=165a874c86a6f416e7e932d79ebdba8e692218c5;hb=95591ed483dbb8c0846c129953acac1554f28809;hp=e9c620e44aa03a672fb2c620c263076cb80343a6;hpb=f68d0f59fa6f9c448b3a147b5940937af03f940a;p=sbcl.git diff --git a/src/code/debug.lisp b/src/code/debug.lisp index e9c620e..165a874 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -170,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) @@ -234,38 +245,41 @@ is how many frames to show." ) ; EVAL-WHEN ;;; 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"))))) + (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) @@ -317,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 @@ -794,9 +806,21 @@ reset to ~S." (t (funcall cmd-fun)))))))))))) +(defvar *auto-eval-in-frame* t + #!+sb-doc + "When set (the default), evaluations in the debugger's command loop occur + relative to the current frame's environment without the need of debugger + forms that explicitly control this kind of evaluation.") + +(defun debug-eval (expr) + (if (and (fboundp 'compile) *auto-eval-in-frame*) + (sb!di:eval-in-frame *current-frame* expr) + (eval expr))) + (defun debug-eval-print (expr) (/noshow "entering DEBUG-EVAL-PRINT" expr) - (let ((values (multiple-value-list (interactive-eval expr)))) + (let ((values (multiple-value-list + (interactive-eval expr :eval #'debug-eval)))) (/noshow "done with EVAL in DEBUG-EVAL-PRINT") (dolist (value values) (fresh-line *debug-io*) @@ -1259,9 +1283,12 @@ reset to ~S." (values *cached-form-number-translations* *cached-toplevel-form*) (let* ((offset (sb!di:code-location-toplevel-form-offset location)) (res - (ecase (sb!di:debug-source-from d-source) - (:file (get-file-toplevel-form location)) - (:lisp (svref (sb!di:debug-source-name d-source) offset))))) + (cond ((sb!di:debug-source-namestring d-source) + (get-file-toplevel-form location)) + ((sb!di:debug-source-form d-source) + (sb!di:debug-source-form d-source)) + (t (bug "Don't know how to use a DEBUG-SOURCE without ~ + a namestring or a form."))))) (setq *cached-toplevel-form-offset* offset) (values (setq *cached-form-number-translations* (sb!di:form-number-translations res offset)) @@ -1279,7 +1306,7 @@ reset to ~S." (aref (or (sb!di:debug-source-start-positions d-source) (error "no start positions map")) local-tlf-offset)) - (name (sb!di:debug-source-name d-source))) + (name (sb!di:debug-source-namestring d-source))) (unless (eq d-source *cached-debug-source*) (unless (and *cached-source-stream* (equal (pathname *cached-source-stream*) @@ -1379,13 +1406,109 @@ 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: "))) @@ -1414,8 +1537,15 @@ reset to ~S." and recompiling)~:@>"))) (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