Carry dynamic-extent declarations from bytecode into BIR

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)

src/lisp/regression-tests/control01.lisp

@@ -164,3 +164,47 @@
                   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))))))
+
+;;; 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))