From 6cbab77cdb3f3674f423980eb749dbeab2c406cb Mon Sep 17 00:00:00 2001 From: Charles Zhang Date: Fri, 7 Aug 2026 22:27:30 +0200 Subject: [PATCH] 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)))