X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fphysenvanal.lisp;h=a2adbcc6bf33914d964cf3f43bc5190f7c86239c;hb=b56c1a4dc22aa0ac827343667584aa6090b15f02;hp=540b29caa0abd5312b39a8b4c9edbd9d0b427ae9;hpb=d604a358d8e5eb5587989e0a4f1d31dbe6ac5ffe;p=sbcl.git diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp index 540b29c..a2adbcc 100644 --- a/src/compiler/physenvanal.lisp +++ b/src/compiler/physenvanal.lisp @@ -41,6 +41,7 @@ (recheck-dynamic-extent-lvars component) (find-cleanup-points component) (tail-annotate component) + (analyze-indirect-lambda-vars component) (dolist (fun (component-lambdas component)) (when (null (leaf-refs fun)) @@ -88,18 +89,13 @@ res)))) ;;; If FUN has no physical environment, assign one, otherwise clean up -;;; the old physical environment, removing/flagging variables that -;;; have no sets or refs. If a var has no references, we remove it -;;; from the closure. We always clear the INDIRECT flag. This is -;;; necessary because pre-analysis is done before optimization. +;;; the old physical environment and the INDIRECT flag on LAMBDA-VARs. +;;; This is necessary because pre-analysis is done before +;;; optimization. (defun reinit-lambda-physenv (fun) (let ((old (lambda-physenv (lambda-home fun)))) (cond (old - (setf (physenv-closure old) - (delete-if (lambda (x) - (and (lambda-var-p x) - (null (leaf-refs x)))) - (physenv-closure old))) + (setf (physenv-closure old) nil) (flet ((clear (fun) (dolist (var (lambda-vars fun)) (setf (lambda-var-indirect var) nil)))) @@ -212,6 +208,43 @@ (flood (get-node-physenv ref)))))))))) (flood ref-physenv))) (values)) + +;;; Find LAMBDA-VARs that are marked as needing to support indirect +;;; access (SET at some point after initial creation) that are present +;;; in CLAMBDAs not marked as being DYNAMIC-EXTENT (meaning that the +;;; value-cell involved must be able to survive past the extent of the +;;; allocating frame), and mark them (the LAMBDA-VARs) as needing +;;; explicit value-cells. Because they are already closed-over, the +;;; LAMBDA-VARs already appear in the closures of all of the CLAMBDAs +;;; that need checking. +(defun analyze-indirect-lambda-vars (component) + (dolist (fun (component-lambdas component)) + (let ((entry-fun (functional-entry-fun fun))) + ;; We also check the ENTRY-FUN, as XEPs for LABELS or FLET + ;; functions aren't set to be DX even if their underlying + ;; CLAMBDAs are, and if we ever get LET-bound anonymous function + ;; DX working, it would mark the XEP as being DX but not the + ;; "real" CLAMBDA. This works because a FUNCTIONAL-ENTRY-FUN is + ;; either NULL, a self-pointer (for :TOPLEVEL functions), a + ;; pointer from an XEP to its underlying function (for :EXTERNAL + ;; functions), or a pointer from an underlying function to its + ;; XEP (for non-:TOPLEVEL functions with XEPs). + (unless (or (leaf-dynamic-extent fun) + ;; Functions without XEPs can be treated as if they + ;; are DYNAMIC-EXTENT, even without being so + ;; declared, as any escaping closure which /isn't/ + ;; DYNAMIC-EXTENT but calls one of these functions + ;; will also close over the required variables, thus + ;; forcing the allocation of value cells. Since the + ;; XEP is stored in the ENTRY-FUN slot, we can pick + ;; off the non-XEP case here. + (not entry-fun) + (leaf-dynamic-extent entry-fun)) + (let ((closure (physenv-closure (lambda-physenv fun)))) + (dolist (var closure) + (when (and (lambda-var-p var) + (lambda-var-indirect var)) + (setf (lambda-var-explicit-value-cell var) t)))))))) ;;;; non-local exit @@ -256,7 +289,7 @@ (setf (nlx-info-target info) new-block) (setf (nlx-info-safe-p info) (exit-should-check-tag-p exit)) (push info (physenv-nlx-info env)) - (push info (cleanup-nlx-info cleanup)) + (push info (cleanup-info cleanup)) (when (member (cleanup-kind cleanup) '(:catch :unwind-protect)) (setf (node-lexenv (block-last new-block)) (node-lexenv entry)))) @@ -333,43 +366,49 @@ (declare (type component component)) (dolist (lambda (component-lambdas component)) (loop for entry in (lambda-entries lambda) - for cleanup = (entry-cleanup entry) - do (when (eq (cleanup-kind cleanup) :dynamic-extent) - (collect ((real-dx-lvars)) - (loop for what in (cleanup-info cleanup) - do (etypecase what - (lvar - (let* ((lvar what) - (use (lvar-uses lvar))) - (if (and (combination-p use) - (eq (basic-combination-kind use) :known) - (awhen (fun-info-stack-allocate-result - (basic-combination-fun-info use)) - (funcall it use))) - (real-dx-lvars lvar) - (setf (lvar-dynamic-extent lvar) nil)))) - (node ; DX closure - (let* ((call what) - (arg (first (basic-combination-args call))) - (funs (lvar-value arg)) - (dx nil)) - (dolist (fun funs) - (binding* ((() (leaf-dynamic-extent fun) - :exit-if-null) - (xep (functional-entry-fun fun) - :exit-if-null) - (closure (physenv-closure - (get-lambda-physenv xep)))) - (cond (closure - (setq dx t)) - (t - (setf (leaf-dynamic-extent fun) nil))))) - (when dx - (setf (lvar-dynamic-extent arg) cleanup) - (real-dx-lvars arg)))))) - (setf (cleanup-info cleanup) (real-dx-lvars)) + for cleanup = (entry-cleanup entry) + do (when (eq (cleanup-kind cleanup) :dynamic-extent) + (collect ((real-dx-lvars)) + (loop for what in (cleanup-info cleanup) + do (etypecase what + (cons + (let ((dx (car what)) + (lvar (cdr what))) + (cond ((lvar-good-for-dx-p lvar dx component) + ;; Since the above check does deep + ;; checks. we need to deal with the deep + ;; results in here as well. + (dolist (cell (handle-nested-dynamic-extent-lvars + dx lvar component)) + (let ((real (principal-lvar (cdr cell)))) + (setf (lvar-dynamic-extent real) cleanup) + (real-dx-lvars real)))) + (t + (note-no-stack-allocation lvar) + (setf (lvar-dynamic-extent lvar) nil))))) + (node ; DX closure + (let* ((call what) + (arg (first (basic-combination-args call))) + (funs (lvar-value arg)) + (dx nil)) + (dolist (fun funs) + (binding* ((() (leaf-dynamic-extent fun) + :exit-if-null) + (xep (functional-entry-fun fun) + :exit-if-null) + (closure (physenv-closure + (get-lambda-physenv xep)))) + (cond (closure + (setq dx t)) + (t + (setf (leaf-extent fun) nil))))) + (when dx + (setf (lvar-dynamic-extent arg) cleanup) + (real-dx-lvars arg)))))) + (let ((real-dx-lvars (delete-duplicates (real-dx-lvars)))) + (setf (cleanup-info cleanup) real-dx-lvars) (setf (component-dx-lvars component) - (append (real-dx-lvars) (component-dx-lvars component))))))) + (append real-dx-lvars (component-dx-lvars component)))))))) (values)) ;;;; cleanup emission @@ -412,7 +451,7 @@ (reanalyze-funs fun) (code `(%funcall ,fun)))) ((:block :tagbody) - (dolist (nlx (cleanup-nlx-info cleanup)) + (dolist (nlx (cleanup-info cleanup)) (code `(%lexical-exit-breakup ',nlx)))) (:dynamic-extent (when (not (null (cleanup-info cleanup)))