emit compiler notes of NLX value-cells when (> SPEED SAFETY)

  People have a right to know: it's NEWS.

diff --git a/NEWS b/NEWS
index 6b64501..4d10a6d 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -11,6 +11,9 @@ changes relative to sbcl-1.0.57:
   * optimization: MAP-INTO is substantially faster when the target sequence is
     of unknown type; mapping into lists is no longer O(N^2). (thanks to James
     M. Lawrence)
+  * optimization: the compiler no longer heap-conses to check exits in cases
+    where the exit function is dynamic extent, or when it can prove the exit
+    function cannot escape.
   * optimization: SB-SEQUENCE:DOSEQUENCE is faster on vectors of unknown
     element type, and vectors that aren't SIMPLE-ARRAYs.
   * bug fix: potential for infinite recursion during compilation of CLOS slot

diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp
index a082a67..2f4ab87 100644 (file)
--- a/src/compiler/physenvanal.lisp
+++ b/src/compiler/physenvanal.lisp
@@ -289,17 +289,25 @@
 (defun exit-should-check-tag-p (exit)
   (declare (type exit exit))
   (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)))))))
+    (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 "~@<Allocating a value-cell at runtime for ~
+                            checking possibly out of extent exit via ~S. Use ~
+                            GO/RETURN-FROM with SAFETY 0, or declare the exit ~
+                            function DYNAMIC-EXTENT to avoid.~:@>"
+                           (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

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 3430814..d047047 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -4285,7 +4285,15 @@
 
 (with-test (:name :escape-analysis-for-nlxs)
   (flet ((test (check lambda &rest args)
-           (let ((fun (compile nil lambda)))
+           (let* ((cell-note nil)
+                  (fun (handler-bind ((compiler-note
+                                        (lambda (note)
+                                          (when (search
+                                                 "Allocating a value-cell at runtime for"
+                                                 (princ-to-string note))
+                                            (setf cell-note t)))))
+                          (compile nil lambda))))
+             (assert (eql check cell-note))
              (if check
                  (assert
                   (eq :ok
@@ -4299,17 +4307,20 @@
                             :ok)))))
                  (ctu:assert-no-consing (apply fun args))))))
     (test nil `(lambda (x)
+                 (declare (optimize speed))
                  (block out
                    (flet ((ex () (return-from out 'out!)))
                      (typecase x
                        (cons (or (car x) (ex)))
                        (t (ex)))))) :foo)
     (test t   `(lambda (x)
+                 (declare (optimize speed))
                  (funcall
                   (block nasty
                     (flet ((oops () (return-from nasty t)))
                       #'oops)))) t)
     (test t   `(lambda (r)
+                 (declare (optimize speed))
                  (block out
                    (flet ((ex () (return-from out r)))
                      (lambda (x)
@@ -4317,6 +4328,7 @@
                          (cons (or (car x) (ex)))
                          (t (ex))))))) t t)
     (test t   `(lambda (x)
+                 (declare (optimize speed))
                  (flet ((eh (x)
                           (flet ((meh () (return-from eh 'meh)))
                             (lambda ()