X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fphysenvanal.lisp;h=037060dc3456f40959452e90c2be8bc51bad4e59;hb=8902b8b6bd2e9285749dd39d313b33b6c69c5213;hp=bfe514f55bd48dda46c0b6f42f94d02ac9e9da6b;hpb=419ce099442b9bffe41eff8516c6a2be085259de;p=sbcl.git diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp index bfe514f..037060d 100644 --- a/src/compiler/physenvanal.lisp +++ b/src/compiler/physenvanal.lisp @@ -30,14 +30,15 @@ (declare (type component component)) (aver (every (lambda (x) (eq (functional-kind x) :deleted)) - (component-new-funs component))) - (setf (component-new-funs component) ()) - (dolist (fun (component-lambdas component)) - (reinit-lambda-physenv fun)) + (component-new-functionals component))) + (setf (component-new-functionals component) ()) + (dolist (clambda (component-lambdas component)) + (reinit-lambda-physenv clambda)) (mapc #'add-lambda-vars-and-let-vars-to-closures (component-lambdas component)) (find-non-local-exits component) + (recheck-dynamic-extent-lvars component) (find-cleanup-points component) (tail-annotate component) @@ -48,8 +49,9 @@ (functional-has-external-references-p fun)) (aver (member kind '(:optional :cleanup :escape))) (setf (functional-kind fun) nil) - (delete-functional fun))))) + (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 @@ -123,9 +125,8 @@ ;;; 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. If it has no sets, we clear the INDIRECT flag. -;;; This is necessary because pre-analysis is done before -;;; optimization. +;;; from the closure. We always clear the INDIRECT flag. This is +;;; necessary because pre-analysis is done before optimization. (defun reinit-lambda-physenv (fun) (let ((old (lambda-physenv (lambda-home fun)))) (cond (old @@ -136,8 +137,7 @@ (physenv-closure old))) (flet ((clear (fun) (dolist (var (lambda-vars fun)) - (unless (lambda-var-sets var) - (setf (lambda-var-indirect var) nil))))) + (setf (lambda-var-indirect var) nil)))) (clear fun) (map nil #'clear (lambda-lets fun)))) (t @@ -171,11 +171,22 @@ (setq did-something t) (close-over var ref-physenv physenv)))) (dolist (set (basic-var-sets var)) - (let ((set-physenv (get-node-physenv set))) - (unless (eq set-physenv physenv) - (setq did-something t) - (setf (lambda-var-indirect var) t) - (close-over var set-physenv physenv))))) + + ;; Variables which are set but never referenced can be + ;; optimized away, and closing over them here would just + ;; interfere with that. (In bug 147, it *did* interfere with + ;; that, causing confusion later. This UNLESS solves that + ;; problem, but I (WHN) am not 100% sure it's best to solve + ;; the problem this way instead of somehow solving it + ;; somewhere upstream and just doing (AVER (LEAF-REFS VAR)) + ;; here.) + (unless (null (leaf-refs var)) + + (let ((set-physenv (get-node-physenv set))) + (unless (eq set-physenv physenv) + (setf did-something t + (lambda-var-indirect var) t) + (close-over var set-physenv physenv)))))) did-something)) ;;; Find any variables in CLAMBDA -- either directly in LAMBDA-VARS or @@ -223,13 +234,13 @@ ;;; 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 ;;; last node in the cleanup code to be the enclosing environment, to -;;; represent the fact that the binding was undone as a side-effect of +;;; represent the fact that the binding was undone as a side effect of ;;; the exit. This will cause a lexical exit to be broken up if we are ;;; actually exiting the scope (i.e. a BLOCK), and will also do any ;;; other cleanups that may have to be done on the way. @@ -237,14 +248,13 @@ (declare (type physenv env) (type exit exit)) (let* ((exit-block (node-block exit)) (next-block (first (block-succ exit-block))) - (cleanup (entry-cleanup (exit-entry exit))) - (info (make-nlx-info :cleanup cleanup - :continuation (node-cont exit))) (entry (exit-entry exit)) + (cleanup (entry-cleanup entry)) + (info (make-nlx-info cleanup exit)) (new-block (insert-cleanup-code exit-block next-block entry `(%nlx-entry ',info) - (entry-cleanup entry))) + cleanup)) (component (block-component new-block))) (unlink-blocks exit-block new-block) (link-blocks exit-block (component-tail component)) @@ -263,40 +273,43 @@ ;;; EXIT into ENV. This is called for each non-local exit node, of ;;; which there may be several per exit continuation. This is what we ;;; do: -;;; -- If there isn't any NLX-Info entry in the environment, make +;;; -- If there isn't any NLX-INFO entry in the environment, make ;;; an entry stub, otherwise just move the exit block link to ;;; the component tail. ;;; -- Close over the NLX-INFO in the exit environment. ;;; -- If the exit is from an :ESCAPE function, then substitute a -;;; constant reference to NLX-Info structure for the escape +;;; constant reference to NLX-INFO structure for the escape ;;; 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 ((entry (exit-entry exit)) - (cont (node-cont exit)) + (let ((lvar (node-lvar exit)) (exit-fun (node-home-lambda exit))) - (if (find-nlx-info entry cont) + (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 entry cont))) + (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*)) + (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-continuation-use node) - (add-continuation-use node (nlx-info-continuation info)))))) + (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))) + (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 @@ -315,6 +328,28 @@ (note-non-local-exit target-physenv exit)))))) (values)) +;;;; final decision on stack allocation of dynamic-extent structores +(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 lvar in (cleanup-info cleanup) + do (let ((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)))) + (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 @@ -346,17 +381,20 @@ (basic-combination-args node)))) (ecase (cleanup-kind cleanup) (:special-bind - (code `(%special-unbind ',(continuation-value (first args))))) + (code `(%special-unbind ',(lvar-value (first args))))) (:catch (code `(%catch-breakup))) (:unwind-protect (code `(%unwind-protect-breakup)) - (let ((fun (ref-leaf (continuation-use (second args))))) + (let ((fun (ref-leaf (lvar-uses (second args))))) (reanalyze-funs fun) (code `(%funcall ,fun)))) ((:block :tagbody) (dolist (nlx (cleanup-nlx-info cleanup)) - (code `(%lexical-exit-breakup ',nlx))))))) + (code `(%lexical-exit-breakup ',nlx)))) + (:dynamic-extent + (when (not (null (cleanup-info cleanup))) + (code `(%cleanup-point))))))) (when (code) (aver (not (node-tail-p (block-last block1)))) @@ -391,20 +429,27 @@ (emit-cleanups block1 block2))))))) (values)) -;;; Mark all tail-recursive uses of function result continuations with -;;; the corresponding TAIL-SET. Nodes whose type is NIL (i.e. don't -;;; return) such as calls to ERROR are never annotated as tail in -;;; order to preserve debugging information. +;;; Mark optimizable tail-recursive uses of function result +;;; continuations with the corresponding TAIL-SET. (defun tail-annotate (component) (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. (when ret (let ((result (return-result ret))) (do-uses (use result) - (when (and (immediately-used-p result use) - (or (not (eq (node-derived-type use) *empty-type*)) - (not (basic-combination-p use)) - (eq (basic-combination-kind use) :local))) - (setf (node-tail-p use) t))))))) + (when (and (policy use merge-tail-calls) + (basic-combination-p use) + (immediately-used-p result use) + (or (not (eq (node-derived-type use) *empty-type*)) + (eq (basic-combination-kind use) :local))) + (setf (node-tail-p use) t))))))) (values))