master: Never transform ELT to NTH
stassats via Sbcl-commits <[email protected]>
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via 09e5b5d14ec199a0e7538a9b18fb88da20200572 (commit)
from 8a26a86d766e650eb5058b5f0724447ee063aaea (commit)
- Log -----------------------------------------------------------------
commit 09e5b5d14ec199a0e7538a9b18fb88da20200572
Author: Stas Boukarev <[email protected]>
Date: Tue Aug 18 06:44:02 2026 +0300
Never transform ELT to NTH
The initial problem is that elt derives types on constant lists
without adding a NIL, which can be returned by NTH.
Always check bounds instead.
There's no performance advantage in not signaling an error.
---
src/code/seq.lisp | 96 +++++++++++++++++++++++++++++++---------------
src/code/target-error.lisp | 32 +++++++++-------
src/cold/exports.lisp | 4 +-
src/compiler/fndb.lisp | 16 +++++---
src/compiler/seqtran.lisp | 10 ++---
src/compiler/srctran.lisp | 24 ++++++++----
tests/seq.impure.lisp | 5 +--
tests/seq.pure.lisp | 3 +-
8 files changed, 121 insertions(+), 69 deletions(-)
diff --git a/src/code/seq.lisp b/src/code/seq.lisp
index 35d02981e..ecd0323bf 100644
--- a/src/code/seq.lisp
+++ b/src/code/seq.lisp
@@ -292,18 +292,23 @@
(and (csubtypep type (specifier-type 'vector))
(not (csubtypep type (specifier-type '(and vector (not simple-array))))))))))
-(declaim (ftype (function (sequence index) nil) signal-index-too-large-error))
-(define-error-wrapper signal-index-too-large-error (sequence index)
- (let* ((length (length sequence))
- (max-index (and (plusp length)
- (1- length))))
- (error 'index-too-large-error
- :datum index
- :sequence sequence
- :expected-type (if max-index
- `(integer 0 ,max-index)
- ;; This seems silly, is there something better?
- '(integer 0 (0))))))
+(declaim (ftype (function (sequence index &optional t) nil) signal-index-too-large-error))
+(define-error-wrapper signal-index-too-large-error (sequence index &optional rest)
+ (if rest
+ (error 'index-too-large-error
+ :datum index
+ :sequence rest
+ :expected-type `(integer 0 (,rest)))
+ (let* ((length (length sequence))
+ (max-index (and (plusp length)
+ (1- length))))
+ (error 'index-too-large-error
+ :datum index
+ :sequence sequence
+ :expected-type (if max-index
+ `(integer 0 ,max-index)
+ ;; This seems silly, is there something better?
+ '(integer 0 (0)))))))
(declaim (ftype (function (t t t) nil) sequence-bounding-indices-bad-error))
(define-error-wrapper sequence-bounding-indices-bad-error (sequence start end)
@@ -342,17 +347,33 @@
(zerop (length sequence))
(sb-sequence:emptyp sequence)))
+(declaim (maybe-inline elt-list %setelt-list))
+(defun elt-list (list index)
+ (declare (explicit-check)
+ (optimize speed))
+ (prog ((result list)
+ (i index))
+ (when (typep index '(and unsigned-byte fixnum))
+ (go loop))
+ bad
+ (signal-index-too-large-error list index)
+ loop
+ (unless (listp result)
+ (go bad))
+ (if (plusp (truly-the fixnum i))
+ (psetq i (1- i)
+ result (cdr result))
+ (if (atom result)
+ (go bad)
+ (return (car result))))
+ (go loop)))
+
(defun elt (sequence index)
"Return the element of SEQUENCE specified by INDEX."
- (declare (explicit-check sequence))
+ (declare (explicit-check sequence)
+ (inline elt-list))
(seq-dispatch-checking sequence
- (do ((count index (1- count))
- (list sequence (cdr list)))
- ((= count 0)
- (if (atom list)
- (signal-index-too-large-error sequence index)
- (car list)))
- (declare (type index count)))
+ (elt-list sequence index)
(locally
(declare (optimize (sb-c:insert-array-bounds-checks 0)))
(when (>= index (length sequence))
@@ -360,18 +381,31 @@
(aref sequence index))
(sb-sequence:elt sequence index)))
+(defun %setelt-list (list index newval)
+ (declare (explicit-check)
+ (optimize speed))
+ (prog ((result list)
+ (i index))
+ (when (typep index '(and unsigned-byte fixnum))
+ (go loop))
+ bad
+ (signal-index-too-large-error list index)
+ loop
+ (unless (listp result)
+ (go bad))
+ (if (plusp (truly-the fixnum i))
+ (psetq i (1- i)
+ result (cdr result))
+ (if (atom result)
+ (go bad)
+ (return (setf (car result) newval))))
+ (go loop)))
+
(defun %setelt (sequence index newval)
"Store NEWVAL as the component of SEQUENCE specified by INDEX."
(declare (explicit-check sequence))
(seq-dispatch-checking sequence
- (do ((count index (1- count))
- (seq sequence))
- ((= count 0) (rplaca seq newval) newval)
- (declare (fixnum count))
- (let ((cdr (cdr seq)))
- (if (atom cdr)
- (signal-index-too-large-error sequence index)
- (setq seq cdr))))
+ (%setelt-list sequence index newval)
(if (>= index (length sequence))
(signal-index-too-large-error sequence index)
(locally
@@ -383,9 +417,9 @@
"Return an integer that is the length of SEQUENCE."
(declare (explicit-check))
(seq-dispatch-checking sequence
- (length sequence)
- (length sequence)
- (sb-sequence:length sequence)))
+ (length sequence)
+ (length sequence)
+ (sb-sequence:length sequence)))
(defun make-sequence (result-type length &key (initial-element nil iep))
"Return a sequence of the given RESULT-TYPE and LENGTH, with
diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp
index 9a7f1e820..3cee6244c 100644
--- a/src/code/target-error.lisp
+++ b/src/code/target-error.lisp
@@ -1470,21 +1470,25 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL."))
(lambda (condition stream)
(let ((sequence (slot-value condition 'sequence))
(index (type-error-datum condition)))
- (if (vectorp sequence)
- (format stream "Invalid index ~D for ~S~@[ with fill-pointer ~D~]~
+ (cond ((integerp sequence)
+ (format stream "Invalid index ~d for a &rest list of length ~d."
+ index sequence))
+ ((vectorp sequence)
+ (format stream "Invalid index ~D for ~S~@[ with fill-pointer ~D~]~
~@[, ~:@_should be a non-negative integer below ~D~]."
- index
- (type-of sequence)
- (and (array-has-fill-pointer-p sequence)
- (fill-pointer sequence))
- (let ((l (length sequence))) (if (> l 0) l)))
- (format stream
- "The index ~D is too large for a ~a of length ~D."
- index
- (if (listp sequence)
- "list"
- "sequence")
- (length sequence)))))))
+ index
+ (type-of sequence)
+ (and (array-has-fill-pointer-p sequence)
+ (fill-pointer sequence))
+ (let ((l (length sequence))) (if (> l 0) l))))
+ (t
+ (format stream
+ "The index ~D is too large for a ~a of length ~D."
+ index
+ (if (listp sequence)
+ "list"
+ "sequence")
+ (length sequence))))))))
(define-condition bounding-indices-bad-error (reference-condition type-error)
((object :reader bounding-indices-bad-object :initarg :object))
diff --git a/src/cold/exports.lisp b/src/cold/exports.lisp
index f499c1ced..950f0b0d4 100644
--- a/src/cold/exports.lisp
+++ b/src/cold/exports.lisp
@@ -2386,7 +2386,9 @@ is a good idea, but see SB-SYS re. blurring of boundaries.")
"SIMPLE-BASE-STRING="
#+sb-unicode "SIMPLE-CHARACTER-STRING="
"%SP-STRING-COMPARE" "%SP-STRING="
- "%SETNTH" "%SETELT"
+ "%SETNTH"
+ "%SETELT" "%SETELT-LIST"
+ "ELT-LIST"
"%SET-ROW-MAJOR-AREF" "%SET-FILL-POINTER"
"%SET-FDEFINITION" "%SCHARSET"
"%RPLACD" "%RPLACA" "%PUT" "%CHARSET"
diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index 95f88562b..39eb00b94 100644
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -620,9 +620,15 @@
;;;; from the "Sequences" chapter:
(defknown elt ((read-only proper-sequence) index) t (foldable unsafely-flushable))
+(defknown elt-list ((read-only proper-list) index) t (foldable unsafely-flushable))
+
+(defknown %setelt ((modifying sequence) index t) t ()
+ :derive-type #'result-type-last-arg)
+(defknown %setelt-list ((modifying sequence) index t) t ()
+ :derive-type #'result-type-last-arg)
(defknown subseq ((read-only proper-sequence) index &optional sequence-end) consed-sequence
- (flushable foldable-read-only))
+ (flushable foldable-read-only))
(defknown vector-subseq ((read-only vector) index sequence-end) (simple-array * (*))
(flushable foldable-read-only no-verify-arg-count))
@@ -2176,6 +2182,7 @@
(defknown %rest-values (t t t t) * (always-translatable))
(defknown %rest-ref (t t t t &optional boolean) * (always-translatable))
+(defknown %rest-elt (t t t t &optional boolean) * (always-translatable))
(defknown %rest-length (t t t) * (always-translatable))
(defknown %rest-null (t t t t) * (always-translatable))
(defknown %rest-true (t t t) * (always-translatable))
@@ -2297,10 +2304,11 @@
function (flushable no-verify-arg-count))
(defknown array-bounding-indices-bad-error (t t t) nil (no-verify-arg-count))
(defknown sequence-bounding-indices-bad-error (t t t) nil (no-verify-arg-count))
+(defknown sb-impl::signal-index-too-large-error (sequence index &optional t) nil)
(defknown %find-position
(t sequence t index sequence-end (function (t)) (function (t t)))
- (values t (or index null))
- (flushable foldable call no-verify-arg-count))
+ (values t (or index null))
+ (flushable foldable call no-verify-arg-count))
(defknown (%find-position-if %find-position-if-not)
((function ((nth-arg 1 :sequence t :key (nth-arg 5))))
sequence t index sequence-end (function ((nth-arg 1 :sequence t))))
@@ -2391,8 +2399,6 @@
(defknown (%rplaca %rplacd) ((modifying cons) t) t ()
:derive-type #'result-type-last-arg)
(defknown %put (symbol t t) t (no-verify-arg-count))
-(defknown %setelt ((modifying sequence) index t) t ()
- :derive-type #'result-type-last-arg)
(defknown %svset ((modifying simple-vector) index t) t ())
(defknown (setf bit) (bit (modifying (array bit)) &rest index) bit ())
(defknown (setf sbit) (bit (modifying (simple-array bit)) &rest index) bit ())
diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index 3dc5b0d63..59c1b3d89 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -403,16 +403,14 @@
(deftransform elt ((s i) (simple-array t) *)
'(aref s i))
-(deftransform elt ((s i) (list t) * :policy (< safety 3))
- (when (eql (lvar-type s) (specifier-type 'null))
- (give-up-ir1-transform))
- '(nth i s))
+(deftransform elt ((s i) (list t))
+ '(elt-list s i))
(deftransform %setelt ((s i v) ((simple-array * (*)) t t) *)
'(setf (aref s i) v))
-(deftransform %setelt ((s i v) (list t t) * :policy (< safety 3))
- '(setf (car (nthcdr i s)) v))
+(deftransform %setelt ((s i v) (list t t))
+ '(%setelt-list s i v))
(deftransform %check-vector-sequence-bounds ((vector start end)
(vector t t) *
diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 6c87e24d9..6a1ac495c 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -8336,7 +8336,7 @@
;; isn't good anywhere else either.
(lvar-fun-is (combination-fun dest)
'(%rest-values %rest-ref %rest-length
- %rest-null %rest-true %rest-listify))
+ %rest-null %rest-true %rest-listify %rest-elt))
;; If the home lambda is different and isn't DX, it might
;; escape -- in which case using the more context isn't safe.
(dx-node-p dest))))
@@ -8390,12 +8390,10 @@
(bug "no &REST context for FAST-REST-NTH"))))
(define-source-transform elt (seq n)
- (if (policy *lexenv* (= safety 3))
- (values nil t)
- (multiple-value-bind (context count) (possible-rest-arg-context seq)
- (if context
- `(%rest-ref ,n ,seq ,context ,count)
- (values nil t)))))
+ (multiple-value-bind (context count) (possible-rest-arg-context seq)
+ (if context
+ `(%rest-elt ,n ,seq ,context ,count)
+ (values nil t))))
;;; CAxR -> %REST-REF
(defun source-transform-car (list nth)
@@ -8522,6 +8520,18 @@
(t
`(and (< (the index n) count) (%more-arg context n)))))
+(deftransform %rest-elt ((n list context count &optional length-checked-p))
+ (cond ((not (rest-var-more-context-ok list))
+ `(elt-list list n))
+ ((and length-checked-p
+ (constant-lvar-p length-checked-p)
+ (lvar-value length-checked-p))
+ `(%more-arg context n))
+ (t
+ `(if (< (the index n) count)
+ (%more-arg context n)
+ (sb-impl::signal-index-too-large-error nil n count)))))
+
(deftransform %rest-length ((list context count))
(if (rest-var-more-context-ok list)
'count
diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp
index a3150d9e8..ffb9cc817 100644
--- a/tests/seq.impure.lisp
+++ b/tests/seq.impure.lisp
@@ -419,10 +419,9 @@
(:optimize :safe)
`(lambda (x) (elt x 3))
(("foo") (condition 'type-error))
+ (('(1 2)) (condition 'type-error))
(("foob") #\b))
- (locally
- (declare (optimize (safety 3)))
- (assert-error (elt (list 1 2 3) 3) type-error)))
+ (assert-error (elt (list 1 2 3) 3) type-error))
;;; confusion in the refactoring led to this signalling an unbound
;;; variable, not a type error.
diff --git a/tests/seq.pure.lisp b/tests/seq.pure.lisp
index 119542e4c..d054d3224 100644
--- a/tests/seq.pure.lisp
+++ b/tests/seq.pure.lisp
@@ -416,8 +416,7 @@
(with-test (:name :&more-elt-index-too-large)
(checked-compile-and-assert
- (:optimize `(:filter ,(lambda (&key safety &allow-other-keys)
- (= safety 3))))
+ (:optimize :safe)
`(lambda (&rest args)
(elt args 0))
(() (condition 'sb-kernel:index-too-large-error))))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL