master: Don't delete blocks during constraint propagation

The branch "master" has been updated in SBCL:
       via  4331687bb8ce33d48c084e990a497e1a1ba79830 (commit)
      from  e45c5c70b571e9dcb1e784c810bd071407f9e89d (commit)

- Log -----------------------------------------------------------------
commit 4331687bb8ce33d48c084e990a497e1a1ba79830
Author: Stas Boukarev <[email protected]>
Date:   Sat Jul 25 18:38:16 2026 +0300

    Don't delete blocks during constraint propagation
    
    When deleting SETs.
    
    Fixes lp#2161789
---
 src/compiler/constraint.lisp | 30 +++++++++++++++++-------------
 src/compiler/ir1util.lisp    |  5 +++++
 tests/constraint.pure.lisp   | 14 ++++++++++++++
 3 files changed, 36 insertions(+), 13 deletions(-)

diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp
index 6c67fe3d9..3526e3fff 100644
--- a/src/compiler/constraint.lisp
+++ b/src/compiler/constraint.lisp
@@ -53,6 +53,7 @@
 (declaim (type (and (vector t) (not simple-array)) *constraint-universe*))
 (defvar *constraint-universe*)
 (defvar *blocks-to-terminate*)
+(defvar *sets-to-delete*)
 (defvar *constraint-blocks*)
 (defvar *constraint-blocks-p*)
 
@@ -1335,18 +1336,19 @@
   (let ((var (set-var set)))
     (when (and (lambda-var-p var)
                (lambda-var-eq-constraints var))
-      (let* ((value (set-value set))
-             (ref (principal-lvar-use value)))
-        (when (and (ref-p ref)
-                   (eq (ref-leaf ref) var))
-          (let ((constraint (gethash (node-lvar ref)
-                                     (lambda-var-eq-constraints var))))
-            (when (and constraint
-                       (conset-member constraint in))
-              (setf (lambda-var-sets var)
-                    (delq1 set (lambda-var-sets var)))
-              (delete-filter set (node-lvar set) value)
-              t)))))))
+      (or (member set *sets-to-delete*)
+          (let* ((value (set-value set))
+                 (ref (principal-lvar-use value)))
+            (when (and (ref-p ref)
+                       (eq (ref-leaf ref) var))
+              (let ((constraint (gethash (node-lvar ref)
+                                         (lambda-var-eq-constraints var))))
+                (when (and constraint
+                           (conset-member constraint in))
+                  ;; Don't delete here because it might lead to block
+                  ;; deletion and disturb the computed constraints
+                  (push set *sets-to-delete*)
+                  t))))))))
 
 ;;;; Flow analysis
 
@@ -1778,6 +1780,7 @@
         (setf (if-consequent-constraints last) nil))))
 
   (let (*blocks-to-terminate*
+        *sets-to-delete*
         *constraint-blocks-p*)
     (dolist (block (find-and-propagate-constraints component))
       (unless (block-delete-p block)
@@ -1787,5 +1790,6 @@
                (memq :constraints *compile-trace-targets*))
       (print-constraints component))
     (loop for node in *blocks-to-terminate*
-          do (maybe-terminate-block node nil)))
+          do (maybe-terminate-block node nil))
+    (mapc #'delete-set *sets-to-delete*))
   (values))
diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 1d161de7f..a2d7d4d55 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -4262,3 +4262,8 @@ is :ANY, the function name is not checked."
        (loop for d in x
              always (or (typep d 'index)
                         (eq d '*)))))
+(defun delete-set (set)
+  (let ((var (set-var set)))
+    (setf (lambda-var-sets var)
+          (delq1 set (lambda-var-sets var)))
+    (delete-filter set (node-lvar set) (set-value set))))
diff --git a/tests/constraint.pure.lisp b/tests/constraint.pure.lisp
index 1c32942ff..20fb320f1 100644
--- a/tests/constraint.pure.lisp
+++ b/tests/constraint.pure.lisp
@@ -2165,6 +2165,7 @@
                         (loop
                          (let ((new (+ v 1)))
                            (setf v new)))))))
+
 (with-test (:name :join-equality-constraints-loop)
   (checked-compile
    `(lambda (data n d j)
@@ -2190,3 +2191,16 @@
              (go g826)))
 
         (do ((index22 0 d)) ((or j index22)))))))
+
+(with-test (:name :delete-redundant-set-delay)
+  (checked-compile-and-assert
+      ()
+      `(lambda (a)
+         (let ((b 0))
+           (let ((c b))
+             (if (eql a 0)
+                 (setf b c))
+             a)))
+    ((0) 0)
+    ((1) 1)
+    ((2) 2)))

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


hooks/post-receive
-- 
SBCL