[armedbear-cvs] r12154 - trunk/abcl/src/org/armedbear/lisp

[Erik Huelsmann]

Author: ehuelsmann
Date: Fri Sep 18 16:40:44 2009
New Revision: 12154

Log:
TAGBODY efficiency: only check those tags which are being used
   as "targets" for Go exceptions.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   trunk/abcl/src/org/armedbear/lisp/jvm.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp	Fri Sep 18 16:40:44 2009
@@ -426,14 +426,16 @@
       (cond ((eq (tag-compiland tag) *current-compiland*)
              ;; Does the GO leave an enclosing UNWIND-PROTECT or CATCH?
              (if (enclosed-by-protected-block-p tag-block)
-                 (setf (tagbody-non-local-go-p tag-block) t)
+                 (setf (tagbody-non-local-go-p tag-block) t
+                       (tag-used-non-locally tag) t)
                  ;; non-local GO's ensure environment restoration
                  ;; find out about this local GO
                  (when (null (tagbody-needs-environment-restoration tag-block))
                    (setf (tagbody-needs-environment-restoration tag-block)
                          (enclosed-by-environment-setting-block-p tag-block)))))
             (t
-             (setf (tagbody-non-local-go-p tag-block) t)))))
+             (setf (tagbody-non-local-go-p tag-block) t
+                   (tag-used-non-locally tag) t)))))
   form)
 
 (defun validate-function-name (name)

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Fri Sep 18 16:40:44 2009
@@ -4502,8 +4502,9 @@
         (emit 'getfield +lisp-go-class+ "tag" +lisp-object+) ; Stack depth is still 1.
         (astore tag-register)
         ;; Don't actually generate comparisons for tags
-        ;; to which there is no GO instruction
-        (dolist (tag (remove-if-not #'tag-used (tagbody-tags block)))
+        ;; to which there is no non-local GO instruction
+        (dolist (tag (remove-if-not #'tag-used-non-locally
+                                    (tagbody-tags block)))
           (let ((NEXT (gensym)))
             (aload tag-register)
             (emit 'getstatic *this-class*

Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/jvm.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp	Fri Sep 18 16:40:44 2009
@@ -588,7 +588,8 @@
   ;; The associated TAGBODY
   block
   (compiland *current-compiland*)
-  used)
+  used
+  used-non-locally)
 
 (defknown find-tag (t) t)
 (defun find-tag (name)