0.8.18.26:

        * Generate one NLX-INFO per pair cleanup/continuation.

src/compiler/ir1util.lisp

@@ -740,7 +740,7 @@
                ((:block :tagbody)
                 (aver (entry-p mess-up))
                 (loop for exit in (entry-exits mess-up)
-                      for nlx-info = (find-nlx-info exit)
+                      for nlx-info = (exit-nlx-info exit)
                       do (funcall fun nlx-info)))
                ((:catch :unwind-protect)
                 (aver (combination-p mess-up))
@@ -1531,10 +1531,17 @@
 ;;; exits to CONT in that entry, then return it, otherwise return NIL.
 (defun find-nlx-info (exit)
   (declare (type exit exit))
-  (let ((entry (exit-entry exit)))
+  (let* ((entry (exit-entry exit))
+         (cleanup (entry-cleanup entry))
+        (block (first (block-succ (node-block exit)))))
     (dolist (nlx (physenv-nlx-info (node-physenv entry)) nil)
-      (when (eq (nlx-info-exit nlx) exit)
+      (when (and (eq (nlx-info-block nlx) block)
+                 (eq (nlx-info-cleanup nlx) cleanup))
 	(return nlx)))))
+
+(defun nlx-info-lvar (nlx)
+  (declare (type nlx-info nlx))
+  (node-lvar (block-last (nlx-info-target nlx))))
 
 ;;;; functional hackery
 

src/compiler/ir2tran.lisp

@@ -1489,7 +1489,7 @@
 ;;; IR2 converted.
 (defun ir2-convert-exit (node block)
   (declare (type exit node) (type ir2-block block))
-  (let ((loc (find-in-physenv (find-nlx-info node)
+  (let ((loc (find-in-physenv (exit-nlx-info node)
 			      (node-physenv node)))
 	(temp (make-stack-pointer-tn))
 	(value (exit-value node)))
@@ -1570,12 +1570,15 @@
 ;;; Scan each of ENTRY's exits, setting up the exit for each lexical exit.
 (defun ir2-convert-entry (node block)
   (declare (type entry node) (type ir2-block block))
-  (dolist (exit (entry-exits node))
-    (let ((info (find-nlx-info exit)))
-      (when (and info
-		 (member (cleanup-kind (nlx-info-cleanup info))
-			 '(:block :tagbody)))
-	(emit-nlx-start node block info nil))))
+  (let ((nlxes '()))
+    (dolist (exit (entry-exits node))
+      (let ((info (exit-nlx-info exit)))
+        (when (and info
+                   (not (memq info nlxes))
+                   (member (cleanup-kind (nlx-info-cleanup info))
+                           '(:block :tagbody)))
+          (push info nlxes)
+          (emit-nlx-start node block info nil)))))
   (values))
 
 ;;; Set up the unwind block for these guys.
@@ -1606,7 +1609,7 @@
 ;;; pointer alone, since the thrown values are still out there.
 (defoptimizer (%nlx-entry ir2-convert) ((info-lvar) node block)
   (let* ((info (lvar-value info-lvar))
-	 (lvar (nlx-info-lvar info))
+	 (lvar (node-lvar node))
 	 (2info (nlx-info-info info))
 	 (top-loc (ir2-nlx-info-save-sp 2info))
 	 (start-loc (make-nlx-entry-arg-start-location))

src/compiler/node.lisp

@@ -543,27 +543,27 @@
 (def!struct (nlx-info
 	     (:constructor make-nlx-info (cleanup
 					  exit
-					  &aux (lvar (node-lvar exit))))
+					  &aux
+                                          (block (first (block-succ
+                                                         (node-block exit))))))
 	     (:make-load-form-fun ignore-it))
   ;; the cleanup associated with this exit. In a catch or
   ;; unwind-protect, this is the :CATCH or :UNWIND-PROTECT cleanup,
   ;; and not the cleanup for the escape block. The CLEANUP-KIND of
   ;; this thus provides a good indication of what kind of exit is
   ;; being done.
   (cleanup (missing-arg) :type cleanup)
-  ;; the continuation exited to (the CONT of the EXIT nodes). If this
-  ;; exit is from an escape function (CATCH or UNWIND-PROTECT), then
-  ;; physical environment analysis deletes the escape function and
-  ;; instead has the %NLX-ENTRY use this continuation.
+  ;; the ``continuation'' exited to (the block, succeeding the EXIT
+  ;; nodes). If this exit is from an escape function (CATCH or
+  ;; UNWIND-PROTECT), then physical environment analysis deletes the
+  ;; escape function and instead has the %NLX-ENTRY use this
+  ;; continuation.
   ;;
-  ;; This slot is primarily an indication of where this exit delivers
-  ;; its values to (if any), but it is also used as a sort of name to
-  ;; allow us to find the NLX-INFO that corresponds to a given exit.
-  ;; For this purpose, the ENTRY must also be used to disambiguate,
-  ;; since exits to different places may deliver their result to the
-  ;; same continuation.
-  (exit (missing-arg) :type exit)
-  (lvar (missing-arg) :type (or lvar null))
+  ;; This slot is used as a sort of name to allow us to find the
+  ;; NLX-INFO that corresponds to a given exit. For this purpose, the
+  ;; ENTRY must also be used to disambiguate, since exits to different
+  ;; places may deliver their result to the same continuation.
+  (block (missing-arg) :type cblock)
   ;; the entry stub inserted by physical environment analysis. This is
   ;; a block containing a call to the %NLX-ENTRY funny function that
   ;; has the original exit destination as its successor. Null only
@@ -572,7 +572,7 @@
   ;; some kind of info used by the back end
   info)
 (defprinter (nlx-info :identity t)
-  exit
+  block
   target
   info)
 
@@ -1319,7 +1319,8 @@
   (entry nil :type (or entry null))
   ;; the lvar yielding the value we are to exit with. If NIL, then no
   ;; value is desired (as in GO).
-  (value nil :type (or lvar null)))
+  (value nil :type (or lvar null))
+  (nlx-info nil :type (or nlx-info null)))
 (defprinter (exit :identity t)
   #!+sb-show id
   (entry :test entry)

src/compiler/physenvanal.lisp

@@ -282,6 +282,7 @@
     (link-blocks exit-block (component-tail component))
     (link-blocks (component-head component) new-block)
 
+    (setf (exit-nlx-info exit) info)
     (setf (nlx-info-target info) new-block)
     (push info (physenv-nlx-info env))
     (push info (cleanup-nlx-info cleanup))
@@ -311,27 +312,30 @@
 (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)))
-    (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 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*))
-	      (leaf-refs exit-fun))
-	(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))))))
+	(exit-fun (node-home-lambda exit))
+        (info (find-nlx-info exit)))
+    (cond (info
+           (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)))
+             (setf (exit-nlx-info exit) info)))
+          (t
+           (insert-nlx-entry-stub exit env)
+           (setq info (exit-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*))
+            (leaf-refs exit-fun))
+      (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

version.lisp-expr

@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.18.25"
+"0.8.18.26"