X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug.lisp;h=ec41b0dac2d1b4e75f9a8a2c9d72819468078e03;hb=d3af5593ffff1c39a2f8fa8113704803f347e22f;hp=05cef22c98a7355fc897cb0c951302160a3e630d;hpb=74cfbf6d0572b7df1b3492563408a7cb3ae103cf;p=sbcl.git

diff --git a/src/code/debug.lisp b/src/code/debug.lisp
index 05cef22..ec41b0d 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
 
@@ -820,9 +846,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)
@@ -1549,6 +1580,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 ()))))