master: assignment-convert: Don't try to be so smart with cleanups.

The branch "master" has been updated in SBCL:
       via  6cbab77cdb3f3674f423980eb749dbeab2c406cb (commit)
      from  4727a49892c11ebe996753f4a6e420666ac9c065 (commit)

- Log -----------------------------------------------------------------
commit 6cbab77cdb3f3674f423980eb749dbeab2c406cb
Author: Charles Zhang <[email protected]>
Date:   Fri Aug 7 22:27:30 2026 +0200

    assignment-convert: Don't try to be so smart with cleanups.
    
    Trying to assignment convert more lambdas whose calls have different
    cleanups but not modulo harmfulness only *almost* works. While
    conceptually it's fine, it causes problems during cleanup
    emission. When we merge lambdas, we anchor to a specific
    lexenv/cleanup, not to the messiest common ancestor. Since cleaup
    emission itself has no notion of skipping harmless cleanups, it tries
    to emit cleanups when it shouldn't, breaking things. I think the
    actual correct as in optimal way to do it is to make cleanup emission
    also ignore harmless cleanups as well, but that gets a bit hairy with
    the existing cleanup sharing code in EMIT-CLEANUPS. So give up and go
    back to the slightly dumber cleanup checking code.
    
    No LLM/AI was used to diagnose this issue, so the responsibility for
    this rambling is mine.
    
    Unfortunately, a few of the assignment conversion tests (but not all of
    the new ones) have to be turned off because the block tag introduced
    by labels gets in the way of the optimization. Even for these tests we
    still contify more than before though.
    
    Fixes #lp2162990.
---
 src/compiler/locall.lisp    | 50 +++++++++++++++++++++------------------------
 tests/compiler-ir.pure.lisp | 13 +++++++++---
 tests/compiler.pure.lisp    | 16 +++++++++++++++
 3 files changed, 49 insertions(+), 30 deletions(-)

diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp
index 6f9a317bf..82f6b37c6 100644
--- a/src/compiler/locall.lisp
+++ b/src/compiler/locall.lisp
@@ -1461,17 +1461,10 @@
 
 ;;;; tail local calls and assignments
 
-;;; Return T if the cleanup definitely won't generate any cleanup
-;;; code. Currently we recognize lexical entry points that are only
-;;; used locally (if at all).
-(defun harmless-cleanup-p (cleanup)
-  (case (cleanup-kind cleanup)
-    ((:block :tagbody)
-     (null (entry-exits (cleanup-mess-up cleanup))))
-    (t nil)))
-
-;;; Return T if there are no cleanups between BLOCK1 and
-;;; BLOCK2, or if they definitely won't generate any cleanup code.
+;;; Return T if there are no cleanups between BLOCK1 and BLOCK2, or if
+;;; they definitely won't generate any cleanup code. Currently we
+;;; recognize lexical entry points that are only used locally (if at
+;;; all).
 (defun only-harmless-cleanups (block1 block2)
   (declare (type cblock block1 block2))
   (or (eq block1 block2)
@@ -1479,16 +1472,11 @@
         (do-nested-cleanups (cleanup block1 t)
           (when (eq cleanup cleanup2)
             (return t))
-          (unless (harmless-cleanup-p cleanup)
-            (return nil))))))
-
-;;; Return the innermost cleanup enclosing NODE which would actually
-;;; generate any cleanup code, or NIL if there is none.
-(defun node-real-enclosing-cleanup (node)
-  (declare (type node node))
-  (do-nested-cleanups (cleanup node nil)
-    (unless (harmless-cleanup-p cleanup)
-      (return cleanup))))
+          (case (cleanup-kind cleanup)
+            ((:block :tagbody)
+             (when (entry-exits (cleanup-mess-up cleanup))
+               (return nil)))
+            (t (return nil)))))))
 
 ;;; If a potentially TR local call really is TR, then convert it to
 ;;; jump directly to the called function. We also call
