From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Sun, 20 Feb 2011 10:12:03 +0000 (+0000)
Subject: 1.0.46.1: be careful about stack-allocation in BACKTRACE-AS-LIST
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=cff4add8f008056edf4c876260c6be8ba804b24c;p=sbcl.git

1.0.46.1: be careful about stack-allocation in BACKTRACE-AS-LIST

  Replace DX objects with heap-allocated ones to avoid leaking invalid
  references.

  Note: doesn't deal with objects allocated on stacks of other threads
  yet, as current %SYMBOL-VALUE-IN-THREAD isn't really something I
  want to call during backtracing: iterating over all_threads is a
  crock.

  Fixes lp#310175.
---

diff --git a/NEWS b/NEWS
index 20fd3b8..6eb7420 100644
--- a/NEWS
+++ b/NEWS
@@ -1,4 +1,8 @@
 ;;;; -*- coding: utf-8; fill-column: 78 -*-
+changes relative to sbcl-1.0.46:
+  * bug fix: SB-DEBUG:BACKTRACE-AS-LIST guards against potentially leaking
+    stack-allocated values out of their dynamic-extent. (lp#310175)
+
 changes in sbcl-1.0.46 relative to sbcl-1.0.45:
   * enhancement: largefile support on Solaris.
   * enhancement: SB-PROFILE:REPORT now supports :LIMIT and :PRINT-NO-CALL-LIST
diff --git a/src/code/debug.lisp b/src/code/debug.lisp
index c89794b..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
 
diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp
index 18cf137..3204f72 100644
--- a/tests/debug.impure.lisp
+++ b/tests/debug.impure.lisp
@@ -469,6 +469,20 @@
     (load (compile-file "bug-414.lisp"))
     (disassemble 'bug-414)))
 
+(with-test (:name :bug-310175)
+  (let ((dx-arg (cons t t)))
+    (declare (dynamic-extent dx-arg))
+    (flet ((dx-arg-backtrace (x)
+             (declare (optimize (debug 2)))
+             (prog1 (sb-debug:backtrace-as-list 10)
+               (assert (sb-debug::stack-allocated-p x)))))
+      (declare (notinline dx-arg-backtrace))
+      (assert (member-if (lambda (frame)
+                           (and (consp frame)
+                                (equal '(flet dx-arg-backtrace) (car frame))
+                                (notany #'sb-debug::stack-allocated-p (cdr frame))))
+                         (dx-arg-backtrace dx-arg))))))
+
 ;;;; test infinite error protection
 
 (defmacro nest-errors (n-levels error-form)
diff --git a/version.lisp-expr b/version.lisp-expr
index 58afd03..759ad3a 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -20,4 +20,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.46"
\ No newline at end of file
+"1.0.46.1"