master: More partial result modification false positives

The branch "master" has been updated in SBCL:
       via  01bd7882b1af89d296a28a359419de20f423b3f2 (commit)
      from  2e9abed30d94fd4d6050381fa364b9869c486fa4 (commit)

- Log -----------------------------------------------------------------
commit 01bd7882b1af89d296a28a359419de20f423b3f2
Author: Stas Boukarev <[email protected]>
Date:   Sun Aug 30 12:05:50 2026 +0300

    More partial result modification false positives
---
 src/compiler/ir1util.lisp | 73 ++++++++++++++++++++++++++---------------------
 tests/bad-code.pure.lisp  |  7 ++++-
 xperfecthash63.lisp-expr  |  7 +++++
 3 files changed, 54 insertions(+), 33 deletions(-)

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 894eaff82..8c4ab79ba 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -3837,8 +3837,8 @@ is :ANY, the function name is not checked."
                                                           source-path)))))
                     collect annotation)))))))
 
-(defun lvar-constants (lvar &optional walk-functions)
-  (named-let recurse ((lvar lvar) (seen nil) (toplevel t))
+(defun lvar-constants (lvar &optional walk-functions partial-modifier)
+  (named-let recurse ((lvar lvar) (seen nil) (toplevel (not partial-modifier)))
     (let ((uses (lvar-uses lvar)))
       (flet ((handle-ref (ref)
                (let* ((ref (principal-ref ref))
@@ -3923,36 +3923,45 @@ is :ANY, the function name is not checked."
         (leaf-debug-name leaf))))
 
 (defun process-lvar-modified-annotation (lvar annotation)
-  (multiple-value-bind (type values) (lvar-constants lvar t)
-    (labels ((modifiable-p (value)
-               (or (consp value)
-                   (and (arrayp value)
-                        (not (typep value '(vector * 0))))
-                   (hash-table-p value)))
-             (report (values)
-               (let ((sans-nil (remove nil values)))
-                (when (and sans-nil
-                           (every #'modifiable-p sans-nil))
-                  (warn 'constant-modified
-                        :fun-name (lvar-modified-annotation-caller annotation)
-                        :values sans-nil)))))
-     (case type
-       (:macro
-        (let ((lambda-var values))
-          (when (and (lambda-var-constant lambda-var)
-                     (not (lambda-var-sets lambda-var)))
-            (warn 'sb-kernel::macro-arg-modified
-                  :fun-name (lvar-modified-annotation-caller annotation)
-                  :variable (lambda-var-original-name lambda-var))
-            (return-from process-lvar-modified-annotation))))
-       (:values
-        (report values)
-        t)
-       (:calls
-        (loop for (call . values) in values
-              do (let ((*compiler-error-context* call))
-                   (report values)))
-        t)))))
+  (let ((partial-modifier-p
+          (not (member (lvar-modified-annotation-caller annotation)
+                       '(replace nreverse map-into nconc nreconc
+                         fill delq delq1
+                         delete delete-if delete-if-not
+                         delete-duplicates nunion nintersection
+                         nsubstitute nsubstitute-if nsubstitute-if-not
+                         nsubst nsubst-if nsubst-if-not
+                         sort stable-sort merge read-sequence)))))
+    (multiple-value-bind (type values) (lvar-constants lvar t partial-modifier-p)
+      (labels ((modifiable-p (value)
+                 (or (consp value)
+                     (and (arrayp value)
+                          (not (typep value '(vector * 0))))
+                     (hash-table-p value)))
+               (report (values)
+                 (let ((sans-nil (remove nil values)))
+                   (when (and sans-nil
+                              (every #'modifiable-p sans-nil))
+                     (warn 'constant-modified
+                           :fun-name (lvar-modified-annotation-caller annotation)
+                           :values sans-nil)))))
+        (case type
+          (:macro
+           (let ((lambda-var values))
+             (when (and (lambda-var-constant lambda-var)
+                        (not (lambda-var-sets lambda-var)))
+               (warn 'sb-kernel::macro-arg-modified
+                     :fun-name (lvar-modified-annotation-caller annotation)
+                     :variable (lambda-var-original-name lambda-var))
+               (return-from process-lvar-modified-annotation))))
+          (:values
+           (report values)
+           t)
+          (:calls
+           (loop for (call . values) in values
+                 do (let ((*compiler-error-context* call))
+                      (report values)))
+           t))))))
 
 (defun improper-sequence-p (annotation value)
   (case annotation
diff --git a/tests/bad-code.pure.lisp b/tests/bad-code.pure.lisp
index 709b5c870..4403a1b63 100644
--- a/tests/bad-code.pure.lisp
+++ b/tests/bad-code.pure.lisp
@@ -1134,4 +1134,9 @@
 (with-test (:name :constant-modification-partial-result)
   (checked-compile
    '(lambda (b n)
-     (delete 10 (nth n (list* b '(a b a)))))))
+     (delete 10 (nth n (list* b '(a b a))))))
+  (checked-compile
+   '(lambda (v)
+     (let ((x (cons v "b")))
+       (setf (car x) 10)
+       x))))
diff --git a/xperfecthash63.lisp-expr b/xperfecthash63.lisp-expr
index 43ab23aa3..93ecc99d3 100644
--- a/xperfecthash63.lisp-expr
+++ b/xperfecthash63.lisp-expr
@@ -1922,5 +1922,12 @@
 (#(A49305EF D0241AE7 E55E7F8C EE9A5410)
  "(SB-PCL::%CLASS SB-PCL::%PARAMETER SB-PCL::%VARIABLE-REBINDING SPECIAL)"
  "((& (>> val 8) 3))")
+(#(44525B4 78E7135 125F7E49 369D9E78 4D244188 4EEED766 50C23A77 5166495A 714B061E 768D8BB2 7D92B35C 81E21B39 88D160D7 891ABD8F
+   B1954899 B3988E73 C21CB849 CF5EC8DB D1321820 D6DCF825 DB690EC5 F1EA8886 FADF2FF2 FE80D3EE)
+ "(REPLACE NREVERSE MAP-INTO NCONC NRECONC FILL DELQ DELQ1 DELETE DELETE-IF DELETE-IF-NOT DELETE-DUPLICATES NUNION NINTERSECTION NSUBSTITUTE NSUBSTITUTE-IF NSUBSTITUTE-IF-NOT NSUBST NSUBST-IF NSUBST-IF-NOT SORT STABLE-SORT MERGE READ-SEQUENCE)"
+ "((let ((tab #a((16) (unsigned-byte 8) 0 15 7 15 16 1 18 0 0 31 0 21 31 13 18 4)))
+  (let ((b (& (>> val 4) #xf)))
+   (let ((a (>> (<< val 7) 28)))
+    (^ a (aref tab b))))))")
 )
 ;; EOF

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


hooks/post-receive
-- 
SBCL