1.0.43.71: fix regression from 1.0.43.26

  PROPAGATE-LOCAL-CALL-ARGS needs to special-case optional dispatch
  entry-points after all: our usual approach can load to too narrow
  types being derived for &OPTIONAL arguments.

  So just deal with &REST args in those cases.

  Closes bug 655203 again.

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 961d1c4..e07fe5d 100644 (file)
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -1735,6 +1735,11 @@
 ;;; If the function has an entry-fun, then we don't do anything: since
 ;;; it has a XEP we would not discover anything.
 ;;;
+;;; If the function is an optional-entry-point, we will just make sure
+;;; &REST lists are known to be lists. Doing the regular rigamarole
+;;; can erronously propagate too strict types into refs: see
+;;; BUG-655203-REGRESSION in tests/compiler.pure.lisp.
+;;;
 ;;; We can clear the LVAR-REOPTIMIZE flags for arguments in all calls
 ;;; corresponding to changed arguments in CALL, since the only use in
 ;;; IR1 optimization of the REOPTIMIZE flag for local call args is
@@ -1742,34 +1747,41 @@
 (defun propagate-local-call-args (call fun)
   (declare (type combination call) (type clambda fun))
   (unless (functional-entry-fun fun)
-    (let* ((vars (lambda-vars fun))
-           (union (mapcar (lambda (arg var)
-                            (when (and arg
-                                       (lvar-reoptimize arg)
-                                       (null (basic-var-sets var)))
-                              (lvar-type arg)))
-                          (basic-combination-args call)
-                          vars))
-           (this-ref (lvar-use (basic-combination-fun call))))
-
-      (dolist (arg (basic-combination-args call))
-        (when arg
-          (setf (lvar-reoptimize arg) nil)))
-
-      (dolist (ref (leaf-refs fun))
-        (let ((dest (node-dest ref)))
-          (unless (or (eq ref this-ref) (not dest))
-            (setq union
-                  (mapcar (lambda (this-arg old)
-                            (when old
-                              (setf (lvar-reoptimize this-arg) nil)
-                              (type-union (lvar-type this-arg) old)))
-                          (basic-combination-args dest)
-                          union)))))
-
-      (loop for var in vars
-            and type in union
-            when type do (propagate-to-refs var type))))
+    (if (lambda-optional-dispatch fun)
+        ;; We can still make sure &REST is known to be a list.
+        (loop for var in (lambda-vars fun)
+              do (let ((info (lambda-var-arg-info var)))
+                   (when (and info (eq :rest (arg-info-kind info)))
+                     (propagate-to-refs var (specifier-type 'list)))))
+        ;; The normal case.
+        (let* ((vars (lambda-vars fun))
+               (union (mapcar (lambda (arg var)
+                                (when (and arg
+                                           (lvar-reoptimize arg)
+                                           (null (basic-var-sets var)))
+                                  (lvar-type arg)))
+                              (basic-combination-args call)
+                              vars))
+               (this-ref (lvar-use (basic-combination-fun call))))
+
+          (dolist (arg (basic-combination-args call))
+            (when arg
+              (setf (lvar-reoptimize arg) nil)))
+
+          (dolist (ref (leaf-refs fun))
+            (let ((dest (node-dest ref)))
+              (unless (or (eq ref this-ref) (not dest))
+                (setq union
+                      (mapcar (lambda (this-arg old)
+                                (when old
+                                  (setf (lvar-reoptimize this-arg) nil)
+                                  (type-union (lvar-type this-arg) old)))
+                              (basic-combination-args dest)
+                              union)))))
+
+          (loop for var in vars
+                and type in union
+                when type do (propagate-to-refs var type)))))
 
   (values))
 \f

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index c74f9b4..7dd538f 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -2684,6 +2684,16 @@
     (assert (eq 'list type))
     (assert derivedp)))
 
+(with-test (:name :rest-list-type-derivation3)
+  (multiple-value-bind (type derivedp)
+      (funcall (funcall (compile nil `(lambda ()
+                                        (lambda (&optional x &rest args)
+                                          (unless x (error "oops"))
+                                          (ctu:compiler-derived-type args)))))
+               t)
+    (assert (eq 'list type))
+    (assert derivedp)))
+
 (with-test (:name :base-char-typep-elimination)
   (assert (eq (funcall (lambda (ch)
                          (declare (type base-char ch) (optimize (speed 3) (safety 0)))
@@ -3620,3 +3630,17 @@
                     (assert (equal '(integer 0 (3)) (type-error-expected-type e)))
                     :caught))))))
 
+(with-test (:name :bug-655203-regression)
+  (let ((fun (compile nil
+                      `(LAMBDA (VARIABLE)
+                         (LET ((CONTINUATION
+                                (LAMBDA
+                                    (&OPTIONAL DUMMY &REST OTHER)
+                                  (DECLARE (IGNORE OTHER))
+                                  (PRIN1 DUMMY)
+                                  (PRIN1 VARIABLE))))
+                           (FUNCALL CONTINUATION (LIST 1 2)))))))
+    ;; This used to signal a bogus type-error.
+    (assert (equal (with-output-to-string (*standard-output*)
+                     (funcall fun t))
+                   "(1 2)T"))))

diff --git a/version.lisp-expr b/version.lisp-expr
index de0051d..2cac2d3 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.43.70"
+"1.0.43.71"