master: Resolve a loop in constraints

The branch "master" has been updated in SBCL:
       via  0132c442dd44f376ac29598bc0ce05fcd633bc0f (commit)
      from  4dde13a7c1364ad9a3f39f023a069e689ef2e421 (commit)

- Log -----------------------------------------------------------------
commit 0132c442dd44f376ac29598bc0ce05fcd633bc0f
Author: Stas Boukarev <[email protected]>
Date:   Sat Apr 25 02:45:31 2026 +0300

    Resolve a loop in constraints
    
    Process newly changed blocks always in the same order.
    
    Reported by _death
---
 src/compiler/constraint.lisp           | 25 ++++++++++++++++++-------
 src/compiler/equality-constraints.lisp |  7 ++++---
 tests/constraint.pure.lisp             | 26 +++++++++++++++++++++++++-
 3 files changed, 47 insertions(+), 11 deletions(-)

diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp
index 58ab921fa..fd1b9cc51 100644
--- a/src/compiler/constraint.lisp
+++ b/src/compiler/constraint.lisp
@@ -61,6 +61,10 @@
             (:copier nil))
   (var nil :type lambda-var :read-only t))
 
+#+sb-devel
+(defprinter (vector-length-constraint)
+            (var :prin1 (lambda-var-%source-name var)))
+
 (deftype constraint-y () '(or ctype lvar lambda-var constant
                            vector-length-constraint))
 
@@ -1656,13 +1660,20 @@
           (mapc #'enqueue-block-for-constraints
                 (find-block-type-constraints block nil)))
         ;; Propagate constraints
-        (loop for block = (pop *constraint-blocks*)
-              while block do
-              (unless (or (block-delete-p block)
-                          (eq block (component-tail component)))
-                (when (update-block-in block join-types-p)
-                  (mapc #'enqueue-block-for-constraints
-                        (find-block-type-constraints block nil)))))))
+        (loop while *constraint-blocks*
+              do
+              ;; Process the newly enqueued blocks in the same order
+              (setf *constraint-blocks*
+                    (sort *constraint-blocks* #'< :key #'block-number))
+              (let ((current-end (car (last *constraint-blocks*))))
+                (loop for block = (pop *constraint-blocks*)
+                      do
+                      (unless (or (block-delete-p block)
+                                  (eq block (component-tail component)))
+                        (when (update-block-in block join-types-p)
+                          (mapc #'enqueue-block-for-constraints
+                                (find-block-type-constraints block nil))))
+                      until (eq block current-end))))))
 
     rest-of-blocks))
 
diff --git a/src/compiler/equality-constraints.lisp b/src/compiler/equality-constraints.lisp
index c5eafec88..e2e7d4949 100644
--- a/src/compiler/equality-constraints.lisp
+++ b/src/compiler/equality-constraints.lisp
@@ -376,12 +376,13 @@
                           (= (car existing) i))
                      ;; Maximize the current block value while
                      ;; not exceeding the overall minimal amount.
-                     (let ((overall-min (third existing)))
+                     (let ((overall-min (third existing))
+                           (block-max (max amount (second existing))))
                        (setf (gethash (list in-con in-op not-p) constraints)
                              (list i
                                    (if overall-min
-                                       (min (max amount (second existing)) overall-min)
-                                       (max amount (second existing)))
+                                       (min block-max overall-min)
+                                       block-max)
                                    overall-min))))))))
 
     (when (and all-previous-outs-computed
diff --git a/tests/constraint.pure.lisp b/tests/constraint.pure.lisp
index 3e0605655..1c32942ff 100644
--- a/tests/constraint.pure.lisp
+++ b/tests/constraint.pure.lisp
@@ -2157,7 +2157,6 @@
      n)
    (or integer (complex rational))))
 
-
 (with-test (:name :growing-amounts-in-loops)
   (checked-compile `(lambda (n)
                       (declare (integer n)
@@ -2166,3 +2165,28 @@
                         (loop
                          (let ((new (+ v 1)))
                            (setf v new)))))))
+(with-test (:name :join-equality-constraints-loop)
+  (checked-compile
+   `(lambda (data n d j)
+      (declare (simple-string   data)
+               (optimize (debug 3)))
+      (let ((p773 0))
+        (if n
+            (setq p773 1))
+        (let ((name (make-array p773)))
+          (print name))
+
+        (incf p773)
+        (print (schar data p773))
+        (incf p773)
+        (block nil
+          (tagbody
+           g826
+             (progn
+               (if n
+                   (return-from nil))
+               (setq p773 (+ 1 p773))
+               (aref data p773))
+             (go g826)))
+
+        (do ((index22 0 d)) ((or j index22)))))))

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


hooks/post-receive
-- 
SBCL