common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Auto-stack-allocate self and mutually-referential functions as well.

Browse source 
Teach environment analysis how to detect when functions which have
references in other functions (potentially itself) are automatically
stack allocatable. This is done by marrying the closure environment
analysis with some of the existing escape analysis utilities, and by
combining those analysis with a step to annotate the correct derived
dynamic extent lifetime, which further required some IR1 flow-graph
hacking utilities to revoke tail call semantics when
necessary. Additionally, the escape analysis performed for functions
is also now somewhat unified with how values are handled, so such
functions are now also stack allocated when all their references
deliver values to e.g. dx-safe functions. In fact, dx-safe as an
ir1-info annotation should probably just be removed in favor of
user-defined dx declarations.

We have thus deleted the arbitrary restriction on auto-dxification of
functions that made us just give up the moment a reference to a
potentially dxable function was in a different environment.

This fixes the existing expected test failures we had regarding being
able to auto stack allocate self-referential functions. We also add a
bunch of new tests to exercise stack-allocatability and correctness of
mutually referential functions which close over each other as well.

We can now remove some explicit dynamic extent declarations in the
system that are now automatically inferred by the compiler, since it
is safer that way in case the functions are changed. It may work to
remove more declarations but these are clearly the instances that the
compiler now handles.

Some test cases provided by Gemini. Everything else written by me.
This commit is contained in:
Charles Zhang 2026-08-27 18:28:25 +02:00
parent ee1e63f0fb
commit 9685c98e78
9 changed files with 293 additions and 55 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
src/code/target-load.lisp
View file

