Optimize trivial tagbody.

* share/txr/stdlib/tagbody.tl (tagbody): If the body contains
no labels, then emit a simple block. Note that we should just
be emitting a progn here; however, there is a bug in tagbody
in that there is an anonymous block. This is not documented,
and a consequence of the looping construct used. So for now we
preserve that behavior in the reduced case.

1 files changed, 37 insertions, 35 deletions

diff --git a/share/txr/stdlib/tagbody.tl b/share/txr/stdlib/tagbody.tl
index e580c91c..6fe24a19 100644
--- a/share/txr/stdlib/tagbody.tl
+++ b/share/txr/stdlib/tagbody.tl
@@ -33,41 +33,43 @@
            (entry-lbl (if start-lbl (caar bblocks) (gensym "entry-"))))
       (unless start-lbl
         (push entry-lbl (car bblocks)))
-      (let* ((lbls [mapcar car bblocks])
-             (forms [mapcar cdr bblocks])
-             ;; This trickery transform the individually labeled form
-             ;; blocks into branches, such that each branch falls through
-             ;; to the next one thanks to substructure sharing.
-             (threaded-1 (mapcar (op member-if true) (conses forms)))
-             (threaded-2 [apply nconc forms]) ;; important side effect
-             (codes [mapcar car threaded-1]))
-        (unless (eql (length (uniq lbls)) (length lbls))
-          (throwf 'eval-error "~s: duplicate labels occur" 'tagbody))
-        (let* ((basic-code ^(let ((,tb-id (gensym "tb-dyn-id-")))
-                              (for ((,next-var 0))
-                                   (,next-var)
-                                   ((set ,next-var
-                                         (block* ,tb-id
-                                           (sys:switch ,next-var #(,*codes))
-                                           nil))))))
-               ;; pass one: expand inner forms, including tagbody forms.
-               ;; if any inner tagbody forms leave (go ...) forms unexpanded,
-               ;; protect those (go ...)forms from falling victim to the
-               ;; global macro, by wrapping this with a harmless local go macro.
-               (pass-one (sys:expand ^(macrolet ((go (:form form label) form))
-                                        ,basic-code) env)))
-          ;; pass two: now expand the remaining go forms at this level, against
-          ;; this tagbody. If any go forms remain, they must refer to nonexistent
-          ;; labels. By calling sys:expand one more time, we flush these out
-          ;; using the global go macro --- unless we are nested inside the
-          ;; pass-one expansion of outer tagbody, which protects them!
-          ;; Thus, the outermost tagbody flushes out the undefined labels.
-          (sys:expand ^(macrolet ((go (:form form label)
-                                      (let ((index (posql label ',lbls)))
-                                        (cond
-                                          ((null index) form)
-                                          (t ^(return* ,',tb-id ,index))))))
-                         ,pass-one) env))))))
+      (if (and (not start-lbl) (not (cdr bblocks)))
+        ^(block nil ,*forms nil)
+        (let* ((lbls [mapcar car bblocks])
+               (forms [mapcar cdr bblocks])
+               ;; This trickery transform the individually labeled form
+               ;; blocks into branches, such that each branch falls through
+               ;; to the next one thanks to substructure sharing.
+               (threaded-1 (mapcar (op member-if true) (conses forms)))
+               (threaded-2 [apply nconc forms]) ;; important side effect
+               (codes [mapcar car threaded-1]))
+          (unless (eql (length (uniq lbls)) (length lbls))
+            (throwf 'eval-error "~s: duplicate labels occur" 'tagbody))
+          (let* ((basic-code ^(let ((,tb-id (gensym "tb-dyn-id-")))
+                                (for ((,next-var 0))
+                                     (,next-var)
+                                     ((set ,next-var
+                                           (block* ,tb-id
+                                             (sys:switch ,next-var #(,*codes))
+                                             nil))))))
+                 ;; pass one: expand inner forms, including tagbody forms.
+                 ;; if any inner tagbody forms leave (go ...) forms unexpanded,
+                 ;; protect those (go ...)forms from falling victim to the
+                 ;; global macro, by wrapping this with a harmless local go macro.
+                 (pass-one (sys:expand ^(macrolet ((go (:form form label) form))
+                                          ,basic-code) env)))
+            ;; pass two: now expand the remaining go forms at this level, against
+            ;; this tagbody. If any go forms remain, they must refer to nonexistent
+            ;; labels. By calling sys:expand one more time, we flush these out
+            ;; using the global go macro --- unless we are nested inside the
+            ;; pass-one expansion of outer tagbody, which protects them!
+            ;; Thus, the outermost tagbody flushes out the undefined labels.
+            (sys:expand ^(macrolet ((go (:form form label)
+                                        (let ((index (posql label ',lbls)))
+                                          (cond
+                                            ((null index) form)
+                                            (t ^(return* ,',tb-id ,index))))))
+                           ,pass-one) env)))))))
 
 (defmacro go (label)
   (if [[orf symbolp integerp chrp] label]