master: Derive AREF type for multiple uses with constants
stassats via Sbcl-commits <[email protected]> Thu, 04 Jun 2026 20:00:04 +0000
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via a7b2d403a2eaaff69a7e3b0cf67922dd000c38fb (commit)
from 5881276137ac2b800ac25cbfa9eaecbcddd05a09 (commit)
- Log -----------------------------------------------------------------
commit a7b2d403a2eaaff69a7e3b0cf67922dd000c38fb
Author: Stas Boukarev <[email protected]>
Date: Thu Jun 4 22:50:58 2026 +0300
Derive AREF type for multiple uses with constants
---
src/compiler/array-tran.lisp | 369 +++++++++++++++++++++++--------------------
src/compiler/ir1opt.lisp | 21 +++
src/compiler/ir1util.lisp | 3 +
tests/array.pure.lisp | 10 ++
4 files changed, 228 insertions(+), 175 deletions(-)
diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index 01d69bb8c..a4582063d 100644
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -251,182 +251,201 @@
clauses))
#-sb-xc-host `(typecase ,arg . ,clauses))
-(defun derive-aref-type (array)
- (or (let ((constant (lvar-constant array))
- min
- max
- symbols
- union
- (conses t)
- any-conses
- (car-type *empty-type*)
- car-min car-max car-symbols
- (cdr-type *empty-type*)
- cdr-min cdr-max cdr-symbols)
- (block nil
- (when constant
- (or (getf (leaf-info constant) nil)
- (setf (getf (leaf-info constant) nil)
- (let ((array (constant-value constant)))
- (or
- (and (zerop (array-total-size array))
- *empty-type*)
- #-sb-xc-host
- (flet ((int-min-max (array min max)
- (declare (optimize (insert-array-bounds-checks 0)))
- (with-array-data ((array array) (start) (end))
- (let ((min min)
- (max max))
- (loop for i from start below end
- do
- (let ((elt (aref array i)))
- (when (> elt max)
- (setf max elt))
- (when (< elt min)
- (setf min elt))))
- (make-numeric-type 'integer min max)))))
- (declare (inline int-min-max))
- (macrolet ((test (type)
- (let ((ctype (specifier-type type)))
- `(and (typep array '(array ,type))
- (int-min-max (the (array ,type) array)
- ,(numeric-type-high ctype)
- ,(numeric-type-low ctype))))))
- (cond
- ((test word))
- ((test sb-vm:signed-word))
- ((test (unsigned-byte 8)))
- ((test (signed-byte 8)))
- ((test (unsigned-byte 16)))
- ((test (signed-byte 16)))
- #+64-bit
- ((test (unsigned-byte 32)))
- #+64-bit
- ((test (signed-byte 32)))
- ((test fixnum))
- ((test bit))
- ((csubtypep (array-type-specialized-element-type (leaf-type constant))
- (specifier-type '(or float complex base-char)))
- (return)))))
- (flet ((lower-type (elt min max set-min set-max symbols set-symbols
- give-up)
- (declare (ignorable symbols set-symbols))
- ;; ctype-of gives too much detail
- (xc-typecase elt
- (integer
- (funcall set-min
- (if min
- (min min elt)
- elt))
- (funcall set-max
- (if max
- (max max elt)
- elt))
- nil)
- #+sb-xc-host
- (symbol
- (specifier-type 'symbol))
- #-sb-xc-host
- (symbol
- (unless symbols
- (setf symbols (alloc-xset)))
- (add-to-xset elt symbols)
- (funcall set-symbols symbols)
- nil)
- (cons
- (specifier-type 'cons))
- (simple-string
- (specifier-type 'simple-string))
- (string
- (specifier-type 'string))
- (simple-vector
- (specifier-type 'simple-vector))
- ((simple-array * (*))
- (specifier-type '(simple-array * (*))))
- (vector
- (specifier-type 'vector))
- (array
- (specifier-type 'array))
- #+sb-unicode
- (base-char
- (specifier-type 'base-char))
- (character
- (specifier-type 'character))
- (double-float
- (specifier-type 'double-float))
- (single-float
- (specifier-type 'single-float))
- (t (funcall give-up)))))
- (loop for i below (array-total-size array)
- for elt = (row-major-aref array i)
- for type = (cond ((and conses
- (consp elt))
- (block nil
- (let ((type (lower-type (car elt) car-min car-max
- (lambda (new)
- (setf car-min new))
- (lambda (new)
- (setf car-max new))
- car-symbols
- (lambda (new)
- (setf car-symbols new))
- (lambda ()
- (setf conses nil)
- (return (specifier-type 'cons))))))
- (when type
- (setf car-type (type-union type car-type))))
- (let ((type (lower-type (cdr elt) cdr-min cdr-max
- (lambda (new)
- (setf cdr-min new))
- (lambda (new)
- (setf cdr-max new))
- cdr-symbols
- (lambda (new)
- (setf cdr-symbols new))
- (lambda ()
- (setf conses nil)
- (return (specifier-type 'cons))))))
- (when type
- (setf cdr-type (type-union type cdr-type))))
- (setf any-conses t)
- nil))
- (t
- (lower-type elt min max
- (lambda (new)
- (setf min new))
- (lambda (new)
- (setf max new))
- symbols
- (lambda (new)
- (setf symbols new))
- (lambda ()
- (return)))))
- do (when type
- (setf union
+(defun constant-array-element-type (constant)
+ (let (min
+ max
+ symbols
+ union
+ (conses t)
+ any-conses
+ (car-type *empty-type*)
+ car-min car-max car-symbols
+ (cdr-type *empty-type*)
+ cdr-min cdr-max cdr-symbols)
+ (block nil
+ (when constant
+ (or (getf (leaf-info constant) nil)
+ (setf (getf (leaf-info constant) nil)
+ (let ((array (constant-value constant)))
+ (or
+ (and (zerop (array-total-size array))
+ *empty-type*)
+ #-sb-xc-host
+ (flet ((int-min-max (array min max)
+ (declare (optimize (insert-array-bounds-checks 0)))
+ (with-array-data ((array array) (start) (end))
+ (let ((min min)
+ (max max))
+ (loop for i from start below end
+ do
+ (let ((elt (aref array i)))
+ (when (> elt max)
+ (setf max elt))
+ (when (< elt min)
+ (setf min elt))))
+ (make-numeric-type 'integer min max)))))
+ (declare (inline int-min-max))
+ (macrolet ((test (type)
+ (let ((ctype (specifier-type type)))
+ `(and (typep array '(array ,type))
+ (int-min-max (the (array ,type) array)
+ ,(numeric-type-high ctype)
+ ,(numeric-type-low ctype))))))
+ (cond
+ ((test word))
+ ((test sb-vm:signed-word))
+ ((test (unsigned-byte 8)))
+ ((test (signed-byte 8)))
+ ((test (unsigned-byte 16)))
+ ((test (signed-byte 16)))
+ #+64-bit
+ ((test (unsigned-byte 32)))
+ #+64-bit
+ ((test (signed-byte 32)))
+ ((test fixnum))
+ ((test bit))
+ ((csubtypep (array-type-specialized-element-type (leaf-type constant))
+ (specifier-type '(or float complex base-char)))
+ (return)))))
+ (flet ((lower-type (elt min max set-min set-max symbols set-symbols
+ give-up)
+ (declare (ignorable symbols set-symbols))
+ ;; ctype-of gives too much detail
+ (xc-typecase elt
+ (integer
+ (funcall set-min
+ (if min
+ (min min elt)
+ elt))
+ (funcall set-max
+ (if max
+ (max max elt)
+ elt))
+ nil)
+ #+sb-xc-host
+ (symbol
+ (specifier-type 'symbol))
+ #-sb-xc-host
+ (symbol
+ (unless symbols
+ (setf symbols (alloc-xset)))
+ (add-to-xset elt symbols)
+ (funcall set-symbols symbols)
+ nil)
+ (cons
+ (specifier-type 'cons))
+ (simple-string
+ (specifier-type 'simple-string))
+ (string
+ (specifier-type 'string))
+ (simple-vector
+ (specifier-type 'simple-vector))
+ ((simple-array * (*))
+ (specifier-type '(simple-array * (*))))
+ (vector
+ (specifier-type 'vector))
+ (array
+ (specifier-type 'array))
+ #+sb-unicode
+ (base-char
+ (specifier-type 'base-char))
+ (character
+ (specifier-type 'character))
+ (double-float
+ (specifier-type 'double-float))
+ (single-float
+ (specifier-type 'single-float))
+ (t (funcall give-up)))))
+ (loop for i below (array-total-size array)
+ for elt = (row-major-aref array i)
+ for type = (cond ((and conses
+ (consp elt))
+ (block nil
+ (let ((type (lower-type (car elt) car-min car-max
+ (lambda (new)
+ (setf car-min new))
+ (lambda (new)
+ (setf car-max new))
+ car-symbols
+ (lambda (new)
+ (setf car-symbols new))
+ (lambda ()
+ (setf conses nil)
+ (return (specifier-type 'cons))))))
+ (when type
+ (setf car-type (type-union type car-type))))
+ (let ((type (lower-type (cdr elt) cdr-min cdr-max
+ (lambda (new)
+ (setf cdr-min new))
+ (lambda (new)
+ (setf cdr-max new))
+ cdr-symbols
+ (lambda (new)
+ (setf cdr-symbols new))
+ (lambda ()
+ (setf conses nil)
+ (return (specifier-type 'cons))))))
+ (when type
+ (setf cdr-type (type-union type cdr-type))))
+ (setf any-conses t)
+ nil))
+ (t
+ (lower-type elt min max
+ (lambda (new)
+ (setf min new))
+ (lambda (new)
+ (setf max new))
+ symbols
+ (lambda (new)
+ (setf symbols new))
+ (lambda ()
+ (return)))))
+ do (when type
+ (setf union
+ (if union
+ (type-union union type)
+ type)))
+ finally
+ (flet ((result (union symbols min max)
+ (when symbols
+ (let ((symbols (make-member-type symbols)))
+ (setf union (if union
+ (type-union union symbols)
+ symbols))))
+ (if min
+ (let ((int (make-numeric-type 'integer min max)))
(if union
- (type-union union type)
- type)))
- finally
- (flet ((result (union symbols min max)
- (when symbols
- (let ((symbols (make-member-type symbols)))
- (setf union (if union
- (type-union union symbols)
- symbols))))
- (if min
- (let ((int (make-numeric-type 'integer min max)))
- (if union
- (type-union union int)
- int))
- union)))
- (let ((union (result union symbols min max)))
- (return
- (if (and conses
- any-conses)
- (type-union (or union *empty-type*)
- (sb-c::make-cons-type (result car-type car-symbols car-min car-max)
- (result cdr-type cdr-symbols cdr-min cdr-max)))
- union)))))))))))))
+ (type-union union int)
+ int))
+ union)))
+ (let ((union (result union symbols min max)))
+ (return
+ (if (and conses
+ any-conses)
+ (type-union (or union *empty-type*)
+ (sb-c::make-cons-type (result car-type car-symbols car-min car-max)
+ (result cdr-type cdr-symbols cdr-min cdr-max)))
+ union))))))))))))))
+
+(defun derive-aref-type (array)
+ (or (let ((uses (lvar-uses array)))
+ (if (consp uses)
+ (let (other-types
+ constant-types)
+ (loop for use in uses
+ do
+ (let ((type (constant-array-element-type (node-constant use))))
+ (if type
+ (push type constant-types)
+ (push (node-single-value-type use) other-types))))
+ (when constant-types
+ (let ((union (sb-kernel::%type-union constant-types)))
+ (if other-types
+ (let ((element-type (type-array-element-type (sb-kernel::%type-union other-types))))
+ (unless (eq element-type *wild-type*)
+ (type-union union element-type)))
+ union))))
+ (constant-array-element-type (node-constant uses))))
(type-array-element-type (lvar-type array))))
(deftransform array-in-bounds-p ((array &rest subscripts))
diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 0431cd88b..2b5c0d684 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -40,6 +40,27 @@
;; check for EQL types and singleton numeric types
(values (type-singleton-p type)))))
+(defun node-constant (node &optional ignore-types)
+ (when node
+ (let ((type (node-derived-type node)))
+ (labels ((process-ref (ref)
+ (when (ref-p ref)
+ (let (leaf)
+ (if (constant-p (setf leaf (ref-leaf ref)))
+ (when (or ignore-types
+ (ctypep (constant-value leaf) (single-value-type type)))
+ (values leaf ref))
+ (process-lvar (lambda-var-ref-lvar ref))))))
+ (process-lvar (lvar)
+ (when lvar
+ (process-ref (lvar-uses (principal-lvar lvar)))))
+ (process-node (node)
+ (cond ((cast-p node)
+ (process-lvar (cast-value node)))
+ ((ref-p node)
+ (process-ref node)))))
+ (process-node node)))))
+
(defun lvar-constant (lvar &optional ignore-types)
(declare (type lvar lvar))
(let ((type (lvar-type lvar)))
diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 425466049..bf1a3c846 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -712,6 +712,9 @@
(handle-combination dest))))))))
(erase lvar nth-value))))
+(defun node-single-value-type (node)
+ (single-value-type (node-derived-type node)))
+
;;; Update lvar use information so that NODE is no longer a use of its
;;; LVAR.
;;;
diff --git a/tests/array.pure.lisp b/tests/array.pure.lisp
index 27ef5602e..27d8b3309 100644
--- a/tests/array.pure.lisp
+++ b/tests/array.pure.lisp
@@ -1156,3 +1156,13 @@
a
(error "")))
(and array (not simple-array))))
+
+(with-test (:name :aref-constants-type)
+ (assert-type
+ (lambda (x n)
+ (aref (if n #(1 -2) #(1 2)) x))
+ (integer -2 2))
+ (assert-type
+ (lambda (x n)
+ (aref (if n (the string n) #(1 2)) x))
+ (or (integer 1 2) character)))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL