X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=8a4d87ed7e8b56b9735c330a13a43a89eb58d8e7;hb=e981481e65e869a92420616163b2ba3ec68b25d7;hp=961d1c4427fc41904f9e61e1b8c49bafed257d47;hpb=12836ca105af62252aa0974c3f6992e60ce0ebf4;p=sbcl.git

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 961d1c4..8a4d87e 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -222,7 +222,7 @@
                                 it (coerce-to-values type)))
                               (t (coerce-to-values type)))))
                dest)))))
-  (lvar-%externally-checkable-type lvar))
+  (or (lvar-%externally-checkable-type lvar) *wild-type*))
 #!-sb-fluid(declaim (inline flush-lvar-externally-checkable-type))
 (defun flush-lvar-externally-checkable-type (lvar)
   (declare (type lvar lvar))
@@ -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-from-sets 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))
 
@@ -1976,6 +1988,15 @@
         (unlink-node call)
         (when vals
           (reoptimize-lvar (first vals)))
+        ;; Propagate derived types from the VALUES call to its args:
+        ;; transforms can leave the VALUES call with a better type
+        ;; than its args have, so make sure not to throw that away.
+        (let ((types (values-type-types (node-derived-type use))))
+          (dolist (val vals)
+            (when types
+              (let ((type (pop types)))
+                (assert-lvar-type val type '((type-check . 0)))))))
+        ;; Propagate declared types of MV-BIND variables.
         (propagate-to-args use fun)
         (reoptimize-call use))
       t)))
@@ -2086,17 +2107,20 @@
         (unless (eq value-type *empty-type*)
 
           ;; FIXME: Do it in one step.
-          (filter-lvar
-           value
-           (if (cast-single-value-p cast)
-               `(list 'dummy)
-               `(multiple-value-call #'list 'dummy)))
-          (filter-lvar
-           (cast-value cast)
-           ;; FIXME: Derived type.
-           `(%compile-time-type-error 'dummy
-                                      ',(type-specifier atype)
-                                      ',(type-specifier value-type)))
+          (let ((context (cons (node-source-form cast)
+                               (lvar-source (cast-value cast)))))
+            (filter-lvar
+             value
+             (if (cast-single-value-p cast)
+                 `(list 'dummy)
+                 `(multiple-value-call #'list 'dummy)))
+            (filter-lvar
+             (cast-value cast)
+             ;; FIXME: Derived type.
+             `(%compile-time-type-error 'dummy
+                                        ',(type-specifier atype)
+                                        ',(type-specifier value-type)
+                                        ',context)))
           ;; KLUDGE: FILTER-LVAR does not work for non-returning
           ;; functions, so we declare the return type of
           ;; %COMPILE-TIME-TYPE-ERROR to be * and derive the real type