X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fphysenvanal.lisp;h=2f4ab871b3bc0e2fc88953a8ad8e673c99d132cb;hb=debae3c18d31b5222be4d5de8dcb2601336e24a4;hp=3cdb53b8ce3efa8ea726ea89e5c6eb71bffeb657;hpb=2d996b6c1f64a2a8f7515629bba134da0d0f0d32;p=sbcl.git diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp index 3cdb53b..2f4ab87 100644 --- a/src/compiler/physenvanal.lisp +++ b/src/compiler/physenvanal.lisp @@ -17,7 +17,7 @@ ;;; Do environment analysis on the code in COMPONENT. This involves ;;; various things: -;;; 1. Make a PHYSENV structure for each non-LET LAMBDA, assigning +;;; 1. Make a PHYSENV structure for each non-LET LAMBDA, assigning ;;; the LAMBDA-PHYSENV for all LAMBDAs. ;;; 2. Find all values that need to be closed over by each ;;; physical environment. @@ -25,30 +25,31 @@ ;;; continuations. ;;; 4. Delete all non-top-level functions with no references. This ;;; should only get functions with non-NULL kinds, since normal -;;; functions are deleted when their references go to zero. +;;; functions are deleted when their references go to zero. (defun physenv-analyze (component) (declare (type component component)) (aver (every (lambda (x) - (eq (functional-kind x) :deleted)) - (component-new-functionals component))) + (eq (functional-kind x) :deleted)) + (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)) + (component-lambdas component)) (find-non-local-exits component) (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)) (let ((kind (functional-kind fun))) - (unless (or (eq kind :toplevel) - (functional-has-external-references-p fun)) - (aver (member kind '(:optional :cleanup :escape))) - (setf (functional-kind fun) nil) + (unless (or (eq kind :toplevel) + (functional-has-external-references-p fun)) + (aver (member kind '(:optional :cleanup :escape))) + (setf (functional-kind fun) nil) (delete-functional fun))))) (setf (component-nlx-info-generated-p component) t) @@ -66,7 +67,7 @@ (let ((found-it nil)) (dolist (lambda (component-lambdas component)) (when (add-lambda-vars-and-let-vars-to-closures lambda) - (setq found-it t))) + (setq found-it t))) found-it)) ;;; If CLAMBDA has a PHYSENV, return it, otherwise assign an empty one @@ -75,38 +76,33 @@ (declare (type clambda clambda)) (let ((homefun (lambda-home clambda))) (or (lambda-physenv homefun) - (let ((res (make-physenv :lambda homefun))) - (setf (lambda-physenv homefun) res) - ;; All the LETLAMBDAs belong to HOMEFUN, and share the same - ;; PHYSENV. Thus, (1) since HOMEFUN's PHYSENV was NIL, - ;; theirs should be NIL too, and (2) since we're modifying - ;; HOMEFUN's PHYSENV, we should modify theirs, too. - (dolist (letlambda (lambda-lets homefun)) - (aver (eql (lambda-home letlambda) homefun)) - (aver (null (lambda-physenv letlambda))) - (setf (lambda-physenv letlambda) res)) - res)))) + (let ((res (make-physenv :lambda homefun))) + (setf (lambda-physenv homefun) res) + ;; All the LETLAMBDAs belong to HOMEFUN, and share the same + ;; PHYSENV. Thus, (1) since HOMEFUN's PHYSENV was NIL, + ;; theirs should be NIL too, and (2) since we're modifying + ;; HOMEFUN's PHYSENV, we should modify theirs, too. + (dolist (letlambda (lambda-lets homefun)) + (aver (eql (lambda-home letlambda) homefun)) + (aver (null (lambda-physenv letlambda))) + (setf (lambda-physenv letlambda) res)) + 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))) - (flet ((clear (fun) - (dolist (var (lambda-vars fun)) - (setf (lambda-var-indirect var) nil)))) - (clear fun) - (map nil #'clear (lambda-lets fun)))) - (t - (get-lambda-physenv fun)))) + (setf (physenv-closure old) nil) + (flet ((clear (fun) + (dolist (var (lambda-vars fun)) + (setf (lambda-var-indirect var) nil)))) + (clear fun) + (map nil #'clear (lambda-lets fun)))) + (t + (get-lambda-physenv fun)))) (values)) ;;; Get NODE's environment, assigning one if necessary. @@ -125,33 +121,33 @@ ;;; the LAMBDA-VARS of CLAMBDA's LAMBDA-LETS. (defun %add-lambda-vars-to-closures (clambda) (let ((physenv (get-lambda-physenv clambda)) - (did-something nil)) + (did-something nil)) (note-unreferenced-vars clambda) (dolist (var (lambda-vars clambda)) (dolist (ref (leaf-refs var)) - (let ((ref-physenv (get-node-physenv ref))) - (unless (eq ref-physenv physenv) - (when (lambda-var-sets var) - (setf (lambda-var-indirect var) t)) - (setq did-something t) - (close-over var ref-physenv physenv)))) + (let ((ref-physenv (get-node-physenv ref))) + (unless (eq ref-physenv physenv) + (when (lambda-var-sets var) + (setf (lambda-var-indirect var) t)) + (setq did-something t) + (close-over var ref-physenv physenv)))) (dolist (set (basic-var-sets var)) - ;; 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)) + ;; 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) + (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)))))) + (lambda-var-indirect var) t) + (close-over var set-physenv physenv)))))) did-something)) ;;; Find any variables in CLAMBDA -- either directly in LAMBDA-VARS or @@ -172,7 +168,7 @@ ;; here, since LETS only go one layer deep. (aver (null (lambda-lets lambda-let))) (when (%add-lambda-vars-to-closures lambda-let) - (setf did-something t))) + (setf did-something t))) did-something)) (defun xep-allocator (xep) @@ -212,13 +208,106 @@ (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 -#!-sb-fluid (declaim (inline should-exit-check-tag-p)) +(defvar *functional-escape-info*) + +(defun functional-may-escape-p (functional) + (let ((table *functional-escape-info*)) + (unless table + ;; Many components never need the table since they have no escapes -- so + ;; we allocate it lazily. + (setf table (make-hash-table) + *functional-escape-info* table)) + (multiple-value-bind (bool ok) (gethash functional table) + (if ok + bool + (let ((entry (functional-entry-fun functional))) + ;; First stick a NIL in there: break cycles. + (setf (gethash functional table) nil) + ;; Then compute the real value. + (setf (gethash functional table) + (or + ;; If the functional has a XEP, it's kind is :EXTERNAL -- + ;; which means it may escape. ...but if it + ;; HAS-EXTERNAL-REFERENCES-P, then that XEP is actually a + ;; TL-XEP, which means it's a toplevel function -- which in + ;; turn means our search has bottomed out without an escape + ;; path. AVER just to make sure, though. + (and (eq :external (functional-kind functional)) + (if (functional-has-external-references-p functional) + (aver (eq 'tl-xep (car (functional-debug-name functional)))) + t)) + ;; If it has an entry point that may escape, that just as bad. + (and entry (functional-may-escape-p entry)) + ;; If it has references to it in functions that may escape, that's bad + ;; too. + (dolist (ref (functional-refs functional) nil) + (let* ((lvar (ref-lvar ref)) + (dest (when lvar (lvar-dest lvar)))) + (when (functional-may-escape-p (node-home-lambda dest)) + (return t))))))))))) + (defun exit-should-check-tag-p (exit) (declare (type exit exit)) - (not (zerop (policy exit check-tag-existence)))) + (let ((exit-lambda (lexenv-lambda (node-lexenv exit)))) + (unless (or + ;; Unsafe but fast... + (policy exit (zerop check-tag-existence)) + ;; Dynamic extent is a promise things won't escape -- + ;; and an explicit request to avoid heap consing. + (member (lambda-extent exit-lambda) '(:always-dynamic :maybe-dynamic)) + ;; If the exit lambda cannot escape, then we should be safe. + ;; ...since the escape analysis is kinda new, and not particularly + ;; exhaustively tested, let alone proven, disable it for SAFETY 3. + (and (policy exit (< safety 3)) + (not (functional-may-escape-p exit-lambda)))) + (when (policy exit (> speed safety)) + (let ((*compiler-error-context* (exit-entry exit))) + (compiler-notify "~@" + (node-source-form exit)))) + t))) ;;; 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 @@ -239,15 +328,15 @@ (defun insert-nlx-entry-stub (exit env) (declare (type physenv env) (type exit exit)) (let* ((exit-block (node-block exit)) - (next-block (first (block-succ exit-block))) - (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) - cleanup)) - (component (block-component new-block))) + (next-block (first (block-succ exit-block))) + (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) + cleanup)) + (component (block-component new-block))) (unlink-blocks exit-block new-block) (link-blocks exit-block (component-tail component)) (link-blocks (component-head component) new-block) @@ -256,10 +345,10 @@ (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)))) + (node-lexenv entry)))) (values)) @@ -283,7 +372,7 @@ (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)) + (exit-fun (node-home-lambda exit)) (info (find-nlx-info exit))) (cond (info (let ((block (node-block exit))) @@ -319,13 +408,14 @@ ;;; for later phases. (defun find-non-local-exits (component) (declare (type component component)) - (dolist (lambda (component-lambdas component)) - (dolist (entry (lambda-entries lambda)) - (dolist (exit (entry-exits entry)) - (let ((target-physenv (node-physenv entry))) - (if (eq (node-physenv exit) target-physenv) - (maybe-delete-exit exit) - (note-non-local-exit target-physenv exit)))))) + (let ((*functional-escape-info* nil)) + (dolist (lambda (component-lambdas component)) + (dolist (entry (lambda-entries lambda)) + (dolist (exit (entry-exits entry)) + (let ((target-physenv (node-physenv entry))) + (if (eq (node-physenv exit) target-physenv) + (maybe-delete-exit exit) + (note-non-local-exit target-physenv exit))))))) (values)) ;;;; final decision on stack allocation of dynamic-extent structures @@ -333,43 +423,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 @@ -393,38 +489,38 @@ (defun emit-cleanups (block1 block2) (declare (type cblock block1 block2)) (collect ((code) - (reanalyze-funs)) + (reanalyze-funs)) (let ((cleanup2 (block-start-cleanup block2))) (do ((cleanup (block-end-cleanup block1) - (node-enclosing-cleanup (cleanup-mess-up cleanup)))) - ((eq cleanup cleanup2)) - (let* ((node (cleanup-mess-up cleanup)) - (args (when (basic-combination-p node) - (basic-combination-args node)))) - (ecase (cleanup-kind cleanup) - (:special-bind - (code `(%special-unbind ',(lvar-value (first args))))) - (:catch - (code `(%catch-breakup))) - (:unwind-protect - (code `(%unwind-protect-breakup)) - (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)))) - (:dynamic-extent - (when (not (null (cleanup-info cleanup))) + (node-enclosing-cleanup (cleanup-mess-up cleanup)))) + ((eq cleanup cleanup2)) + (let* ((node (cleanup-mess-up cleanup)) + (args (when (basic-combination-p node) + (basic-combination-args node)))) + (ecase (cleanup-kind cleanup) + (:special-bind + (code `(%special-unbind ',(lvar-value (first args))))) + (:catch + (code `(%catch-breakup))) + (:unwind-protect + (code `(%unwind-protect-breakup)) + (let ((fun (ref-leaf (lvar-uses (second args))))) + (reanalyze-funs fun) + (code `(%funcall ,fun)))) + ((:block :tagbody) + (dolist (nlx (cleanup-info cleanup)) + (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)))) - (insert-cleanup-code block1 block2 - (block-last block1) - `(progn ,@(code))) - (dolist (fun (reanalyze-funs)) - (locall-analyze-fun-1 fun))))) + (aver (not (node-tail-p (block-last block1)))) + (insert-cleanup-code block1 block2 + (block-last block1) + `(progn ,@(code))) + (dolist (fun (reanalyze-funs)) + (locall-analyze-fun-1 fun))))) (values)) @@ -437,18 +533,18 @@ (declare (type component component)) (do-blocks (block1 component) (let ((env1 (block-physenv block1)) - (cleanup1 (block-end-cleanup block1))) + (cleanup1 (block-end-cleanup block1))) (dolist (block2 (block-succ block1)) - (when (block-start block2) - (let ((env2 (block-physenv block2)) - (cleanup2 (block-start-cleanup block2))) - (unless (or (not (eq env2 env1)) - (eq cleanup1 cleanup2) - (and cleanup2 - (eq (node-enclosing-cleanup - (cleanup-mess-up cleanup2)) - cleanup1))) - (emit-cleanups block1 block2))))))) + (when (block-start block2) + (let ((env2 (block-physenv block2)) + (cleanup2 (block-start-cleanup block2))) + (unless (or (not (eq env2 env1)) + (eq cleanup1 cleanup2) + (and cleanup2 + (eq (node-enclosing-cleanup + (cleanup-mess-up cleanup2)) + cleanup1))) + (emit-cleanups block1 block2))))))) (values)) ;;; Mark optimizable tail-recursive uses of function result @@ -457,21 +553,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. (when ret - (let ((result (return-result ret))) - (do-uses (use result) - (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))))))) + (let ((result (return-result ret))) + (do-uses (use result) + (when (and (basic-combination-p use) + (immediately-used-p result use) + (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))