@ -132,6 +132,7 @@
(invalid-fasl-fhsss condition)))))
(defun call-with-load-bindings (function stream arg pathname-designator)
(declare (dynamic-extent function))
(let* (;; FIXME: we should probably document the circumstances
;; where *LOAD-PATHNAME* and *LOAD-TRUENAME* aren't
;; pathnames during LOAD. ANSI makes no exceptions here.
@ -260,7 +261,6 @@
;; of using the compiler to perform interpretation.
(sb-c:with-compiler-error-resignalling
(load-as-source stream :verbose verbose :print print))))))
(declare (dynamic-extent #'load-stream-1))
;; Case 1: stream.
(when (streamp filespec)

1
src/code/type.lisp
View file

@ -5770,6 +5770,7 @@ expansion happened."
;;; Standard list representation of sets. Use CL:* for the universe.
(defun list-abstract-type-function (type over &key under (overapproximate t))
(declare (dynamic-extent over under))
#-sb-xc-host (declare (inline generic-abstract-type-function))
(generic-abstract-type-function
type overapproximate

1
src/compiler/array-tran.lisp
View file

@ -2009,7 +2009,6 @@
(t
(list (length dims))))))
(t '()))))
(declare (dynamic-extent #'over #'under))
(multiple-value-bind (not-p ranks)
(list-abstract-type-function ctype #'over :under #'under)
(cond ((eql ranks '*)

193
src/compiler/envanal.lisp
View file

@ -343,19 +343,27 @@
(when (and (not (lvar-dynamic-extent arg))
(ref-p use)
(lambda-p (ref-leaf use))
(not (leaf-dynamic-extent (functional-entry-fun (ref-leaf use))))
;; TODO: we need to do this because we don't
;; have enough smarts yet.
(eq (node-home-lambda (xep-enclose (ref-leaf use)))
(node-home-lambda node)))
(not (leaf-dynamic-extent (functional-entry-fun (ref-leaf use)))))
(unless dynamic-extent
(setq dynamic-extent (insert-dynamic-extent node)))
(setf (lvar-dynamic-extent arg) dynamic-extent)
(push arg (dynamic-extent-values dynamic-extent))))))))))
;;; Check if all references to LEAF (other than USE) are bounded by
;;; dynamic extents or safely discarded and therefore do not escape.
(defun leaf-refs-not-escape-elsewhere-p (leaf use &optional visited)
(dolist (ref (leaf-refs leaf) t)
(unless (eq use ref)
(multiple-value-bind (dest p-lvar)
(principal-lvar-end (node-lvar ref))
(declare (ignore dest))
(unless (or (lvar-dynamic-extent p-lvar)
(ref-good-for-dx-p ref visited))
(return nil))))))
;;; Check that REF delivers a value to a combination which is DX safe
;;; or whose result is that value and ends up being discarded.
(defun ref-good-for-dx-p (ref)
(defun ref-good-for-dx-p (ref &optional visited)
(let* ((lvar (ref-lvar ref))
(dest (when lvar (lvar-dest lvar))))
(and (combination-p dest)
@ -367,14 +375,36 @@
(awhen (fun-info-result-arg it)
(eql lvar (nth it (combination-args dest))))))))
(:local
(loop for arg in (combination-args dest)
for var in (lambda-vars (combination-lambda dest))
do (when (eq arg lvar)
(return
(dolist (ref (lambda-var-refs var) t)
(unless (ref-good-for-dx-p ref)
(return nil)))))
finally (sb-impl::unreachable)))))))
(or (memq ref visited)
(progn
(push ref visited)
(loop for arg in (combination-args dest)
for var in (lambda-vars (combination-lambda dest))
do (when (eq arg lvar)
(return (leaf-refs-not-escape-elsewhere-p var nil visited)))
finally (sb-impl::unreachable)))))))))
;;; Find which environments escape because they are closed over by
;;; other external entry points which themselves escape. An entry
;;; point is considered to escape if it is closed over by a non
;;; dynamic extent lambda whose references escape. If an environment's
;;; lambda closes over itself, we do not take that into account here,
;;; to make it easier for others to check whether the lambda escapes
;;; even when excluding one of its references.
(defun analyze-escaping-closure-environments (component)
(declare (type component component))
(dolist (xep (component-lambdas component))
(let ((closure (environment-closure (lambda-environment xep))))
(when (and (functional-kind-eq xep external)
(not (leaf-dynamic-extent (functional-entry-fun xep)))
closure
(not (leaf-refs-not-escape-elsewhere-p xep nil)))
(dolist (thing closure)
(when (and (lambda-p thing)
(neq thing xep))
(setf (environment-escapes-elsewhere-p (lambda-environment thing))
t))))))
(values))
;;; Recursively look for otherwise inaccessible potentially
;;; stack-allocatable parts in the uses of LVAR. If there is one,
@ -410,7 +440,6 @@
(find-stack-allocatable-parts arg dynamic-extent t)))))))
(ref
(let ((leaf (ref-leaf use)))
(typecase leaf
(lambda-var
;; LET lambda var with no SETS.
@ -418,38 +447,25 @@
(not (lambda-var-sets leaf))
(lexenv-contains-lambda (lambda-var-home leaf)
(node-lexenv dynamic-extent))
;; Check the other refs are good.
(dolist (ref (leaf-refs leaf) t)
(unless (eq use ref)
(when (not (ref-good-for-dx-p ref))
(return nil)))))
(leaf-refs-not-escape-elsewhere-p leaf use))
(when (find-stack-allocatable-parts (let-var-initial-value leaf)
dynamic-extent)
(setq found-subpart-p t))))
(clambda
(when (functional-kind-eq leaf external)
(let* ((fun (functional-entry-fun leaf))
(enclose (functional-enclose fun)))
(enclose (functional-enclose fun))
(environment (get-lambda-environment leaf)))
(when (and (or (not check-nesting)
;; Allow (let ((x (lambda () v))) (let ((d x)) (dynamic-extent d)))
;; but not (let ((x (lambda () v))) (let ((d (list x))) (dynamic-extent d)))
(lexenv-contains-lambda leaf (node-lexenv dynamic-extent)))
(environment-closure (get-lambda-environment leaf))
;; To make sure the allocation is in the same
;; stack frame as the dynamic extent.
(eq (node-home-lambda enclose)
(node-home-lambda dynamic-extent))
;; Check the other refs are good. At this
;; point, DXIFY-DOWNWARD-FUNARGS and
;; PROPAGATE-REF-DX should have marked
;; the p-lvar-ends of all good refs.
(dolist (ref (leaf-refs leaf) t)
(unless (eq use ref)
(multiple-value-bind (dest lvar)
(principal-lvar-end (node-lvar ref))
(declare (ignore dest))
(unless (lvar-dynamic-extent lvar)
(return nil))))))
(environment-closure environment)
;; At this point, DXIFY-DOWNWARD-FUNARGS
;; and PROPAGATE-REF-DX should have
;; marked the p-lvar-ends of FUN's refs.
(leaf-refs-not-escape-elsewhere-p leaf use)
(not (environment-escapes-elsewhere-p environment)))
(unless (enclose-dynamic-extent enclose)
(pushnew dynamic-extent
(enclose-derived-dynamic-extents enclose)))
@ -459,9 +475,104 @@
(setf (lvar-dynamic-extent lvar) dynamic-extent)
t)))
;;; Return the return node of FUN, creating it if it no longer exists.
(defun ensure-lambda-return (fun)
(declare (type clambda fun))
(or (lambda-return fun)
(with-ir1-environment-from-node (lambda-bind fun)
(let* ((result-ctran (make-ctran))
(result-lvar (make-lvar))
(return (make-return result-lvar fun))
(block (ctran-starts-block result-ctran)))
(link-node-to-previous-ctran return result-ctran)
(setf (block-last block) return)
(setf (lvar-dest result-lvar) return)
(setf (lambda-return fun) return)
(link-blocks block (component-tail (lambda-component fun)))
return))))
;;; Revoke the tail-call status of CALL to FUN. This unlinks the call
;;; from FUN's bind node and routes it to a proper return node,
;;; creating it if necessary.
(defun revoke-tail-call (call fun)
(declare (type combination call)
(type clambda fun))
(aver (node-tail-p call))
(setf (node-tail-p call) nil)
(unlink-blocks (node-block call)
(node-block (lambda-bind fun)))
(let ((return (ensure-lambda-return (node-home-lambda call))))
(link-blocks (node-block call) (node-block return))
(add-lvar-use call (return-result return))))
;;; For each local call to FUN which shares a home lambda with
;;; ENCLOSE, insert a DYNAMIC-EXTENT node to bound the lifetime of
;;; ENCLOSE.
;;;
;;; If the call is a tail call, we have to revoke its tail-call
;;; status, since the dynamic extent cleanup action makes the call
;;; non-tail.
(defun insert-local-call-dynamic-extents (fun enclose)
(let ((enclose-home (node-home-lambda enclose)))
(dolist (ref (leaf-refs fun))
(let* ((lvar (node-lvar ref))
(dest (and lvar (lvar-dest lvar))))
(when (and (eq (node-home-lambda ref) enclose-home)
(combination-p dest)
(eq (combination-kind dest) :local)
(eq lvar (combination-fun dest)))
(pushnew (insert-dynamic-extent dest)
(enclose-derived-dynamic-extents enclose))
(when (node-tail-p dest)
(revoke-tail-call dest fun)))))))
;;; For each lambda in COMPONENT which has been determined to be
;;; eligible for stack allocation and does not have an explicit
;;; dynamic extent lifetime, annotate its derived lifetime. This is
;;; done by inserting appropriate dynamic extents around local calls
;;; in lambda's allocation environment and inheriting any lifetime
;;; annotations in the same environment from functions with XEPs which
;;; close over the lambda. Because a function might be invoked
;;; transitively by another local function that closes over it, we
;;; scan the component's lambdas and check if the lambda's local calls
;;; are in the same allocation environment of itself or any of the
;;; functions it closes over when annotating derived lifetimes around
;;; local calls.
(defun annotate-lambda-derived-extents (component)
(dolist (fun (component-lambdas component))
(let ((enclose (functional-enclose fun)))
(when enclose
(when (leaf-dynamic-extent fun)
(unless (enclose-dynamic-extent enclose)
(insert-local-call-dynamic-extents fun enclose)))
(dolist (thing (environment-closure (lambda-environment fun)))
(when (and (lambda-p thing)
(leaf-dynamic-extent (functional-entry-fun thing)))
(let ((captured-enclose (xep-enclose thing)))
(unless (enclose-dynamic-extent captured-enclose)
(insert-local-call-dynamic-extents fun captured-enclose))))))))
(dolist (xep (component-lambdas component))
(when (and (functional-kind-eq xep external)
(leaf-dynamic-extent (functional-entry-fun xep)))
(let* ((enclose (xep-enclose xep))
(dynamic-extent (enclose-dynamic-extent enclose))
(enclose-home (node-home-lambda enclose)))
(dolist (thing (environment-closure (lambda-environment xep)))
(when (and (lambda-p thing)
(leaf-dynamic-extent (functional-entry-fun thing)))
(let ((captured-enclose (xep-enclose thing)))
(when (and (not (enclose-dynamic-extent captured-enclose))
(eq (node-home-lambda captured-enclose) enclose-home))
(cond (dynamic-extent
(pushnew dynamic-extent (enclose-derived-dynamic-extents captured-enclose)))
(t
(setf (enclose-derived-dynamic-extents captured-enclose)
(union (enclose-derived-dynamic-extents enclose)
(enclose-derived-dynamic-extents captured-enclose)))))))))))))
;;; Determine which values and closures in COMPONENT may be stack
;;; allocated. We do so by starting a recursive walk from the values
;;; and closures declared dynamic extent explicitly and transitively
;;; and closures explicitly declared dynamic extent and transitively
;;; marking the otherwise-inaccessible parts of these values as
;;; potentially stack allocatable. If a dynamic extent is in fact
;;; associated with a stack allocatable thing, note that fact by
@ -480,6 +591,9 @@
(memq (basic-combination-kind node)
'(:full :unknown-keys :known)))
(dxify-downward-funargs node))))
(analyze-escaping-closure-environments component)
(dolist (lambda (component-lambdas component))
(dolist (dynamic-extent (lambda-dynamic-extents lambda))
(let ((environment (node-environment dynamic-extent)))
@ -491,6 +605,9 @@
(return nil)))
(find-stack-allocatable-parts lvar dynamic-extent))
(setf (dynamic-extent-info dynamic-extent) (make-lvar)))))))
(annotate-lambda-derived-extents component)
(dolist (xep (component-lambdas component))
(when (and (functional-kind-eq xep external)
(leaf-dynamic-extent (functional-entry-fun xep))

1
src/compiler/ir2opt.lisp
View file

@ -265,7 +265,6 @@
(return-from mark-2block))
(setf (gethash 2block live-2blocks) t)
(map nil #'mark-2block (cdr (gethash 2block *2block-info*)))))
(declare (dynamic-extent #'mark-2block))
(mark-2block (block-info (component-head component))))
(flet ((delete-2block (2block)

6
src/compiler/node.lisp
View file

@ -716,6 +716,10 @@
;; a list of NLX-INFO structures describing all the non-local exits
;; into this environment
(nlx-info nil :type list)
;; whether this environment has a closure and the function that
;; allocates this environment escapes through any other escaping
;; environments.
(escapes-elsewhere-p nil :type boolean)
;; some kind of info used by the back end
(info nil :type (or ir2-environment null)))
(defprinter (environment :identity t)
@ -1251,7 +1255,7 @@
;; the TAIL-SET that this LAMBDA is in. This is null during creation
;; and in let lambdas.
(tail-set nil :type (or tail-set null))
;; the structure which represents the phsical environment that this
;; the structure which represents the environment that this
;; function's variables are allocated in. This is filled in by
;; environment analysis. In a LET, this is EQ to our home's
;; environment.

17
src/compiler/seqtran.lisp
View file

@ -2756,14 +2756,15 @@
,@(and key
`((key (%coerce-callable-to-fun key)))))
(declare (index count))
(flet ((counter (x) (when (funcall ,(if test 'test ''eql)
item
,(if key
`(funcall key x)
`x))
(incf count))))
(declare (dynamic-extent #'counter))
(map nil #'counter sequence))
(map nil
(lambda (x)
(when (funcall ,(if test 'test ''eql)
item
,(if key
`(funcall key x)
`x))
(incf count)))
sequence)
count))
(defoptimizer (sb-impl::length-remove-duplicates derive-type) ((sequence &key &allow-other-keys))

1
src/pcl/sequence.lisp
View file

@ -1243,7 +1243,6 @@ have dynamic extent."
(if (funcall predicate key2 key1)
(prog1 elt2 (step2) (pop/key2))
(prog1 elt1 (step1) (pop/key1)))))
(declare (dynamic-extent #'pop-one/no-key #'pop-one/key))
;; Populate ENDP{1,2}, ELT{1,2} and maybe KEY{1,2}.
(cond (key-function (pop/key1) (pop/key2))
(t (pop/no-key1) (pop/no-key2)))

126
tests/dynamic-extent.pure.lisp
View file

@ -2517,8 +2517,7 @@
(with-test (:name :auto-dx-recursive-ref.correct)
(assert (equal (auto-dx-recursive-ref '(1 2 3 4)) nil)))
(with-test (:name :auto-dx-recursive-ref.stack-allocates
:fails-on :sbcl)
(with-test (:name :auto-dx-recursive-ref.stack-allocates)
(assert-no-consing (auto-dx-recursive-ref '(1 2 3 4))))
(defun auto-dx-recursive-ref-2 (seq)
@ -2532,8 +2531,7 @@
(with-test (:name :auto-dx-recursive-ref-2.correct)
(assert (equal (auto-dx-recursive-ref-2 '(1 2 3 4)) nil)))
(with-test (:name :auto-dx-recursive-ref-2.stack-allocates
:fails-on :sbcl)
(with-test (:name :auto-dx-recursive-ref-2.stack-allocates)
(assert-no-consing (auto-dx-recursive-ref-2 '(1 2 3 4))))
;;; Even though #'f's direct references do not escape, it is closed
@ -2691,3 +2689,123 @@
(assert (sb-ext:stack-allocated-p elt))
2))
((0 t) 2)))
(defun auto-dx-mutually-recursive-map (seq1 seq2)
(let ((count 0))
(labels ((ping (x)
(incf count)
(when (listp x)
(map nil #'pong x)))
(pong (x)
(incf count)
(when (listp x)
(map nil #'ping x))))
(map nil #'ping seq1)
(map nil #'pong seq2)
count)))
(with-test (:name :auto-dx-mutually-recursive.correct)
(assert (= (auto-dx-mutually-recursive-map '((1) (2 3)) '((4 5) (6)))
10)))
(with-test (:name :auto-dx-mutually-recursive.stack-allocates)
(assert-no-consing
(auto-dx-mutually-recursive-map '((1) (2 3)) '((4 5) (6)))))
(defun auto-dx-transitive-carriers (seq)
(let ((count 0))
(labels ((f (x)
(incf count x))
(g (x)
(map nil #'f x))
(h (x)
(g x)
(g x)))
(h seq)
(h seq)
count)))
(with-test (:name :auto-dx-transitive-carriers.correct)
(assert (= (auto-dx-transitive-carriers '(-1 2 -3 4)) 8)))
(with-test (:name :auto-dx-transitive-carriers.stack-allocates)
(assert-no-consing (auto-dx-transitive-carriers '(-1 2 -3 4))))
(defun auto-dx-disjoint-sequential (seq)
(let ((z 0))
(labels ((y (a)
(incf z a))
(g ()
(map nil #'y seq)))
(map nil #'y seq)
(g)
(let ((x (cons 1 2)))
(declare (dynamic-extent x))
(opaque-identity x))
(g)
z)))
(with-test (:name :auto-dx-disjoint-sequential.correct)
(assert (= (auto-dx-disjoint-sequential '(1 2 3)) 18)))
(with-test (:name :auto-dx-disjoint-sequential.stack-allocates)
(assert-no-consing (auto-dx-disjoint-sequential '(1 2 3))))
(defun auto-dx-directed-escape-precision (seq)
(let ((state 0))
(labels ((f (x)
(incf state)
(when (listp x)
(map nil #'g x)))
(g (x)
(incf state)
(when (listp x)
(map nil #'f x)))
(h ()
state))
(map nil #'f seq)
#'h)))
;;; FIXME: We need to find a way to check that #'g and #'f do get
;;; stack-allocated.
(with-test (:name :auto-dx-directed-escape-precision.correct)
(let ((h-fun (auto-dx-directed-escape-precision '((1) (2)))))
(assert (functionp h-fun))
(assert (= (funcall h-fun) 4))))
(defun auto-dx-escaping-carrier (seq)
(let ((z (car seq)))
(labels ((f (x)
(when (member x seq)
(return-from f z))
(map nil #'f (cdr seq)))
(g ()
(map nil #'f (cdr seq))))
(values (f seq) #'g))))
(with-test (:name :auto-dx-escaping-carrier.correct)
(multiple-value-bind (val g-fun)
(auto-dx-escaping-carrier '(1 2 3 4))
(assert (eq val nil))
(assert (eq (funcall g-fun) nil))))
(with-test (:name :auto-dx-local-call-in-lambda.correct)
(checked-compile-and-assert
()
'(lambda (flag forms)
(let ((count 0))
(labels ((z (c)
(declare (ignore c))
(incf count)
nil)
(trap (form)
(handler-bind ((condition #'z))
(when (eq form :boom)
(warn "boo")))))
(if flag
(map nil (lambda (form)
(trap form))
forms)
(trap '(print)))
count)))
((t '(:boom :boom)) 2 :allow-conditions 'warning)))