Changeset 11828 for trunk/abcl/src/org

Timestamp:

05/03/09 21:43:08 (15 years ago)

Author:

ehuelsmann

Message:

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

Location:

trunk/abcl/src/org/armedbear/lisp

Files:

• compiler-pass1.lisp (modified) (4 diffs)
• compiler-pass2.lisp (modified) (4 diffs)
• jvm.lisp (modified) (2 diffs)

trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp

@@ -337 +337 @@
          (*blocks* (cons block *blocks*))
          (*visible-tags* *visible-tags*)
+         (local-tags '())
          (body (cdr form)))
     ;; Make all the tags visible before processing the body forms.
@@ -342 +343 @@
       (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 '())
@@ -348 +350 @@
         (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)
@@ -368 +372 @@
     (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*)

trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

@@ -4431 +4431 @@
          (form (block-form block))
          (body (cdr form))
-         (local-tags ())
          (BEGIN-BLOCK (gensym))
          (END-BLOCK (gensym))
@@ -4441 +4440 @@
             (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
@@ -4466 +4462 @@
          ((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)
@@ -4493 +4491 @@
         (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)

trunk/abcl/src/org/armedbear/lisp/jvm.lisp

@@ -371 +371 @@
   vars
   free-specials
+  ;; Only used in TAGBODY
+  tags
   )
 
@@ -432 +434 @@
   ;; The associated TAGBODY
   block
-  (compiland *current-compiland*))
+  (compiland *current-compiland*)
+  used)
 
 (defknown find-tag (t) t)