X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug.lisp;h=014103c51b622d7664018a449905d23b1275ce2e;hb=1e161456a066b34e4a764fd351217dafc4f4f787;hp=05cef22c98a7355fc897cb0c951302160a3e630d;hpb=74cfbf6d0572b7df1b3492563408a7cb3ae103cf;p=sbcl.git diff --git a/src/code/debug.lisp b/src/code/debug.lisp index 05cef22..014103c 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -198,16 +198,42 @@ is how many frames to show." (values)) (defun backtrace-as-list (&optional (count most-positive-fixnum)) - #!+sb-doc "Return a list representing the current BACKTRACE." + #!+sb-doc + "Return a list representing the current BACKTRACE. + +Objects in the backtrace with dynamic-extent allocation by the current +thread are represented by substitutes to avoid references to them from +leaking outside their legal extent." (let ((reversed-result (list))) (map-backtrace (lambda (frame) - (push (frame-call-as-list frame) reversed-result)) + (let ((frame-list (frame-call-as-list frame))) + (if (listp (cdr frame-list)) + (push (mapcar #'replace-dynamic-extent-object frame-list) + reversed-result) + (push frame-list reversed-result)))) :count count) (nreverse reversed-result))) (defun frame-call-as-list (frame) (multiple-value-bind (name args) (frame-call frame) (cons name args))) + +(defun replace-dynamic-extent-object (obj) + (if (stack-allocated-p obj) + (make-unprintable-object + (handler-case + (format nil "dynamic-extent: ~S" obj) + (error () + "error printing dynamic-extent object"))) + obj)) + +(defun stack-allocated-p (obj) + "Returns T if OBJ is allocated on the stack of the current +thread, NIL otherwise." + (with-pinned-objects (obj) + (let ((sap (int-sap (get-lisp-obj-address obj)))) + (when (sb!vm:control-stack-pointer-valid-p sap nil) + t)))) ;;;; frame printing @@ -221,6 +247,7 @@ is how many frames to show." optional rest keyword + more deleted) `(etypecase ,element (sb!di:debug-var @@ -229,7 +256,8 @@ is how many frames to show." (ecase (car ,element) (:optional ,@optional) (:rest ,@rest) - (:keyword ,@keyword))) + (:keyword ,@keyword) + (:more ,@more))) (symbol (aver (eq ,element :deleted)) ,@deleted))) @@ -267,15 +295,27 @@ is how many frames to show." :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)) + (let ((rest (sb!di:debug-var-value (second element) frame))) + (if (listp rest) + (setf reversed-result (append (reverse rest) reversed-result)) + (push (make-unprintable-object "unavailable &REST argument") + reversed-result)) (return-from enumerating)) (push (make-unprintable-object "unavailable &REST argument") - reversed-result))))) + reversed-result))) + :more ((lambda-var-dispatch (second element) location + nil + (let ((context (sb!di:debug-var-value (second element) frame)) + (count (sb!di:debug-var-value (third element) frame))) + (setf reversed-result + (append (reverse + (multiple-value-list + (sb!c::%more-arg-values context 0 count))) + reversed-result)) + (return-from enumerating)) + (push (make-unprintable-object "unavailable &MORE argument") + reversed-result))))) frame)) (nreverse reversed-result)) (sb!di:lambda-list-unavailable () @@ -317,6 +357,12 @@ is how many frames to show." ;; &AUX-BINDINGS appear in backtraces, so they are ;; left alone for now. --NS 2005-02-28 (case (first name) + ((eval) + ;; The name of an evaluator thunk contains + ;; the source context -- but that makes for a + ;; confusing frame name, since it can look like an + ;; EVAL call with a bogus argument. + (values '#:eval-thunk nil)) ((sb!c::xep sb!c::tl-xep) (clean-xep name args)) ((sb!c::&more-processor) @@ -371,10 +417,17 @@ is how many frames to show." ;; If we hit a &REST arg, then print as many of the values as ;; possible, punting the loop over lambda-list variables since any ;; other arguments will be in the &REST arg's list of values. - (let ((args (ensure-printable-object args))) - (if (listp args) - (format stream "~{ ~_~S~}" args) - (format stream " ~S" args)))) + (let ((print-args (ensure-printable-object args)) + ;; Special case *PRINT-PRETTY* for eval frames: if + ;; *PRINT-LINES* is 1, turn off pretty-printing. + (*print-pretty* + (if (and (eql 1 *print-lines*) + (member name '(eval simple-eval-in-lexenv))) + nil + *print-pretty*))) + (if (listp print-args) + (format stream "~{ ~_~S~}" print-args) + (format stream " ~S" print-args)))) (when kind (format stream "[~S]" kind)))) (when (>= verbosity 2) @@ -820,9 +873,14 @@ and LDB (the low-level debugger). See also ENABLE-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))) + (cond ((not (and (fboundp 'compile) *auto-eval-in-frame*)) + (eval expr)) + ((frame-has-debug-vars-p *current-frame*) + (sb!di:eval-in-frame *current-frame* expr)) + (t + (format *debug-io* "; No debug variables for current frame: ~ + using EVAL instead of EVAL-IN-FRAME.~%") + (eval expr)))) (defun debug-eval-print (expr) (/noshow "entering DEBUG-EVAL-PRINT" expr) @@ -1209,19 +1267,29 @@ and LDB (the low-level debugger). See also ENABLE-DEBUGGER." (location (sb!di:frame-code-location *current-frame*)) (prefix (read-if-available nil)) (any-p nil) - (any-valid-p nil)) + (any-valid-p nil) + (more-context nil) + (more-count nil)) (dolist (v (sb!di:ambiguous-debug-vars - d-fun - (if prefix (string prefix) ""))) + d-fun + (if prefix (string prefix) ""))) (setf any-p t) (when (eq (sb!di:debug-var-validity v location) :valid) (setf any-valid-p t) + (case (sb!di::debug-var-info v) + (:more-context + (setf more-context (sb!di:debug-var-value v *current-frame*))) + (:more-count + (setf more-count (sb!di:debug-var-value v *current-frame*)))) (format *debug-io* "~S~:[#~W~;~*~] = ~S~%" (sb!di:debug-var-symbol v) (zerop (sb!di:debug-var-id v)) (sb!di:debug-var-id v) (sb!di:debug-var-value v *current-frame*)))) - + (when (and more-context more-count) + (format *debug-io* "~S = ~S~%" + 'more + (multiple-value-list (sb!c:%more-arg-values more-context 0 more-count)))) (cond ((not any-p) (format *debug-io* @@ -1533,15 +1601,33 @@ and LDB (the low-level debugger). See also ENABLE-DEBUGGER." (!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))))) + (multiple-value-bind (fname args) (frame-call *current-frame*) + (multiple-value-bind (fun arglist ok) + (if (and (legal-fun-name-p fname) (fboundp fname)) + (values (fdefinition fname) args t) + (values (sb!di:debug-fun-fun (sb!di:frame-debug-fun *current-frame*)) + (frame-args-as-list *current-frame*) + nil)) + (when (and fun + (or ok + (y-or-n-p "~@"))) + (unwind-to-frame-and-call *current-frame* + (lambda () + ;; Ensure TCO. + (declare (optimize (debug 0))) + (apply fun arglist)))) + (format *debug-io* + "Can't restart ~S: no function for frame." + *current-frame*))) (format *debug-io* - "~@"))) + "~@" + *current-frame*))) (defun frame-has-debug-tag-p (frame) #!+unwind-to-frame-and-call-vop @@ -1549,6 +1635,11 @@ and LDB (the low-level debugger). See also ENABLE-DEBUGGER." #!-unwind-to-frame-and-call-vop (find 'sb!c:debug-catch-tag (sb!di::frame-catches frame) :key #'car)) +(defun frame-has-debug-vars-p (frame) + (sb!di:debug-var-info-available + (sb!di:code-location-debug-fun + (sb!di:frame-code-location frame)))) + ;; 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 ()))))