master: Check types for concatenate-subseq
stassats via Sbcl-commits <[email protected]> Mon, 08 Jun 2026 23:33:37 +0000
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via b0916688cbced286faa4b5cf804961655d3880e2 (commit)
from ddedba22893371ebb96b2b81865eefd2ba27ab6d (commit)
- Log -----------------------------------------------------------------
commit b0916688cbced286faa4b5cf804961655d3880e2
Author: Stas Boukarev <[email protected]>
Date: Mon Jun 8 23:31:27 2026 +0300
Check types for concatenate-subseq
---
src/compiler/array-tran.lisp | 39 ++++++++++----------
src/compiler/seqtran.lisp | 88 +++++++++++++++++++++++++++-----------------
src/compiler/srctran.lisp | 62 +++++++++++++++++++++----------
3 files changed, 117 insertions(+), 72 deletions(-)
diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index 18245c6fa..7e1adaba5 100644
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -382,25 +382,26 @@
(setf (getf (leaf-info constant) key)
(constant-sequence-element-type (constant-value constant) key)))))
-(defun sequence-elements-type (sequence &optional key)
- (or (let ((uses (lvar-uses sequence)))
- (if (consp uses)
- (let (other-types
- constant-types)
- (loop for use in uses
- do
- (let ((type (constant-array-element-type (node-constant use) key)))
- (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) key)))
+(defun sequence-elements-type (sequence &optional key (constants t))
+ (or (and constants
+ (let ((uses (lvar-uses sequence)))
+ (if (consp uses)
+ (let (other-types
+ constant-types)
+ (loop for use in uses
+ do
+ (let ((type (constant-array-element-type (node-constant use) key)))
+ (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) key))))
(if key
*universal-type*
(unwild (type-array-element-type (lvar-type sequence))))))
diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index 3c9c5663f..b8dc4f923 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -1833,6 +1833,57 @@
(defoptimizer (vector-push-extend ir2-hook) ((item vector &optional min-extension) node)
(check-sequence-item item vector node "Can't push ~a into ~a"))
+(defun check-concatenate-sequence-type (type result-element-type sequence node &key (description "concatenate")
+ (constants t))
+ (when result-element-type
+ (let ((constant (and (constant-lvar-p sequence)
+ (lvar-value sequence))))
+ (if (and constant
+ (proper-sequence-p constant))
+ (map nil
+ (lambda (elt)
+ (multiple-value-bind (fits really) (ctypep elt result-element-type)
+ (when (and really (not fits))
+ (let ((*compiler-error-context* node))
+ (compiler-warn "Can't ~a ~s into ~s"
+ description
+ elt
+ (if (ctype-p type)
+ (type-specifier (make-array-type '(*)
+ :specialized-element-type type
+ :element-type type))
+ type))
+ (return-from check-concatenate-sequence-type)))))
+ constant)
+ (let ((element-type (sequence-elements-type sequence nil constants)))
+ (when (and element-type
+ (not (eq element-type *wild-type*))
+ (not (types-equal-or-intersect element-type result-element-type)))
+ (let ((*compiler-error-context* node))
+ (compiler-warn "Can't ~a elements of type ~s into ~s"
+ description
+ (type-specifier element-type)
+ (if (ctype-p type)
+ (type-specifier (make-array-type '(*)
+ :specialized-element-type type
+ :element-type type))
+ type)))))))))
+
+(defun check-concatenate-element-type (type result-element-type element-type node &key (description "concatenate"))
+ (when (and result-element-type
+ element-type
+ (not (eq element-type *wild-type*))
+ (not (types-equal-or-intersect element-type result-element-type)))
+ (let ((*compiler-error-context* node))
+ (compiler-warn "Can't ~a elements of type ~s into ~s"
+ description
+ (type-specifier element-type)
+ (if (ctype-p type)
+ (type-specifier (make-array-type '(*)
+ :specialized-element-type type
+ :element-type type))
+ type)))))
+
(defun check-concatenate (type sequences node &optional (description "concatenate"))
(let ((result-element-type (if (ctype-p type)
type
@@ -1840,40 +1891,9 @@
(return-from check-concatenate))))))
(unless (or (eq result-element-type *wild-type*)
(eq result-element-type *universal-type*))
- (loop for i from 0
- for sequence in sequences
- for constant = (and (constant-lvar-p sequence)
- (lvar-value sequence))
- do (if (and constant
- (proper-sequence-p constant))
- (map nil
- (lambda (elt)
- (multiple-value-bind (fits really) (ctypep elt result-element-type)
- (when (and really (not fits))
- (let ((*compiler-error-context* node))
- (compiler-warn "Can't ~a ~s, of type ~s, into ~s"
- description
- elt (type-of elt)
- (if (ctype-p type)
- (type-specifier (make-array-type '(*)
- :specialized-element-type type
- :element-type type))
- type))
- (return)))))
- constant)
- (let ((element-type (sequence-elements-type sequence)))
- (when (and element-type
- (not (eq element-type *wild-type*))
- (not (types-equal-or-intersect element-type result-element-type)))
- (let ((*compiler-error-context* node))
- (compiler-warn "Can't ~a elements of type ~s into ~s"
- description
- (type-specifier element-type)
- (if (ctype-p type)
- (type-specifier (make-array-type '(*)
- :specialized-element-type type
- :element-type type))
- type))))))))))
+ (loop for sequence in sequences
+ do (check-concatenate-sequence-type type result-element-type
+ sequence node :description description)))))
(defoptimizer (%concatenate-to-string ir2-hook) ((&rest args) node)
(check-concatenate 'string args node))
diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index ec545cbcd..487fe4f2a 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -453,30 +453,54 @@
(defoptimizer (%concatenate-to-vector-subseq externally-checkable-type) ((type &rest args) node lvar)
(concatenate-subseq-type lvar args))
-(defun concatenate-subseq-check-ranges (args node)
- (loop while args
- do (let ((arg (pop args)))
- (when (constant-lvar-p arg)
- (case (lvar-value arg)
- (sb-impl::%subseq
- (check-sequence-ranges (pop args) (pop args) (pop args) node))
- (sb-impl::%splice
- (loop repeat (lvar-value (pop args))
- do (pop args)))
- (sb-impl::%repeat
- (pop args)
- (pop args)))))))
+(defun check-concatenate-subseq (type args node)
+ (let* ((result-element-type (and type
+ (if (ctype-p type)
+ type
+ (block nil
+ (type-array-element-type (or (careful-specifier-type type)
+ (return)))))))
+ (result-element-type (unless (or (eq result-element-type *wild-type*)
+ (eq result-element-type *universal-type*))
+ result-element-type)))
+ (loop while args
+ do (let ((arg (pop args)))
+ (when (constant-lvar-p arg)
+ (case (lvar-value arg)
+ (sb-impl::%subseq
+ (let ((sequence (pop args))
+ (start (pop args))
+ (end (pop args)))
+ (check-sequence-ranges sequence start end node)
+ (check-concatenate-sequence-type type result-element-type sequence node :constants nil)))
+ (sb-impl::%splice
+ (loop repeat (lvar-value (pop args))
+ for elt = (pop args)
+ do
+ (check-concatenate-element-type type result-element-type (lvar-type elt) node)))
+ (sb-impl::%repeat
+ (pop args)
+ (let ((elt
+ (pop args)))
+ (check-concatenate-element-type type result-element-type (lvar-type elt) node)))
+ (t
+ (check-concatenate-sequence-type type result-element-type arg node :constants nil))))))))
(defoptimizer (%concatenate-to-string-subseq ir2-hook) ((&rest args) node)
- (concatenate-subseq-check-ranges args node))
+ (check-concatenate-subseq 'string args node))
(defoptimizer (%concatenate-to-base-string-subseq ir2-hook) ((&rest args) node)
- (concatenate-subseq-check-ranges args node))
+ (check-concatenate-subseq 'base-string args node))
(defoptimizer (%concatenate-to-list-subseq ir2-hook) ((&rest args) node)
- (concatenate-subseq-check-ranges args node))
+ (check-concatenate-subseq nil args node))
(defoptimizer (%concatenate-to-simple-vector-subseq ir2-hook) ((&rest args) node)
- (concatenate-subseq-check-ranges args node))
-(defoptimizer (%concatenate-to-vector-subseq ir2-hook) ((type &rest args) node)
- (concatenate-subseq-check-ranges args node))
+ (check-concatenate-subseq nil args node))
+(defoptimizer (%concatenate-to-vector-subseq ir2-hook) ((widetag &rest args) node)
+ (check-concatenate-subseq (and (constant-lvar-p widetag)
+ (sb-vm:saetp-ctype
+ (find (lvar-value widetag)
+ sb-vm:*specialized-array-element-type-properties*
+ :key #'sb-vm:saetp-typecode)))
+ args node))
(defoptimizer (%concatenate-to-list derive-type) ((&rest args))
(loop for arg in args
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL