Steel Bank Common Lisp

The branch "master" has been updated in SBCL:
       via  3352e447d32d6786a5609cd53c6b3f2be7ab3e08 (commit)
      from  2ad50715571eb8ccfb9ab55c13b8c038c89f2dfd (commit)

- Log -----------------------------------------------------------------
commit 3352e447d32d6786a5609cd53c6b3f2be7ab3e08
Author: Nikodemus Siivola <nikodemus@...>
Date:   Mon May 21 23:30:54 2012 +0300

    elide value cells for NLXs when it seems like the right thing
    
      Previously we only did this for unsafe code.
    
      Now we also elide them for
    
       (1) exits from DX functions: if a DX function escapes its proper context,
           trying to perform NLX to a stale tag is the least of our worries.
    
       (2) functions that cannot escape. Since the escape analysis isn't yet very
           tested, disable it for safe code, though. If this raises hairs on your
           neck, consider this: even if our analysis is wrong, and a function we
           didn't think could escape does, we're in the land of "undefined
           consequences" anyways.
    
           If you're wondering if this is worth it, compare
    
             (defun feh (x)
               (flet ((meh () (return-from feh 'meh)))
                 (typecase x
                  (cons (or (car x) (meh)))
                  (t (meh)))))
    
             (time (loop repeat 10000 do (feh t)))
    
           with and without the escape analysis.
---
 src/compiler/physenvanal.lisp |   67 +++++++++++++++++++++++++++++++++++-----
 tests/compiler.pure.lisp      |   42 +++++++++++++++++++++++++
 2 files changed, 100 insertions(+), 9 deletions(-)

diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp
index 615239a..a082a67 100644
--- a/src/compiler/physenvanal.lisp
+++ b/src/compiler/physenvanal.lisp
@@ -248,10 +248,58 @@
 
 ;;;; 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))))
+    (not (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)))))))
 
 ;;; 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
@@ -352,13 +400,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
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index cd14e50..3430814 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -4282,3 +4282,45 @@
      (sb-int:compiled-program-error (e)
        (let ((source (read-from-string (sb-kernel::program-error-source e))))
          (equal source '#'(lambda ("foo"))))))))
+
+(with-test (:name :escape-analysis-for-nlxs)
+  (flet ((test (check lambda &rest args)
+           (let ((fun (compile nil lambda)))
+             (if check
+                 (assert
+                  (eq :ok
+                      (handler-case
+                          (dolist (arg args nil)
+                            (setf fun (funcall fun arg)))
+                        (sb-int:simple-control-error (e)
+                          (when (equal
+                                 (simple-condition-format-control e)
+                                 "attempt to RETURN-FROM a block or GO to a tag that no longer exists")
+                            :ok)))))
+                 (ctu:assert-no-consing (apply fun args))))))
+    (test nil `(lambda (x)
+                 (block out
+                   (flet ((ex () (return-from out 'out!)))
+                     (typecase x
+                       (cons (or (car x) (ex)))
+                       (t (ex)))))) :foo)
+    (test t   `(lambda (x)
+                 (funcall
+                  (block nasty
+                    (flet ((oops () (return-from nasty t)))
+                      #'oops)))) t)
+    (test t   `(lambda (r)
+                 (block out
+                   (flet ((ex () (return-from out r)))
+                     (lambda (x)
+                       (typecase x
+                         (cons (or (car x) (ex)))
+                         (t (ex))))))) t t)
+    (test t   `(lambda (x)
+                 (flet ((eh (x)
+                          (flet ((meh () (return-from eh 'meh)))
+                            (lambda ()
+                              (typecase x
+                                (cons (or (car x) (meh)))
+                                (t (meh)))))))
+                   (funcall (eh x)))) t t)))

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL