master: Distinguish between full and partial constant pass-through

The branch "master" has been updated in SBCL:
       via  1899deda6a8d986aa891ca49e945780e21c2fd03 (commit)
      from  5bfa2103ecc8139ef53198d71d32f5ac67ab1925 (commit)

- Log -----------------------------------------------------------------
commit 1899deda6a8d986aa891ca49e945780e21c2fd03
Author: Stas Boukarev <[email protected]>
Date:   Sun Aug 30 04:45:32 2026 +0300

    Distinguish between full and partial constant pass-through
---
 src/compiler/ir1util.lisp | 12 +++++++-----
 src/compiler/seqtran.lisp | 10 ++++++++--
 tests/bad-code.pure.lisp  |  5 +++++
 3 files changed, 20 insertions(+), 7 deletions(-)

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index fdd35f985..894eaff82 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -3838,7 +3838,7 @@ is :ANY, the function name is not checked."
                     collect annotation)))))))
 
 (defun lvar-constants (lvar &optional walk-functions)
-  (named-let recurse ((lvar lvar) (seen nil))
+  (named-let recurse ((lvar lvar) (seen nil) (toplevel t))
     (let ((uses (lvar-uses lvar)))
       (flet ((handle-ref (ref)
                (let* ((ref (principal-ref ref))
@@ -3852,7 +3852,7 @@ is :ANY, the function name is not checked."
                            (lambda (call lvar)
                              (unless (xset-member-p lvar seen)
                                (add-to-xset lvar seen)
-                               (multiple-value-bind (type values) (recurse lvar seen)
+                               (multiple-value-bind (type values) (recurse lvar seen toplevel)
                                  (case type
                                    (:values
                                     (push (cons call values) constants))
@@ -3868,10 +3868,12 @@ is :ANY, the function name is not checked."
                     (eq (combination-kind node) :known)
                     (let ((fun-info (fun-info-constants (combination-fun-info node))))
                       (when fun-info
-                        (let ((constants (funcall fun-info node)))
-                          (when constants
+                        (multiple-value-bind (constants partial) (funcall fun-info node)
+                          (when (and constants
+                                     (or toplevel
+                                         (not partial))) ;; (car (append x constant)) is ok
                             (multiple-value-bind (kind constants)
-                                (recurse constants seen)
+                                (recurse constants seen nil)
                               (when constants
                                 (values kind constants))))))))))
         (cond ((constant-lvar-p lvar)
diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index 3e1c462bb..f7b4df72f 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -4511,7 +4511,7 @@
     (make-numeric-type 'integer min max)))
 
 (defoptimizers constants
-    (nth nthcdr sb-impl::append2 nreconc revappend
+    (nth nthcdr
      %adjoin %adjoin-eq %adjoin-key %adjoin-test %adjoin-key-eq %adjoin-key-test %adjoin-key-test-not
      %assoc %assoc-eq %assoc-key %assoc-test %assoc-key-eq %assoc-key-test %assoc-key-test-not
      %rassoc %rassoc-eq %rassoc-key %rassoc-test %rassoc-key-eq %rassoc-key-test %rassoc-key-test-not
@@ -4528,8 +4528,14 @@
     ((a &rest args))
   a)
 
+(defoptimizers constants
+    (sb-impl::append2 nreconc revappend
+     %adjoin %adjoin-eq %adjoin-key %adjoin-test %adjoin-key-eq %adjoin-key-test %adjoin-key-test-not)
+    ((a b &rest args))
+  (values b t)) ;; partial result
+
 (defoptimizers constants (append nconc list*) ((&rest args))
-  (car (last args)))
+  (values (car (last args)) t))
 
 (defoptimizer (vector-to-list derive-type) ((vector))
   (when (typep (nth-value 1 (sequence-lvar-dimensions vector)) '(integer 1))
diff --git a/tests/bad-code.pure.lisp b/tests/bad-code.pure.lisp
index e0c2708f4..709b5c870 100644
--- a/tests/bad-code.pure.lisp
+++ b/tests/bad-code.pure.lisp
@@ -1130,3 +1130,8 @@
                                      (delete 2 (list* '- a))))
                           (a (* 2 3))))
                       :allow-warnings 'sb-kernel::macro-arg-modified))))
+
+(with-test (:name :constant-modification-partial-result)
+  (checked-compile
+   '(lambda (b n)
+     (delete 10 (nth n (list* b '(a b a)))))))

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL