From 64ed946d513d0cd0508fea90cd3b44328e75df9a Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Wed, 10 Jun 2009 13:03:36 +0000 Subject: [PATCH] 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?) --- NEWS | 2 ++ src/code/defboot.lisp | 16 +++++++++++----- tests/dynamic-extent.impure.lisp | 14 ++++++++++++++ version.lisp-expr | 2 +- 4 files changed, 28 insertions(+), 6 deletions(-) diff --git a/NEWS b/NEWS index bfb9975b6..03aeaedb6 100644 --- 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 2ad6f6f13..291d73d92 100644 --- 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)))))))))) diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index 9e7732150..167acf8cc 100644 --- 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))) diff --git a/version.lisp-expr b/version.lisp-expr index 7b27937d8..67060a141 100644 --- 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" -- 2.11.4.GIT