X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fphysenvanal.lisp;h=615239a3f47f8246db4193cd970608a6fae6972f;hb=436b2ab0276f547e8537b6c1fb52b11fa1f53975;hp=481ce2e35a38618d288933e83433fc1550d753e3;hpb=6dac5c9af52b4538b412b2e7c22b78863d85557a;p=sbcl.git diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp index 481ce2e..615239a 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)) @@ -207,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 @@ -251,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)))) @@ -328,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 @@ -407,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))) @@ -452,26 +496,24 @@ (declare (type component component)) (dolist (fun (component-lambdas component)) (let ((ret (lambda-return fun))) - ;; Nodes whose type is NIL (i.e. don't return) such as calls to - ;; ERROR are never annotated as TAIL-P, in order to preserve - ;; debugging information. - ;; - ;; FIXME: It might be better to add another DEFKNOWN property - ;; (e.g. NO-TAIL-RECURSION) and use it for error-handling - ;; functions like ERROR, instead of spreading this special case - ;; net so widely. --WHN? - ;; - ;; Why is that bad? Because this non-elimination of - ;; non-returning tail calls causes the XEP for FOO appear in - ;; backtrace for (defun foo (x) (error "foo ~S" x)) wich seems - ;; less then optimal. --NS 2005-02-28 (when ret (let ((result (return-result ret))) (do-uses (use result) - (when (and (policy use merge-tail-calls) - (basic-combination-p use) + (when (and (basic-combination-p use) (immediately-used-p result use) - (or (not (eq (node-derived-type use) *empty-type*)) - (eq (basic-combination-kind use) :local))) + (or (eq (basic-combination-kind use) :local) + ;; Nodes whose type is NIL (i.e. don't return) such + ;; as calls to ERROR are never annotated as TAIL-P, + ;; in order to preserve debugging information, so that + ;; + ;; We spread this net wide enough to catch + ;; untrusted NIL return types as well, so that + ;; frames calling functions such as FOO-ERROR are + ;; kept in backtraces: + ;; + ;; (defun foo-error (x) (error "oops: ~S" x)) + ;; + (not (or (eq *empty-type* (node-derived-type use)) + (eq *empty-type* (combination-defined-type use)))))) (setf (node-tail-p use) t))))))) (values))