1.0.29.6: work around stack-allocated value cell badness in HANDLER-CASE

* Use an explicit CONS so the closed-over variable is read-only and
  doesn't need a value cell, and stack allocate the CONS instead.
  (Stack analysis still can't reason about stack allocated
  value-cells... it might be that doing a transformation like this in
  the compiler would be the way to integrate dx value cells properly
  into Python, maybe?)

diff --git a/NEWS b/NEWS
index bfb9975..03aeaed 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -7,6 +7,8 @@
   * bug fix: on 64 bit platforms FILL worked incorrectly on arrays with
     upgraded element type (COMPLEX SINGLE-FLOAT), regression from 1.0.28.55.
     (thanks to Paul Khuong)
+  * bug fix: looping around HANDLER-CASE could silently consume stack space
+    on each iteration. (reported by "foobar")
   * bug fix: better error signalling when calls to functions seeking elements
     from lists (eg. ADJOIN) are compiled with both :TEST and :TEST-NOT.
     (reported by Tobias Rittweiler)

diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp
index 2ad6f6f..291d73d 100644 (file)
--- a/src/code/defboot.lisp
+++ b/src/code/defboot.lisp
@@ -662,7 +662,7 @@ specification."
                               (push `(,fun ,ll ,@body) local-funs)
                               (list tag type ll fun))))
                         cases)))
-          (with-unique-names (block var form-fun)
+          (with-unique-names (block cell form-fun)
             `(dx-flet ((,form-fun ()
                          #!-x86 ,form
                          ;; Need to catch FP errors here!
@@ -670,8 +670,14 @@ specification."
                        ,@(reverse local-funs))
                (declare (optimize (sb!c::check-tag-existence 0)))
                (block ,block
-                 (dx-let ((,var nil))
-                   (declare (ignorable ,var))
+                 ;; KLUDGE: We use a dx CONS cell instead of just assigning to
+                 ;; the variable directly, so that we can stack allocate
+                 ;; robustly: dx value cells don't work quite right, and it is
+                 ;; possible to construct user code that should loop
+                 ;; indefinitely, but instead eats up some stack each time
+                 ;; around.
+                 (dx-let ((,cell (cons :condition nil)))
+                   (declare (ignorable ,cell))
                    (tagbody
                       (%handler-bind
                        ,(mapcar (lambda (annotated-case)
@@ -680,7 +686,7 @@ specification."
                                     (list type
                                           `(lambda (temp)
                                              ,(if ll
-                                                  `(setf ,var temp)
+                                                  `(setf (cdr ,cell) temp)
                                                   '(declare (ignore temp)))
                                              (go ,tag)))))
                                 annotated-cases)
@@ -692,7 +698,7 @@ specification."
                              (list tag
                                    `(return-from ,block
                                       ,(if ll
-                                           `(,fun-name ,var)
+                                           `(,fun-name (cdr ,cell))
                                            `(,fun-name))))))
                          annotated-cases))))))))))
 \f

diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp
index 9e77321..167acf8 100644 (file)
--- a/tests/dynamic-extent.impure.lisp
+++ b/tests/dynamic-extent.impure.lisp
@@ -780,4 +780,18 @@
     (assert-notes 0 `(lambda (other)
                        #'(lambda (s c n)
                            (ignore-errors (funcall other s c n)))))))
+
+;;; Stack allocating a value cell in HANDLER-CASE would blow up stack
+;;; in an unfortunate loop.
+(defun handler-case-eating-stack ()
+  (let ((sp nil))
+    (do ((n 0 (logand most-positive-fixnum (1+ n))))
+        ((>= n 1024))
+     (multiple-value-bind (value error) (ignore-errors)
+       (when (and value error) nil))
+      (if sp
+          (assert (= sp (sb-c::%primitive sb-c:current-stack-pointer)))
+          (setf sp (sb-c::%primitive sb-c:current-stack-pointer))))))
+(with-test (:name :handler-case-eating-stack)
+  (assert-no-consing (handler-case-eating-stack)))
 \f

diff --git a/version.lisp-expr b/version.lisp-expr
index 7b27937..67060a1 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,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.29.5"
+"1.0.29.6"