From: Stas Boukarev <stassats@gmail.com>
Date: Sat, 22 Jun 2013 15:37:18 +0000 (+0400)
Subject: backtrace: don't cons large lists when RCX is overwritten inside XEPs.
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=6e8818015788c80c3705748bebada273ff70370e;p=sbcl.git

backtrace: don't cons large lists when RCX is overwritten inside XEPs.

To present a list with the actual number of passed arguments in the
backtrace, clean-xep used the arg-count register and added missing
arguments in the form of #<unknown>, but if the register is
overwritten by other code, it could cons very large lists, exhausting
heap. Do such arg-list clean up only upon INVALID-ARG-COUNT-ERROR.
Fixes lp#1192929.
---

diff --git a/NEWS b/NEWS
index e1b19d1..6d75cdf 100644
--- a/NEWS
+++ b/NEWS
@@ -38,7 +38,9 @@ changes relative to sbcl-1.1.8:
     or double float precision on x87.
   * bug fix: Known-safe vector access on x86oids should not fail spuriously
     when the index is of the form (+ x constant-positive-integer).
-  * bug fix: Remove GPL-licensed files from source distribution.  (lp#1185668)
+  * bug fix: Remove GPL-licensed files from source distribution. (lp#1185668)
+  * bug fix: backtrace printer no longer tries to create very large lists when
+    the arg-count register is clobberred by other code. (lp#1192929)
 
 changes in sbcl-1.1.8 relative to sbcl-1.1.7:
   * notice: The implementation of MAP-ALLOCATED-OBJECTS (the heart of
diff --git a/src/code/debug.lisp b/src/code/debug.lisp
index 76a87d8..2393a1b 100644
--- a/src/code/debug.lisp
+++ b/src/code/debug.lisp
@@ -512,12 +512,22 @@ thread, NIL otherwise."
     (sb!di:lambda-list-unavailable ()
       (make-unprintable-object "unavailable lambda list"))))
 
-(defun clean-xep (name args info)
+(defun interrupted-frame-error (frame)
+  (when (and (sb!di::compiled-frame-p frame)
+             (sb!di::compiled-frame-escaped frame))
+    (let ((error-number (sb!vm:internal-error-args
+                         (sb!di::compiled-frame-escaped frame))))
+      (when (array-in-bounds-p sb!c:*backend-internal-errors* error-number)
+        (car (svref sb!c:*backend-internal-errors* error-number))))))
+
+(defun clean-xep (frame name args info)
   (values (second name)
           (if (consp args)
               (let* ((count (first args))
                      (real-args (rest args)))
-                (if (fixnump count)
+                (if (and (integerp count)
+                         (eq (interrupted-frame-error frame)
+                             'invalid-arg-count-error))
                     ;; So, this is a cheap trick -- but makes backtraces for
                     ;; too-many-arguments-errors much, much easier to to
                     ;; understand. FIXME: For :EXTERNAL frames at least we
@@ -568,21 +578,22 @@ thread, NIL otherwise."
          (values name args)))
     (values cname cargs (cons :fast-method info))))
 
-(defun clean-frame-call (name args method-frame-style info)
-  (if (consp name)
-      (case (first name)
-        ((sb!c::xep sb!c::tl-xep)
-         (clean-xep name args info))
-        ((sb!c::&more-processor)
-         (clean-&more-processor name args info))
-        ((sb!c::&optional-processor)
-         (clean-frame-call (second name) args method-frame-style
-                           info))
-        ((sb!pcl::fast-method)
-         (clean-fast-method name args method-frame-style info))
-        (t
-         (values name args info)))
-      (values name args info)))
+(defun clean-frame-call (frame name method-frame-style info)
+  (let ((args (frame-args-as-list frame)))
+    (if (consp name)
+        (case (first name)
+          ((sb!c::xep sb!c::tl-xep)
+           (clean-xep frame name args info))
+          ((sb!c::&more-processor)
+           (clean-&more-processor name args info))
+          ((sb!c::&optional-processor)
+           (clean-frame-call frame (second name) method-frame-style
+                             info))
+          ((sb!pcl::fast-method)
+           (clean-fast-method name args method-frame-style info))
+          (t
+           (values name args info)))
+        (values name args info))))
 
 (defun frame-call (frame &key (method-frame-style *method-frame-style*)
                               replace-dynamic-extent-objects)
@@ -603,8 +614,8 @@ the current thread are replaced with dummy objects which can safely escape."
   (let* ((debug-fun (sb!di:frame-debug-fun frame))
          (kind (sb!di:debug-fun-kind debug-fun)))
     (multiple-value-bind (name args info)
-        (clean-frame-call (sb!di:debug-fun-name debug-fun)
-                          (frame-args-as-list frame)
+        (clean-frame-call frame
+                          (sb!di:debug-fun-name debug-fun)
                           method-frame-style
                           (when kind (list kind)))
       (let ((args (if (and (consp args) replace-dynamic-extent-objects)
diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp
index 1804a08..c69015e 100644
--- a/tests/debug.impure.lisp
+++ b/tests/debug.impure.lisp
@@ -823,4 +823,12 @@
   (assert (verify-backtrace (lambda () (gf-dispatch-test/f 42))
                             '(((sb-pcl::gf-dispatch gf-dispatch-test/gf) 42)))))
 
+(with-test (:name (:xep-arglist-clean-up :bug-1192929))
+  (assert
+   (block nil
+     (handler-bind ((error (lambda (e)
+                             (declare (ignore e))
+                             (return (< (length (car (sb-debug:backtrace-as-list 1))) 10)))))
+       (funcall (compile nil `(lambda (i) (declare ((mod 65536) i)) i)) nil)))))
+
 (write-line "/debug.impure.lisp done")