From: Paul Khuong <pvk@pvk.ca>
Date: Thu, 3 Jan 2013 15:31:09 +0000 (-0500)
Subject: Do not traverse long constant lists when expanding DOLIST
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=678a5d0cd5bfccf621e11147507471c3f511595c;p=sbcl.git

Do not traverse long constant lists when expanding DOLIST

* Only gather type information on the list contents' if it's short
  (at most 20 elements); otherwise, do not derive type information.

* Thanks to Douglas Katzman for the bug report (lp#1095488).
---

diff --git a/NEWS b/NEWS
index faa6803..11036e5 100644
--- a/NEWS
+++ b/NEWS
@@ -1,4 +1,8 @@
 ;;;; -*- coding: utf-8; fill-column: 78 -*-
+changes relative to sbcl-1.1.3:
+  * bug fix: very long (or infinite) constant lists in DOLIST do not result
+    in very long compile times or heap exhaustion anymore. (lp#1095488)
+
 changes in sbcl-1.1.3 relative to sbcl-1.1.2:
   * enhancement: warnings about bad locale settings, LANG, LC_CTYPE, etc.
     (lp#727625)
diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp
index 2285b4f..050489b 100644
--- a/src/code/defboot.lisp
+++ b/src/code/defboot.lisp
@@ -360,17 +360,18 @@ evaluated as a PROGN."
   ;; var.
   (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
     (let* ((n-list (gensym "N-LIST"))
-           (start (gensym "START"))
-           (tmp (gensym "TMP")))
+           (start (gensym "START")))
       (multiple-value-bind (clist members clist-ok)
           (cond ((sb!xc:constantp list env)
                  (let ((value (constant-form-value list env)))
-                   (multiple-value-bind (all dot) (list-members value)
-                     (when dot
+                   (multiple-value-bind (all dot) (list-members value :max-length 20)
+                     (when (eql dot t)
                        ;; Full warning is too much: the user may terminate the loop
                        ;; early enough. Contents are still right, though.
                        (style-warn "Dotted list ~S in DOLIST." value))
-                     (values value all t))))
+                     (if (eql dot :maybe)
+                         (values value nil nil)
+                         (values value all t)))))
                 ((and (consp list) (eq 'list (car list))
                       (every (lambda (arg) (sb!xc:constantp arg env)) (cdr list)))
                  (let ((values (mapcar (lambda (arg) (constant-form-value arg env)) (cdr list))))
@@ -382,10 +383,9 @@ evaluated as a PROGN."
              (tagbody
                 ,start
                 (unless (endp ,n-list)
-                  (let* (,@(if clist-ok
-                               `((,tmp (truly-the (member ,@members) (car ,n-list)))
-                                 (,var ,tmp))
-                               `((,var (car ,n-list)))))
+                  (let ((,var ,(if clist-ok
+                                   `(truly-the (member ,@members) (car ,n-list))
+                                   `(car ,n-list))))
                     ,@decls
                     (setq ,n-list (cdr ,n-list))
                     (tagbody ,@forms))
diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index 9ed8d28..52ab419 100644
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -1300,12 +1300,16 @@
 ;;; Returns a list of members of LIST. Useful for dealing with circular lists.
 ;;; For a dotted list returns a secondary value of T -- in which case the
 ;;; primary return value does not include the dotted tail.
-(defun list-members (list)
+;;; If the maximum length is reached, return a secondary value of :MAYBE.
+(defun list-members (list &key max-length)
   (when list
     (do ((tail (cdr list) (cdr tail))
-         (members (list (car list)) (cons (car tail) members)))
-        ((or (not (consp tail)) (eq tail list))
-         (values members (not (listp tail)))))))
+         (members (list (car list)) (cons (car tail) members))
+         (count 0 (1+ count)))
+        ((or (not (consp tail)) (eq tail list)
+             (and max-length (>= count max-length)))
+         (values members (or (not (listp tail))
+                             (and (>= count max-length) :maybe)))))))
 
 ;;; Default evaluator mode (interpeter / compiler)