From ed945e716c537f3e76581f05e10e73c73971ae44 Mon Sep 17 00:00:00 2001 From: dg1sbg Date: Sun, 2 Aug 2026 21:00:21 +0200 Subject: [PATCH 1/2] Add a regression test for dynamic-extent closure escape Compiles an escaping closure with the native compiler 30 times and calls each result. Before the companion Cleavir fix the closure was stack allocated on roughly half the compiles -- the reader iteration order that decides it comes from an EQ hash table -- so one compile is not a reliable probe, while 30 makes a miss effectively impossible. This needs the DETERMINE-CLOSURE-EXTENT fix in Cleavir. repos.sexp tracks Cleavir's main unpinned, so the test goes green once that lands upstream. --- src/lisp/regression-tests/control01.lisp | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/src/lisp/regression-tests/control01.lisp b/src/lisp/regression-tests/control01.lisp index 7827e4263b..95c06128b9 100644 --- a/src/lisp/regression-tests/control01.lisp +++ b/src/lisp/regression-tests/control01.lisp @@ -164,3 +164,20 @@ item)) result)) (4)) + +;;; DETERMINE-CLOSURE-EXTENT marked an ENCLOSE :dynamic as soon as one reader +;;; turned out to be a dx-call, before the remaining readers were checked; a +;;; later escaping reader then bailed out without undoing it, so a closure that +;;; is returned got stack allocated. Cleavir sets are EQ hash tables, so which +;;; reader came first -- and hence whether the bug fired -- varied per compile. +;;; Repeat enough times that the old behaviour is caught with certainty. +(test-true dynamic-extent-escaping-closure + (let ((src '(lambda (x) + (let ((g (lambda (y) (+ x y)))) + (mapcar g '(1 2 3)) + g)))) + (every (lambda (f) + (eql 15 (handler-case (funcall (funcall f 10) 5) + (error () nil)))) + (let ((cmp:*compile-native* t)) + (loop repeat 30 collect (compile nil src)))))) From 15922f205e9433bb6107f88969a9b8d9d9b278c0 Mon Sep 17 00:00:00 2001 From: dg1sbg Date: Sun, 2 Aug 2026 21:51:05 +0200 Subject: [PATCH 2/2] Carry dynamic-extent declarations from bytecode into BIR Clasp does not use Cleavir's CST-to-AST front end -- CLEAVIR-CST-TO-AST, CLEAVIR-AST and CLEAVIR-AST-TO-BIR are not present at runtime at all -- so the declaration reaches BIR by way of the bytecode instead. It is already carried there: CMPLTV encodes a dynamic-extent bit into the debug-var flags byte, and START-ANNOTATION already reads BYTECODE-DEBUG-VAR/DECLS to recover the declared type. It was simply not passed on. Read CL:DYNAMIC-EXTENT out of that same list and set it on the BIR:LETI binding the variable. Cleavir's closure extent analysis then treats it as permission to attempt a stack allocation, which it still has to prove. Measured on a closure passed to a capturing FLET called from three sites, 100000 calls: 544 bytes per call before, 504 after, results unchanged. The 40 bytes are the closure itself moving to the stack. It only fires when the local function captures something; a non-capturing FLET is a constant function, so the callee is a constant reference with no BIR function behind it to walk into. Also adds two regression tests: one pins the safety property, that a declaration which is wrong forfeits the optimisation rather than handing back a closure whose frame is gone, and one pins that a correct declaration does not change the value computed. --- src/lisp/kernel/cleavir/compile-bytecode.lisp | 18 ++++++++----- src/lisp/regression-tests/control01.lisp | 27 +++++++++++++++++++ 2 files changed, 39 insertions(+), 6 deletions(-) diff --git a/src/lisp/kernel/cleavir/compile-bytecode.lisp b/src/lisp/kernel/cleavir/compile-bytecode.lisp index bf83127a41..e6f8b20806 100644 --- a/src/lisp/kernel/cleavir/compile-bytecode.lisp +++ b/src/lisp/kernel/cleavir/compile-bytecode.lisp @@ -1404,6 +1404,10 @@ for index = (core:bytecode-debug-var/frame-index bdv) for ctype = (declared-variable-ctype (core:bytecode-debug-var/decls bdv) (consp name)) + ;; Permission to stack allocate; the escape analysis still has to agree. + for dxp = (and (member 'cl:dynamic-extent + (core:bytecode-debug-var/decls bdv)) + t) for (datum) = (aref (locals context) index) ;; We make all variables IGNORABLE because the bytecode compiler ;; has already warned about any syntactically unused variables @@ -1415,9 +1419,9 @@ :ignore 'cl:ignorable :name name) do (etypecase datum (bir:linear-datum - (bind-variable variable datum ctype inserter context)) + (bind-variable variable datum ctype inserter context dxp)) ((cons bir:linear-datum) ; cell - (bind-variable variable (car datum) ctype inserter context))) + (bind-variable variable (car datum) ctype inserter context dxp))) (setf (aref (locals context) index) (cons variable cellp)) collect (cons name ctype) into typemap @@ -1443,14 +1447,16 @@ return (env:parse-type-specifier (second decl) env sys) finally (return (ctype:top sys)))) -(defun bind-variable (variable value ctype inserter context) +(defun bind-variable (variable value ctype inserter context + &optional dynamic-extent) (let ((typed (compile-type-decl :setq ctype value inserter context))) - (%bind-variable variable typed inserter))) + (%bind-variable variable typed inserter dynamic-extent))) -(defun %bind-variable (variable value inserter) +(defun %bind-variable (variable value inserter &optional dynamic-extent) (build:insert inserter 'bir:leti :inputs (list value) - :outputs (list variable))) + :outputs (list variable) + :dynamic-extent dynamic-extent)) (defmethod end-annotation ((annot core:bytecode-debug-vars) inserter context) diff --git a/src/lisp/regression-tests/control01.lisp b/src/lisp/regression-tests/control01.lisp index 95c06128b9..ac3f91605c 100644 --- a/src/lisp/regression-tests/control01.lisp +++ b/src/lisp/regression-tests/control01.lisp @@ -181,3 +181,30 @@ (error () nil)))) (let ((cmp:*compile-native* t)) (loop repeat 30 collect (compile nil src)))))) + +;;; A DYNAMIC-EXTENT declaration is permission to stack allocate, never proof. +;;; Here it is simply wrong -- the local function hands the closure back out -- +;;; so the compiler has to forfeit the optimisation. Believing the declaration +;;; would return a closure whose frame is already gone. +(test-true dynamic-extent-wrong-declaration-is-safe + (let ((f (let ((cmp:*compile-native* t)) + (compile nil '(lambda (x k) + (flet ((leak-it (g) (list g k))) + (let ((c (lambda (y) (+ x y)))) + (declare (dynamic-extent c)) + (values (leak-it c) (leak-it c) + (leak-it c))))))))) + (eql 15 (handler-case (funcall (first (funcall f 10 1)) 5) + (error () nil))))) + +;;; The same shape with a declaration that IS correct must keep its meaning. +(test dynamic-extent-declared-closure-value + (let ((f (let ((cmp:*compile-native* t)) + (compile nil '(lambda (x k) + (flet ((use-it (g) (length (mapcar g (list k 2 3))))) + (let ((c (lambda (y) (+ x y)))) + (declare (dynamic-extent c)) + (values (use-it c) (use-it c) + (use-it c))))))))) + (funcall f 10 1)) + (3 3 3))