From ee1e63f0fbaaf44329bc783cbfb31bdc6e8ecd99 Mon Sep 17 00:00:00 2001 From: Charles Zhang Date: Tue, 1 Sep 2026 12:31:48 +0200 Subject: [PATCH] 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 | 21 +++++---------------- tests/compiler-2.pure.lisp | 3 ++- tests/compiler.pure.lisp | 19 +++++++++++++++++++ 3 files changed, 26 insertions(+), 17 deletions(-) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 27a93a6af..8ffd60090 100644 --- a/src/compiler/ir1opt.lisp +++ b/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))) diff --git a/tests/compiler-2.pure.lisp b/tests/compiler-2.pure.lisp index 790c3aa3c..e037624b7 100644 --- a/tests/compiler-2.pure.lisp +++ b/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 diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index d784a0a4e..3242d1544 100644 --- a/tests/compiler.pure.lisp +++ b/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