X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fphysenvanal.lisp;h=3cdb53b8ce3efa8ea726ea89e5c6eb71bffeb657;hb=b63c4fb9b98fa8188e17ba926e150ba417a74635;hp=cf4386560ea52425d6ff35cb4ab66445a773638f;hpb=304c44d731bea3b9ce3c47d864d90eac92ba604e;p=sbcl.git diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp index cf43865..3cdb53b 100644 --- a/src/compiler/physenvanal.lisp +++ b/src/compiler/physenvanal.lisp @@ -38,6 +38,7 @@ (component-lambdas component)) (find-non-local-exits component) + (recheck-dynamic-extent-lvars component) (find-cleanup-points component) (tail-annotate component) @@ -50,6 +51,7 @@ (setf (functional-kind fun) nil) (delete-functional fun))))) + (setf (component-nlx-info-generated-p component) t) (values)) ;;; This is to be called on a COMPONENT with top level LAMBDAs before @@ -67,41 +69,6 @@ (setq found-it t))) found-it)) -;;; This is like old CMU CL PRE-ENVIRONMENT-ANALYZE-TOPLEVEL, except -;;; (1) It's been brought into the post-0.7.0 world where the property -;;; HAS-EXTERNAL-REFERENCES-P is orthogonal to the property of -;;; being specialized/optimized for locall at top level. -;;; (2) There's no return value, since we don't care whether we -;;; find any possible closure variables. -;;; -;;; I wish I could find an explanation of why -;;; PRE-ENVIRONMENT-ANALYZE-TOPLEVEL is important. The old CMU CL -;;; comments said -;;; Called on component with top level lambdas before the -;;; compilation of the associated non-top-level code to detect -;;; closed over top level variables. We just do COMPUTE-CLOSURE on -;;; all the lambdas. This will pre-allocate environments for all -;;; the functions with closed-over top level variables. The -;;; post-pass will use the existing structure, rather than -;;; allocating a new one. We return true if we discover any -;;; possible closure vars. -;;; But that doesn't seem to explain either why it's important to do -;;; this for top level lambdas, or why it's important to do it only -;;; for top level lambdas instead of just doing it indiscriminately -;;; for all lambdas. I do observe that when it's not done, compiler -;;; assertions occasionally fail. My tentative hypothesis for why it's -;;; important to do it is that other environment analysis expects to -;;; bottom out on the outermost enclosing thing, and (insert -;;; mysterious reason here) it's important to set up bottomed-out-here -;;; environments before anything else. I haven't been able to guess -;;; why it's important to do it selectively instead of -;;; indiscriminately. -- WHN 2001-11-10 -(defun preallocate-physenvs-for-toplevelish-lambdas (component) - (dolist (clambda (component-lambdas component)) - (when (lambda-toplevelish-p clambda) - (add-lambda-vars-and-let-vars-to-closures clambda))) - (values)) - ;;; If CLAMBDA has a PHYSENV, return it, otherwise assign an empty one ;;; and return that. (defun get-lambda-physenv (clambda) @@ -208,6 +175,10 @@ (setf did-something t))) did-something)) +(defun xep-allocator (xep) + (let ((entry (functional-entry-fun xep))) + (functional-allocator entry))) + ;;; Make sure that THING is closed over in REF-PHYSENV and in all ;;; PHYSENVs for the functions that reference REF-PHYSENV's function ;;; (not just calls). HOME-PHYSENV is THING's home environment. When we @@ -215,25 +186,48 @@ (defun close-over (thing ref-physenv home-physenv) (declare (type physenv ref-physenv home-physenv)) (let ((flooded-physenvs nil)) - (named-let flood ((flooded-physenv ref-physenv)) - (unless (or (eql flooded-physenv home-physenv) - (member flooded-physenv flooded-physenvs)) - (push flooded-physenv flooded-physenvs) - (pushnew thing (physenv-closure flooded-physenv)) - (dolist (ref (leaf-refs (physenv-lambda flooded-physenv))) - (flood (get-node-physenv ref)))))) + (labels ((flood (flooded-physenv) + (unless (or (eql flooded-physenv home-physenv) + (member flooded-physenv flooded-physenvs)) + (push flooded-physenv flooded-physenvs) + (unless (memq thing (physenv-closure flooded-physenv)) + (push thing (physenv-closure flooded-physenv)) + (let ((lambda (physenv-lambda flooded-physenv))) + (cond ((eq (functional-kind lambda) :external) + (let* ((alloc-node (xep-allocator lambda)) + (alloc-lambda (node-home-lambda alloc-node)) + (alloc-physenv (get-lambda-physenv alloc-lambda))) + (flood alloc-physenv) + (dolist (ref (leaf-refs lambda)) + (close-over lambda + (get-node-physenv ref) alloc-physenv)))) + (t (dolist (ref (leaf-refs lambda)) + ;; FIXME: This assertion looks + ;; reasonable, but does not work for + ;; :CLEANUPs. + #+nil + (let ((dest (node-dest ref))) + (aver (basic-combination-p dest)) + (aver (eq (basic-combination-kind dest) :local))) + (flood (get-node-physenv ref)))))))))) + (flood ref-physenv))) (values)) ;;;; non-local exit +#!-sb-fluid (declaim (inline should-exit-check-tag-p)) +(defun exit-should-check-tag-p (exit) + (declare (type exit exit)) + (not (zerop (policy exit check-tag-existence)))) + ;;; Insert the entry stub before the original exit target, and add a ;;; new entry to the PHYSENV-NLX-INFO. The %NLX-ENTRY call in the ;;; stub is passed the NLX-INFO as an argument so that the back end ;;; knows what entry is being done. ;;; ;;; The link from the EXIT block to the entry stub is changed to be a -;;; link to the component head. Similarly, the EXIT block is linked to -;;; the component tail. This leaves the entry stub reachable, but +;;; link from the component head. Similarly, the EXIT block is linked +;;; to the component tail. This leaves the entry stub reachable, but ;;; makes the flow graph less confusing to flow analysis. ;;; ;;; If a CATCH or an UNWIND-protect, then we set the LEXENV for the @@ -258,7 +252,9 @@ (link-blocks exit-block (component-tail component)) (link-blocks (component-head component) new-block) + (setf (exit-nlx-info exit) info) (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)) (when (member (cleanup-kind cleanup) '(:catch :unwind-protect)) @@ -280,31 +276,40 @@ ;;; function reference. This will cause the escape function to ;;; be deleted (although not removed from the DFO.) The escape ;;; function is no longer needed, and we don't want to emit code -;;; for it. We then also change the %NLX-ENTRY call to use the -;;; NLX continuation so that there will be a use to represent -;;; the NLX use. +;;; for it. +;;; -- Change the %NLX-ENTRY call to use the NLX lvar so that 1) there +;;; will be a use to represent the NLX use; 2) make life easier for +;;; the stack analysis. (defun note-non-local-exit (env exit) (declare (type physenv env) (type exit exit)) (let ((lvar (node-lvar exit)) - (exit-fun (node-home-lambda exit))) - (if (find-nlx-info exit) - (let ((block (node-block exit))) - (aver (= (length (block-succ block)) 1)) - (unlink-blocks block (first (block-succ block))) - (link-blocks block (component-tail (block-component block)))) - (insert-nlx-entry-stub exit env)) - (let ((info (find-nlx-info exit))) - (aver info) - (close-over info (node-physenv exit) env) - (when (eq (functional-kind exit-fun) :escape) - (mapc (lambda (x) - (setf (node-derived-type x) *wild-type*)) - (leaf-refs exit-fun)) - (substitute-leaf (find-constant info) exit-fun) - (let ((node (block-last (nlx-info-target info)))) - (delete-lvar-use node) + (exit-fun (node-home-lambda exit)) + (info (find-nlx-info exit))) + (cond (info + (let ((block (node-block exit))) + (aver (= (length (block-succ block)) 1)) + (unlink-blocks block (first (block-succ block))) + (link-blocks block (component-tail (block-component block))) + (setf (exit-nlx-info exit) info) + (unless (nlx-info-safe-p info) + (setf (nlx-info-safe-p info) + (exit-should-check-tag-p exit))))) + (t + (insert-nlx-entry-stub exit env) + (setq info (exit-nlx-info exit)) + (aver info))) + (close-over info (node-physenv exit) env) + (when (eq (functional-kind exit-fun) :escape) + (mapc (lambda (x) + (setf (node-derived-type x) *wild-type*)) + (leaf-refs exit-fun)) + (substitute-leaf (find-constant info) exit-fun)) + (when lvar + (let ((node (block-last (nlx-info-target info)))) + (unless (node-lvar node) (aver (eq lvar (node-lvar exit))) - (add-lvar-use node lvar))))) + (setf (node-derived-type node) (lvar-derived-type lvar)) + (add-lvar-use node lvar))))) (values)) ;;; Iterate over the EXITs in COMPONENT, calling NOTE-NON-LOCAL-EXIT @@ -323,6 +328,50 @@ (note-non-local-exit target-physenv exit)))))) (values)) +;;;; final decision on stack allocation of dynamic-extent structures +(defun recheck-dynamic-extent-lvars (component) + (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)) + (setf (component-dx-lvars component) + (append (real-dx-lvars) (component-dx-lvars component))))))) + (values)) + ;;;; cleanup emission ;;; Zoom up the cleanup nesting until we hit CLEANUP1, accumulating @@ -366,7 +415,8 @@ (dolist (nlx (cleanup-nlx-info cleanup)) (code `(%lexical-exit-breakup ',nlx)))) (:dynamic-extent - (code `(%dynamic-extent-end)))))) + (when (not (null (cleanup-info cleanup))) + (code `(%cleanup-point))))))) (when (code) (aver (not (node-tail-p (block-last block1))))