From fa2c3ba871c9818e5768fd8f6092ddda83a93a1f Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Thu, 21 Apr 2011 11:08:12 +0000 Subject: [PATCH] 1.0.47.27: limit open coding from MEMBER, ASSOC, &co Open coding massive lists doesn't really help, and a sufficiently long list can blow the stack during compilation. --- NEWS | 2 ++ src/compiler/seqtran.lisp | 8 ++++++-- tests/compiler.pure.lisp | 7 +++++++ version.lisp-expr | 2 +- 4 files changed, 16 insertions(+), 3 deletions(-) diff --git a/NEWS b/NEWS index 5adaafc..281a811 100644 --- a/NEWS +++ b/NEWS @@ -30,6 +30,8 @@ changes relative to sbcl-1.0.47: engages the obsolete instance protocol. (lp#766271) * bug fix: constant improper lists could break source coverage recording. (lp#767959) + * bug fix: compiling calls to eg. MEMBER with massive constant list arguments + could exhaust stack. changes in sbcl-1.0.47 relative to sbcl-1.0.46: * bug fix: fix mach port rights leaks in mach exception handling code on diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 7775528..67ecb5a 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -316,6 +316,8 @@ (bug "Unknown list item seek transform: name=~S, key-functions=~S variant=~S" function-name key-functions variant))) +(defparameter *list-open-code-limit* 128) + (defun transform-list-item-seek (name item list key test test-not node) (when (and test test-not) (abort-ir1-transform "Both ~S and ~S supplied to ~S." :test :test-not name)) @@ -376,7 +378,8 @@ (let* ((cp (constant-lvar-p list)) (c-list (when cp (lvar-value list)))) (cond ((and cp c-list (member name '(assoc rassoc member)) - (policy node (>= speed space))) + (policy node (>= speed space)) + (not (nthcdr *list-open-code-limit* c-list))) `(let ,(mapcar (lambda (fun) `(,(second fun) ,(ensure-fun fun))) funs) ,(open-code c-list))) ((and cp (not c-list)) @@ -431,7 +434,8 @@ ,(open-code (cdr tail)))))) (let* ((cp (constant-lvar-p list)) (c-list (when cp (lvar-value list)))) - (cond ((and cp c-list (policy node (>= speed space))) + (cond ((and cp c-list (policy node (>= speed space)) + (not (nthcdr *list-open-code-limit* c-list))) `(let ((pred ,pred-expr) ,@(when key `((key ,key-form)))) ,(open-code c-list))) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index c2223e7..f6dcabf 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -3867,3 +3867,10 @@ (assoc nil '((:ordinary . ordinary-lambda-list)))))) + +(with-test (:name :member-on-long-constant-list) + ;; This used to blow stack with a sufficiently long list. + (let ((cycle (list t))) + (nconc cycle cycle) + (compile nil `(lambda (x) + (member x ',cycle))))) diff --git a/version.lisp-expr b/version.lisp-expr index 93d53f0..72e16ed 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.47.26" +"1.0.47.27" -- 1.7.10.4