From e082422c19768dd7d6e30126740fe7f05cbd603a Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sun, 3 Aug 2008 21:39:09 +0000 Subject: [PATCH] 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. --- NEWS | 4 +++ src/code/defboot.lisp | 65 +++++++++++++++++++++++++++--------------- src/code/early-extensions.lisp | 10 +++++++ tests/compiler.pure.lisp | 32 +++++++++++++++++++++ version.lisp-expr | 2 +- 5 files changed, 89 insertions(+), 24 deletions(-) diff --git a/NEWS b/NEWS index e4c5f05e7..70c9be03d 100644 --- 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 232802fce..0df13b61e 100644 --- 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)))))) ;;;; conditions, handlers, restarts diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index e004f73a7..c6a544f81 100644 --- 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 755547f57..c85ebd08e 100644 --- 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 c02ee2c3f..cefa0925b 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.19.16" +"1.0.19.17" -- 2.11.4.GIT