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

[Erik Huelsmann]

Author: ehuelsmann
Date: Sun May  3 17:43:08 2009
New Revision: 11828

Log:
Use the fact that tags have lexical scope:
if they're not used, don't generate comparisons
for tags which are not used.

 * P1: Find out which tags are used
 * P2: Limit the number of tag comparisons


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	Sun May  3 17:43:08 2009
@@ -336,17 +336,21 @@
   (let* ((block (make-block-node '(TAGBODY)))
          (*blocks* (cons block *blocks*))
          (*visible-tags* *visible-tags*)
+         (local-tags '())
          (body (cdr form)))
     ;; Make all the tags visible before processing the body forms.
     (dolist (subform body)
       (when (or (symbolp subform) (integerp subform))
         (let* ((tag (make-tag :name subform :label (gensym) :block block)))
+          (push tag local-tags)
           (push tag *visible-tags*))))
     (let ((new-body '())
           (live t))
       (dolist (subform body)
         (cond ((or (symbolp subform) (integerp subform))
                (push subform new-body)
+               (push (find subform local-tags :key #'tag-name :test #'eql)
+                     (block-tags block))
                (setf live t))
               ((not live)
                ;; Nothing to do.
@@ -367,6 +371,7 @@
          (tag (find-tag name)))
     (unless tag
       (error "p1-go: tag not found: ~S" name))
+    (setf (tag-used tag) t)
     (let ((tag-block (tag-block tag)))
       (cond ((eq (tag-compiland tag) *current-compiland*)
              ;; Does the GO leave an enclosing UNWIND-PROTECT?

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	Sun May  3 17:43:08 2009
@@ -4430,7 +4430,6 @@
          (*register* *register*)
          (form (block-form block))
          (body (cdr form))
-         (local-tags ())
          (BEGIN-BLOCK (gensym))
          (END-BLOCK (gensym))
          (EXIT (gensym))
@@ -4440,11 +4439,8 @@
       (setf environment-register (allocate-register)
             (block-environment-register block) environment-register))
     ;; Scan for tags.
-    (dolist (subform body)
-      (when (or (symbolp subform) (integerp subform))
-        (let* ((tag (make-tag :name subform :label (gensym) :block block)))
-          (push tag local-tags)
-          (push tag *visible-tags*))))
+    (dolist (tag (block-tags block))
+      (push tag *visible-tags*))
 
     (when environment-register
       ;; Note: we store the environment register,
@@ -4465,10 +4461,12 @@
           (subform (car rest) (car rest)))
          ((null rest))
       (cond ((or (symbolp subform) (integerp subform))
-             (let ((tag (find-tag subform)))
+             (let ((tag (find subform (block-tags block) :key #'tag-name
+                              :test #'eql)))
                (unless tag
                  (error "COMPILE-TAGBODY: tag not found: ~S~%" subform))
-               (label (tag-label tag))))
+               (when (tag-used tag)
+                 (label (tag-label tag)))))
             (t
              (compile-form subform nil nil)
              (unless must-clear-values
@@ -4492,7 +4490,9 @@
         (emit 'checkcast +lisp-go-class+)
         (emit 'getfield +lisp-go-class+ "tag" +lisp-object+) ; Stack depth is still 1.
         (astore tag-register)
-        (dolist (tag local-tags)
+        ;; Don't actually generate comparisons for tags
+        ;; to which there is no GO instruction
+        (dolist (tag (remove-if-not #'tag-used (block-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	Sun May  3 17:43:08 2009
@@ -370,6 +370,8 @@
   ;; Only used in LET/LET*/M-V-B nodes.
   vars
   free-specials
+  ;; Only used in TAGBODY
+  tags
   )
 
 (defvar *blocks* ())
@@ -431,7 +433,8 @@
   label
   ;; The associated TAGBODY
   block
-  (compiland *current-compiland*))
+  (compiland *current-compiland*)
+  used)
 
 (defknown find-tag (t) t)
 (defun find-tag (name)