1.0.19.17: DOLIST variable type on constant lists

 * When DOLIST list is a (LIST ...) form where every argument is a
   constant, constant-fold it during macro-expansion. (User has no
   direct access to the list itself, so this is safe.)

 * When DOLIST list ia a constant, add an extra binding,
   and annotate its type as (MEMBER ...).

   This means that the compiler knows that in

    (dolist (x (list 1 2 3)) ...)

   X is (INTEGER 1 3).

 * Also add a STYLE-WARNING for constant dotted lists in DOLIST.

diff --git a/NEWS b/NEWS
index e4c5f05..70c9be0 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -7,6 +7,10 @@ changes in sbcl-1.0.20 relative to 1.0.19:
   * optimization: ASSOC-IF, ASSOC-IF-NOT, MEMBER-IF, MEMBER-IF-NOT,
     RASSOC, RASSOC-IF, and RASSOC-IF-NOT are now equally efficient
     as ASSOC and MEMEBER.
+  * optimization: enhanced derivation of DOLIST iteration variable type
+    for constant lists.
+  * optimization: constant folding of simple (LIST ...) forms as DOLIST
+    arguments.
   * optimization: runtime lookup of function definitions can be
     elided in more cases, eg: (let ((x 'foo)) (funcall foo)).
   * optimization: compiler is able to derive the return type of

diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp
index 232802f..0df13b6 100644 (file)
--- a/src/code/defboot.lisp
+++ b/src/code/defboot.lisp
@@ -345,7 +345,7 @@ evaluated as a PROGN."
                        (type integer ,c))
               ,@body)))))
 
-(defmacro-mundanely dolist ((var list &optional (result nil)) &body body)
+(defmacro-mundanely dolist ((var list &optional (result nil)) &body body &environment env)
   ;; We repeatedly bind the var instead of setting it so that we never
   ;; have to give the var an arbitrary value such as NIL (which might
   ;; conflict with a declaration). If there is a result form, we
@@ -355,28 +355,47 @@ evaluated as a PROGN."
   ;; since we don't want to use IGNORABLE on what might be a special
   ;; var.
   (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
-    (let ((n-list (gensym "N-LIST"))
-          (start (gensym "START")))
-      `(block nil
-         (let ((,n-list ,list))
-           (tagbody
-              ,start
-              (unless (endp ,n-list)
-                (let ((,var (car ,n-list)))
-                  ,@decls
-                  (setq ,n-list (cdr ,n-list))
-                  (tagbody ,@forms))
-                (go ,start))))
-         ,(if result
-              `(let ((,var nil))
-                 ;; Filter out TYPE declarations (VAR gets bound to NIL,
-                 ;; and might have a conflicting type declaration) and
-                 ;; IGNORE (VAR might be ignored in the loop body, but
-                 ;; it's used in the result form).
-                 ,@(filter-dolist-declarations decls)
-                 ,var
-                 ,result)
-               nil)))))
+    (let* ((n-list (gensym "N-LIST"))
+           (start (gensym "START"))
+           (tmp (gensym "TMP")))
+      (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
+                       ;; 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))))
+                ((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))))
+                   (values values values t)))
+                (t
+                 (values nil nil nil)))
+        `(block nil
+           (let ((,n-list ,(if clist-ok (list 'quote clist) list)))
+             (tagbody
+                ,start
+                (unless (endp ,n-list)
+                  (let* (,@(if clist-ok
+                               `((,tmp (truly-the (member ,@members) (car ,n-list)))
+                                 (,var ,tmp))
+                               `((,var (car ,n-list)))))
+                    ,@decls
+                    (setq ,n-list (cdr ,n-list))
+                    (tagbody ,@forms))
+                  (go ,start))))
+           ,(if result
+                `(let ((,var nil))
+                   ;; Filter out TYPE declarations (VAR gets bound to NIL,
+                   ;; and might have a conflicting type declaration) and
+                   ;; IGNORE (VAR might be ignored in the loop body, but
+                   ;; it's used in the result form).
+                   ,@(filter-dolist-declarations decls)
+                   ,var
+                   ,result)
+                nil))))))
 \f
 ;;;; conditions, handlers, restarts
 

diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index e004f73..c6a544f 100644 (file)
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -1214,6 +1214,16 @@
           (*print-length* (or (true *print-length*) 12)))
       (funcall function))))
 
+;;; 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)
+  (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)))))))
+
 ;;; Default evaluator mode (interpeter / compiler)
 
 (declaim (type (member :compile #!+sb-eval :interpret) *evaluator-mode*))

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 755547f..c85ebd0 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -2594,3 +2594,35 @@
                                '(lambda (s)
                                  (sb-c::compiler-derived-type (aref (the base-string s) 0))))
                       (coerce "foo" 'base-string)))))
+
+(with-test (:name :dolist-constant-type-derivation)
+  (assert (equal '(integer 1 3)
+                 (funcall (compile nil
+                                   '(lambda (x)
+                                     (dolist (y '(1 2 3))
+                                       (when x
+                                         (return (sb-c::compiler-derived-type y))))))
+                          t))))
+
+(with-test (:name :dolist-simple-list-type-derivation)
+  (assert (equal '(integer 1 3)
+                 (funcall (compile nil
+                                   '(lambda (x)
+                                     (dolist (y (list 1 2 3))
+                                       (when x
+                                         (return (sb-c::compiler-derived-type y))))))
+                          t))))
+
+(with-test (:name :dolist-dotted-constant-list-type-derivation)
+  (let* ((warned nil)
+         (fun (handler-bind ((style-warning (lambda (c) (push c warned))))
+                (compile nil
+                         '(lambda (x)
+                           (dolist (y '(1 2 3 . 4) :foo)
+                             (when x
+                               (return (sb-c::compiler-derived-type y)))))))))
+    (assert (equal '(integer 1 3) (funcall fun t)))
+    (assert (= 1 (length warned)))
+    (multiple-value-bind (res err) (ignore-errors (funcall fun nil))
+      (assert (not res))
+      (assert (typep err 'type-error)))))

diff --git a/version.lisp-expr b/version.lisp-expr
index c02ee2c..cefa092 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.19.16"
+"1.0.19.17"