Better type derivation for APPEND, NCONC, LIST.

[sbcl.git] / src / compiler / ir1opt.lisp

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 59b6bfd..b664bf7 100644 (file)
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -166,7 +166,14 @@
               :specialized-element-type (array-type-specialized-element-type type))
              ;; Simple arrays cannot change at all.
              type))
+        ((union-type-p type)
+         ;; Conservative union type is an union of conservative types.
+         (let ((res *empty-type*))
+           (dolist (part (union-type-types type) res)
+             (setf res (type-union res (conservative-type part))))))
         (t
+         ;; Catch-all.
+         ;;
          ;; If the type contains some CONS types, the conservative type contains all
          ;; of them.
          (when (types-equal-or-intersect type (specifier-type 'cons))
@@ -222,7 +229,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))
@@ -1304,7 +1311,7 @@
                               '(optimize
                                 (preserve-single-use-debug-variables 0))
                               (lexenv-policy
-                                   (combination-lexenv call)))))
+                               (combination-lexenv call)))))
   (with-ir1-environment-from-node call
     (with-component-last-block (*current-component*
                                 (block-next (node-block call)))
@@ -1715,9 +1722,7 @@
                            leaf var)))
                  t)))))
         ((and (null (rest (leaf-refs var)))
-              ;; Don't substitute single-ref variables on high-debug /
-              ;; low speed, to improve the debugging experience.
-              (policy call (< preserve-single-use-debug-variables 3))
+              (not (preserve-single-use-debug-var-p call var))
               (substitute-single-use-lvar arg var)))
         (t
          (propagate-to-refs var (lvar-type arg))))))
@@ -1988,6 +1993,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)))
@@ -2020,6 +2034,7 @@
           (flush-lvar-externally-checkable-type arg))
         (setf (combination-args use) nil)
         (flush-dest list)
+        (flush-combination use)
         (setf (combination-args node) args))
       t)))