Be even more conservative around cons and non-simple array types.

While it could be argued that

(lambda (x)
  (declare (optimize speed))
  (declare (type (array * (4 4)) x))
  (adjust-array x '(3 5))
  (array-dimension (the (array t) x) 0))

should be able to return 4 (I think this is rather dubious though),
clearly it is not correct for the attached test case to be able to do
so. Because declared types do not know anything about variable
subsitution, do not try and squeeze more type information from a
declared type if there is more than one reference to the variable.

While it is unfortunate that a test had to be disabled as a worse type
is derived, I don't see how to safely derive a better type without
making other cases incorrect. This could be fixed as a follow-up.

Notably

(lambda (x)
  (declare (type (or null (cons fixnum)) x))
  (setf (car x) 'foo)
  (if x
      (+ (car x) 4)
      0))

simply crashes without this fix and is not safe, which is not good
even if it's undefined behavior. The corresponding test case with a
variable substitution is not only unsafe but incorrect despite being
defined behavior.

Fixes lp#2165835.

src/compiler/ir1opt.lisp

@@ -205,10 +205,10 @@
 ;;; does the same -- so there is no way to use the derived information in
 ;;; general.
 ;;;
-;;; So, the conservative option is to use the derived type if the leaf has
-;;; only a single ref -- in which case there cannot be a prior call that
-;;; mutates it. Otherwise we use the declared type or punt to the most general
-;;; type we know to be correct for sure.
+;;; So, the conservative option is to use the derived type if the leaf
+;;; has only a single ref -- in which case there cannot be a prior
+;;; call that mutates it. Otherwise we punt to the most general type
+;;; we know to be correct for sure.
 (defun lvar-conservative-type (lvar)
   (let ((derived-type (lvar-type lvar))
         (t-type *universal-type*))
@@ -243,18 +243,7 @@
         (let ((leaf (ref-leaf node)))
           (if (and (basic-var-p leaf)
                    (cdr (leaf-refs leaf)))
-              (coerce-to-values
-               (if (eq :declared (leaf-where-from leaf))
-                   (let ((leaf-type (leaf-type leaf))
-                         (cons-type (specifier-type 'cons)))
-                     ;; If LEAF-TYPE is (or null some-cons-type) and
-                     ;; DERIVED-TYPE is known to be non-null, use
-                     ;; SOME-CONS-TYPE in that case, because a cons
-                     ;; can't become null.
-                     (if (csubtypep derived-type cons-type)
-                         (type-intersection leaf-type cons-type)
-                         leaf-type))
-                   (conservative-type derived-type)))
+              (coerce-to-values (conservative-type derived-type))
               derived-values-type))
         derived-values-type)))
 

tests/compiler-2.pure.lisp

@@ -2345,7 +2345,8 @@
         t)
     ((1 2) t)))
 
-(with-test (:name :car-type-on-or-null)
+(with-test (:name :car-type-on-or-null
+            :fails-on :sbcl)
   (assert
    (equal (sb-kernel:%simple-fun-type
            (checked-compile

tests/compiler.pure.lisp

@@ -3117,8 +3117,27 @@
            (setq x (make-array '(4 4)))
            (adjust-array y '(3 5))
            (array-dimension (the (array t) y) 0)))
+    (((make-array '(4 4) :initial-element nil :adjustable t)) 3))
+  (checked-compile-and-assert (:optimize nil)
+      `(lambda (x)
+         (declare (optimize speed))
+         (declare (type (array * (4 4)) x))
+         (let ((y x))
+           (adjust-array y '(3 5))
+           (array-dimension (the (array t) y) 0)))
     (((make-array '(4 4) :initial-element nil :adjustable t)) 3)))
 
+(with-test (:name :cons-type-derivation-conservative)
+  (checked-compile-and-assert ()
+      `(lambda (x)
+         (declare (type (or null (cons fixnum)) x))
+         (let ((y x))
+           (setf (car y) 'foo)
+           (if y
+               (+ (car y) 4)
+               0)))
+    (((list 9 10)) (condition 'type-error))))
+
 (with-test (:name :with-timeout-code-deletion-note)
   (checked-compile `(lambda ()
                       (sb-ext:with-timeout 0