X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fphysenvanal.lisp;h=2f4ab871b3bc0e2fc88953a8ad8e673c99d132cb;hb=eda83f00e869193cb69826be5fa1086b95d12ff7;hp=d067c27d3181f3a2b4ef8e4d8143696cdc97cadc;hpb=6e1eec3ed564da272ebf0caad99384670ad4a643;p=sbcl.git diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp index d067c27..2f4ab87 100644 --- a/src/compiler/physenvanal.lisp +++ b/src/compiler/physenvanal.lisp @@ -230,8 +230,16 @@ ;; functions), or a pointer from an underlying function to its ;; XEP (for non-:TOPLEVEL functions with XEPs). (unless (or (leaf-dynamic-extent fun) - (and entry-fun - (leaf-dynamic-extent entry-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) @@ -240,10 +248,66 @@ ;;;; 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 @@ -344,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 @@ -393,7 +458,7 @@ (cond (closure (setq dx t)) (t - (setf (leaf-dynamic-extent fun) nil))))) + (setf (leaf-extent fun) nil))))) (when dx (setf (lvar-dynamic-extent arg) cleanup) (real-dx-lvars arg)))))) @@ -488,26 +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. --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))