@@ -1672,7 +1660,7 @@
                    (lvar (and (valued-node-p call)
                               (node-lvar call)))
                    (env (node-home-lambda call))
-                   (cleanup (node-real-enclosing-cleanup call)))
+                   (cleanup (node-enclosing-cleanup call)))
                (aver env)
                (cond ((null return-env)
                       (setq return-ctran ctran
@@ -1681,11 +1669,19 @@
                             return-cleanup cleanup)
                       t)
                      (t
-                      ;; We can only convert multiple outside calls when
-                      ;; they are all in the same environment, so we don't
-                      ;; muck up tail sets. This is not a conceptual
-                      ;; restriction though; it may be possible to lift
-                      ;; this if things are reworked.
+                      ;; We can only convert multiple outside calls
+                      ;; when they are all in the same environment, so
+                      ;; we don't muck up tail sets. This is not a
+                      ;; conceptual restriction though; it may be
+                      ;; possible to lift this if things are
+                      ;; reworked. The cleanup checking here is also
+                      ;; overly conservative. A better approach would
+                      ;; be to check for harmful cleanups with respect
+                      ;; to the messiest common ancestor, though care
+                      ;; would need to be taken with cleanup emission
+                      ;; as merging lambdas will anchor to a specific
+                      ;; predecessor's lexenv/cleanup, not to the
+                      ;; ancestor's.
                       (and (or (eq (node-derived-type call) *empty-type*)
                                (and (eq return-ctran ctran)
                                     (eq return-lvar lvar)))
diff --git a/tests/compiler-ir.pure.lisp b/tests/compiler-ir.pure.lisp
index 25fbd966f..e19da0a83 100644
--- a/tests/compiler-ir.pure.lisp
+++ b/tests/compiler-ir.pure.lisp
@@ -308,7 +308,12 @@
 ;;; cannot. In this case, FM, F, G and H all have the same
 ;;; continuation.
 #+sb-devel
-(with-test (:name (:assignment-convert :fluet-weeks-5.1))
+(with-test (:name (:assignment-convert :fluet-weeks-5.1)
+            ;; Unfortunately, this test and the next few almost work
+            ;; but are defeated by the block tags inserted by LABELS
+            ;; since we don't have smart enough cleanup logic in the
+            ;; assignment conversion code.
+            :fails-on :sbcl)
   (let ((converted '()))
     (let ((fun (inspect-ir
                 '(lambda (b x y flag)
@@ -342,7 +347,8 @@
 ;;; A modified version of the above test, but with an outside call for
 ;;; H.
 #+sb-devel
-(with-test (:name (:assignment-convert :fluet-weeks-5.1-modified))
+(with-test (:name (:assignment-convert :fluet-weeks-5.1-modified)
+            :fails-on :sbcl)
   (let ((converted '()))
     (let ((fun (inspect-ir
                 '(lambda (b x y flag)
@@ -382,7 +388,8 @@
 ;;; analysis. In this case, F, G1, G2 and H all have the same
 ;;; continuation.
 #+sb-devel
-(with-test (:name (:assignment-convert :fluet-weeks-5.2))
+(with-test (:name (:assignment-convert :fluet-weeks-5.2)
+            :fails-on :sbcl)
   (let ((converted '()))
     (let ((fun (inspect-ir
                 '(lambda (b x y flag)
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index e0f277d71..7a3360c33 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -6363,3 +6363,19 @@
                                     (recurse (the fixnum (1- x)) fn))))
                        (recurse x fn)))
                    :allow-notes nil))
+
+(with-test (:name (:assignment-convert :lp2162990))
+  (checked-compile-and-assert ()
+    `(lambda (a)
+       (block done
+         (let ((done (lambda (&rest values) (return-from done (values-list values))))
+               (l (lambda ())))
+           (flet ((c (f)
+                    (funcall f)))
+             (declare (inline c))
+             (if a
+                 (c l)
+                 (c l)))
+           (funcall done nil))))
+    ((t) nil)
+    ((nil) nil)))

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


hooks/post-receive
-- 
SBCL