X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/b88fef5519fab447c6c5405928c248f9f0966148..26d148066f9cb20e395a7dc4fefdf2e2ef0b2fb0:/module/language/tree-il/compile-glil.scm

diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index 518823d11..1b6fea69c 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -1,6 +1,6 @@
 ;;; TREE-IL -> GLIL compiler
 
-;; Copyright (C) 2001,2008,2009,2010,2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001,2008,2009,2010,2011,2012,2013 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -27,6 +27,7 @@
   #:use-module (system vm instruction)
   #:use-module (language tree-il)
   #:use-module (language tree-il optimize)
+  #:use-module (language tree-il canonicalize)
   #:use-module (language tree-il analyze)
   #:use-module ((srfi srfi-1) #:select (filter-map))
   #:export (compile-glil))
@@ -64,6 +65,7 @@
   (let* ((x (make-lambda (tree-il-src x) '()
                          (make-lambda-case #f '() #f #f #f '() '() x #f)))
          (x (optimize! x e opts))
+         (x (canonicalize! x))
          (allocation (analyze-lexicals x)))
 
     (with-fluids ((*comp-module* e))
@@ -108,11 +110,15 @@
    ((list? . 1) . list?)
    ((symbol? . 1) . symbol?)
    ((vector? . 1) . vector?)
+   ((nil? . 1) . nil?)
    (list . list)
    (vector . vector)
    ((class-of . 1) . class-of)
    ((@slot-ref . 2) . slot-ref)
    ((@slot-set! . 3) . slot-set)
+   ((string-length . 1) . string-length)
+   ((string-ref . 2) . string-ref)
+   ((vector-length . 1) . vector-length)
    ((vector-ref . 2) . vector-ref)
    ((vector-set! . 3) . vector-set)
    ((variable-ref . 1) . variable-ref)
@@ -235,6 +241,24 @@
           (if (eq? context 'tail)
               (emit-code #f (make-glil-call 'return 1)))))
     
+    ;; After lexical binding forms in non-tail context, call this
+    ;; function to clear stack slots, allowing their previous values to
+    ;; be collected.
+    (define (clear-stack-slots context syms)
+      (case context
+        ((push drop)
+         (for-each (lambda (v)
+                     (and=>
+                      ;; Can be #f if the var is labels-allocated.
+                      (hashq-ref allocation v)
+                      (lambda (h)
+                        (pmatch (hashq-ref h self)
+                          ((#t _ . ,n)
+                           (emit-code #f (make-glil-void))
+                           (emit-code #f (make-glil-lexical #t #f 'set n)))
+                          (,loc (error "bad let var allocation" x loc))))))
+                   syms))))
+
     (record-case x
       ((<void>)
        (case context
@@ -248,200 +272,12 @@
           (emit-code src (make-glil-const exp))))
        (maybe-emit-return))
 
-      ;; FIXME: should represent sequence as exps tail
-      ((<sequence> exps)
-       (let lp ((exps exps))
-         (if (null? (cdr exps))
-             (comp-tail (car exps))
-             (begin
-               (comp-drop (car exps))
-               (lp (cdr exps))))))
-
-      ((<application> src proc args)
-       ;; FIXME: need a better pattern-matcher here
+      ((<seq> head tail)
+       (comp-drop head)
+       (comp-tail tail))
+      
+      ((<call> src proc args)
        (cond
-        ((and (primitive-ref? proc)
-              (eq? (primitive-ref-name proc) '@apply)
-              (>= (length args) 1))
-         (let ((proc (car args))
-               (args (cdr args)))
-           (cond
-            ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
-                  (not (eq? context 'push)) (not (eq? context 'vals)))
-             ;; tail: (lambda () (apply values '(1 2)))
-             ;; drop: (lambda () (apply values '(1 2)) 3)
-             ;; push: (lambda () (list (apply values '(10 12)) 1))
-             (case context
-               ((drop) (for-each comp-drop args) (maybe-emit-return))
-               ((tail)
-                (for-each comp-push args)
-                (emit-code src (make-glil-call 'return/values* (length args))))))
-
-            (else
-             (case context
-               ((tail)
-                (comp-push proc)
-                (for-each comp-push args)
-                (emit-code src (make-glil-call 'tail-apply (1+ (length args)))))
-               ((push)
-                (emit-code src (make-glil-call 'new-frame 0))
-                (comp-push proc)
-                (for-each comp-push args)
-                (emit-code src (make-glil-call 'apply (1+ (length args))))
-                (maybe-emit-return))
-               ((vals)
-                (comp-vals
-                 (make-application src (make-primitive-ref #f 'apply)
-                                   (cons proc args))
-                 MVRA)
-                (maybe-emit-return))
-               ((drop)
-                ;; Well, shit. The proc might return any number of
-                ;; values (including 0), since it's in a drop context,
-                ;; yet apply does not create a MV continuation. So we
-                ;; mv-call out to our trampoline instead.
-                (comp-drop
-                 (make-application src (make-primitive-ref #f 'apply)
-                                   (cons proc args)))
-                (maybe-emit-return)))))))
-        
-        ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values))
-         ;; tail: (lambda () (values '(1 2)))
-         ;; drop: (lambda () (values '(1 2)) 3)
-         ;; push: (lambda () (list (values '(10 12)) 1))
-         ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
-         (case context
-           ((drop) (for-each comp-drop args) (maybe-emit-return))
-           ((push)
-            (case (length args)
-              ((0)
-               ;; FIXME: This is surely an error.  We need to add a
-               ;; values-mismatch warning pass.
-               (emit-code src (make-glil-call 'new-frame 0))
-               (comp-push proc)
-               (emit-code src (make-glil-call 'call 0))
-               (maybe-emit-return))
-              ((1)
-               (comp-push (car args)))
-              (else
-               ;; Taking advantage of unspecified order of evaluation of
-               ;; arguments.
-               (for-each comp-drop (cdr args))
-               (comp-push (car args)))))
-           ((vals)
-            (for-each comp-push args)
-            (emit-code #f (make-glil-const (length args)))
-            (emit-branch src 'br MVRA))
-           ((tail)
-            (for-each comp-push args)
-            (emit-code src (let ((len (length args)))
-                             (if (= len 1)
-                                 (make-glil-call 'return 1)
-                                 (make-glil-call 'return/values len)))))))
-        
-        ((and (primitive-ref? proc)
-              (eq? (primitive-ref-name proc) '@call-with-values)
-              (= (length args) 2))
-	 ;; CONSUMER
-         ;; PRODUCER
-         ;; (mv-call MV)
-         ;; ([tail]-call 1)
-         ;; goto POST
-         ;; MV: [tail-]call/nargs
-         ;; POST: (maybe-drop)
-         (case context
-           ((vals)
-            ;; Fall back.
-            (comp-vals
-             (make-application src (make-primitive-ref #f 'call-with-values)
-                               args)
-             MVRA)
-            (maybe-emit-return))
-           (else
-            (let ((MV (make-label)) (POST (make-label))
-                  (producer (car args)) (consumer (cadr args)))
-              (if (not (eq? context 'tail))
-                  (emit-code src (make-glil-call 'new-frame 0)))
-              (comp-push consumer)
-              (emit-code src (make-glil-call 'new-frame 0))
-              (comp-push producer)
-              (emit-code src (make-glil-mv-call 0 MV))
-              (case context
-                ((tail) (emit-code src (make-glil-call 'tail-call 1)))
-                (else   (emit-code src (make-glil-call 'call 1))
-                        (emit-branch #f 'br POST)))
-              (emit-label MV)
-              (case context
-                ((tail) (emit-code src (make-glil-call 'tail-call/nargs 0)))
-                (else   (emit-code src (make-glil-call 'call/nargs 0))
-                        (emit-label POST)
-                        (if (eq? context 'drop)
-                            (emit-code #f (make-glil-call 'drop 1)))
-                        (maybe-emit-return)))))))
-
-        ((and (primitive-ref? proc)
-              (eq? (primitive-ref-name proc) '@call-with-current-continuation)
-              (= (length args) 1))
-         (case context
-           ((tail)
-            (comp-push (car args))
-            (emit-code src (make-glil-call 'tail-call/cc 1)))
-           ((vals)
-            (comp-vals
-             (make-application
-              src (make-primitive-ref #f 'call-with-current-continuation)
-              args)
-             MVRA)
-            (maybe-emit-return))
-           ((push)
-            (comp-push (car args))
-            (emit-code src (make-glil-call 'call/cc 1))
-            (maybe-emit-return))
-           ((drop)
-            ;; Crap. Just like `apply' in drop context.
-            (comp-drop
-             (make-application
-              src (make-primitive-ref #f 'call-with-current-continuation)
-              args))
-            (maybe-emit-return))))
-
-        ;; A hack for variable-set, the opcode for which takes its args
-        ;; reversed, relative to the variable-set! function
-        ((and (primitive-ref? proc)
-              (eq? (primitive-ref-name proc) 'variable-set!)
-              (= (length args) 2))
-         (comp-push (cadr args))
-         (comp-push (car args))
-         (emit-code src (make-glil-call 'variable-set 2))
-         (case context
-           ((tail push vals) (emit-code #f (make-glil-void))))
-         (maybe-emit-return))
-        
-        ((and (primitive-ref? proc)
-              (or (hash-ref *primcall-ops*
-                            (cons (primitive-ref-name proc) (length args)))
-                  (hash-ref *primcall-ops* (primitive-ref-name proc))))
-         => (lambda (op)
-              (for-each comp-push args)
-              (emit-code src (make-glil-call op (length args)))
-              (case (instruction-pushes op)
-                ((0)
-                 (case context
-                   ((tail push vals) (emit-code #f (make-glil-void))))
-                 (maybe-emit-return))
-                ((1)
-                 (case context
-                   ((drop) (emit-code #f (make-glil-call 'drop 1))))
-                 (maybe-emit-return))
-                ((-1)
-                 ;; A control instruction, like return/values.  Here we
-                 ;; just have to hope that the author of the tree-il
-                 ;; knew what they were doing.
-                 *unspecified*)
-                (else
-                 (error "bad primitive op: too many pushes"
-                        op (instruction-pushes op))))))
-        
         ;; call to the same lambda-case in tail position
         ((and (lexical-ref? proc)
               self-label (eq? (lexical-ref-gensym proc) self-label)
@@ -508,9 +344,20 @@
          (for-each comp-push args)
          (let ((len (length args)))
            (case context
-             ((tail) (emit-code src (make-glil-call 'tail-call len)))
-             ((push) (emit-code src (make-glil-call 'call len))
+             ((tail) (if (<= len #xff)
+                         (emit-code src (make-glil-call 'tail-call len))
+                         (begin
+                           (comp-push (make-const #f len))
+                           (emit-code src (make-glil-call 'tail-call/nargs 0)))))
+             ((push) (if (<= len #xff)
+                         (emit-code src (make-glil-call 'call len))
+                         (begin
+                           (comp-push (make-const #f len))
+                           (emit-code src (make-glil-call 'call/nargs 0))))
                      (maybe-emit-return))
+             ;; FIXME: mv-call doesn't have a /nargs variant, so it is
+             ;; limited to 255 args.  Can work around it with a
+             ;; trampoline and tail-call/nargs, but it's not so nice.
              ((vals) (emit-code src (make-glil-mv-call len MVRA))
                      (maybe-emit-return))
              ((drop) (let ((MV (make-label)) (POST (make-label)))
@@ -523,6 +370,157 @@
                            (emit-branch #f 'br RA)
                            (emit-label POST)))))))))
 
+      ((<primcall> src name args)
+       (pmatch (cons name args)
+         ((@apply ,proc . ,args)
+          (cond
+           ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
+                 (not (eq? context 'push)) (not (eq? context 'vals)))
+            ;; tail: (lambda () (apply values '(1 2)))
+            ;; drop: (lambda () (apply values '(1 2)) 3)
+            ;; push: (lambda () (list (apply values '(10 12)) 1))
+            (case context
+              ((drop) (for-each comp-drop args) (maybe-emit-return))
+              ((tail)
+               (for-each comp-push args)
+               (emit-code src (make-glil-call 'return/values* (length args))))))
+
+           (else
+            (case context
+              ((tail)
+               (comp-push proc)
+               (for-each comp-push args)
+               (emit-code src (make-glil-call 'tail-apply (1+ (length args)))))
+              ((push)
+               (emit-code src (make-glil-call 'new-frame 0))
+               (comp-push proc)
+               (for-each comp-push args)
+               (emit-code src (make-glil-call 'apply (1+ (length args))))
+               (maybe-emit-return))
+              (else
+               (comp-tail (make-primcall src 'apply (cons proc args))))))))
+
+         ((values . _)
+          ;; tail: (lambda () (values '(1 2)))
+          ;; drop: (lambda () (values '(1 2)) 3)
+          ;; push: (lambda () (list (values '(10 12)) 1))
+          ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
+          (case context
+            ((drop) (for-each comp-drop args) (maybe-emit-return))
+            ((push)
+             (case (length args)
+               ((0)
+                ;; FIXME: This is surely an error.  We need to add a
+                ;; values-mismatch warning pass.
+                (comp-push (make-call src (make-primitive-ref #f 'values)
+                                      '())))
+               (else
+                ;; Taking advantage of unspecified order of evaluation of
+                ;; arguments.
+                (for-each comp-drop (cdr args))
+                (comp-push (car args))
+                (maybe-emit-return))))
+            ((vals)
+             (for-each comp-push args)
+             (emit-code #f (make-glil-const (length args)))
+             (emit-branch src 'br MVRA))
+            ((tail)
+             (for-each comp-push args)
+             (emit-code src (let ((len (length args)))
+                              (if (= len 1)
+                                  (make-glil-call 'return 1)
+                                  (make-glil-call 'return/values len)))))))
+        
+         ((@call-with-values ,producer ,consumer)
+          ;; CONSUMER
+          ;; PRODUCER
+          ;; (mv-call MV)
+          ;; ([tail]-call 1)
+          ;; goto POST
+          ;; MV: [tail-]call/nargs
+          ;; POST: (maybe-drop)
+          (case context
+            ((vals)
+             ;; Fall back.
+             (comp-tail (make-primcall src 'call-with-values args)))
+            (else
+             (let ((MV (make-label)) (POST (make-label)))
+               (if (not (eq? context 'tail))
+                   (emit-code src (make-glil-call 'new-frame 0)))
+               (comp-push consumer)
+               (emit-code src (make-glil-call 'new-frame 0))
+               (comp-push producer)
+               (emit-code src (make-glil-mv-call 0 MV))
+               (case context
+                 ((tail) (emit-code src (make-glil-call 'tail-call 1)))
+                 (else   (emit-code src (make-glil-call 'call 1))
+                         (emit-branch #f 'br POST)))
+               (emit-label MV)
+               (case context
+                 ((tail) (emit-code src (make-glil-call 'tail-call/nargs 0)))
+                 (else   (emit-code src (make-glil-call 'call/nargs 0))
+                         (emit-label POST)
+                         (if (eq? context 'drop)
+                             (emit-code #f (make-glil-call 'drop 1)))
+                         (maybe-emit-return)))))))
+
+         ((@call-with-current-continuation ,proc)
+          (case context
+            ((tail)
+             (comp-push proc)
+             (emit-code src (make-glil-call 'tail-call/cc 1)))
+            ((vals)
+             (comp-vals
+              (make-primcall src 'call-with-current-continuation args)
+              MVRA)
+             (maybe-emit-return))
+            ((push)
+             (comp-push proc)
+             (emit-code src (make-glil-call 'call/cc 1))
+             (maybe-emit-return))
+            ((drop)
+             ;; Fall back.
+             (comp-tail
+              (make-primcall src 'call-with-current-continuation args)))))
+         
+        ;; A hack for variable-set, the opcode for which takes its args
+        ;; reversed, relative to the variable-set! function
+        ((variable-set! ,var ,val)
+         (comp-push val)
+         (comp-push var)
+         (emit-code src (make-glil-call 'variable-set 2))
+         (case context
+           ((tail push vals) (emit-code #f (make-glil-void))))
+         (maybe-emit-return))
+        
+        (else
+         (cond
+          ((or (hash-ref *primcall-ops* (cons name (length args)))
+               (hash-ref *primcall-ops* name))
+           => (lambda (op)
+                (for-each comp-push args)
+                (emit-code src (make-glil-call op (length args)))
+                (case (instruction-pushes op)
+                  ((0)
+                   (case context
+                     ((tail push vals) (emit-code #f (make-glil-void))))
+                   (maybe-emit-return))
+                  ((1)
+                   (case context
+                     ((drop) (emit-code #f (make-glil-call 'drop 1))))
+                   (maybe-emit-return))
+                  ((-1)
+                   ;; A control instruction, like return/values.  Here we
+                   ;; just have to hope that the author of the tree-il
+                   ;; knew what they were doing.
+                   *unspecified*)
+                  (else
+                   (error "bad primitive op: too many pushes"
+                          op (instruction-pushes op))))))
+          (else
+           ;; Fall back to the normal compilation strategy.
+           (comp-tail (make-call src (make-primitive-ref #f name) args)))))))
+
       ((<conditional> src test consequent alternate)
        ;;     TEST
        ;;     (br-if-not L1)
@@ -531,54 +529,39 @@
        ;; L1: alternate
        ;; L2:
        (let ((L1 (make-label)) (L2 (make-label)))
-         ;; need a pattern matcher
          (record-case test
-           ((<application> proc args)
-            (record-case proc
-              ((<primitive-ref> name)
-               (let ((len (length args)))
-                 (cond
-
-                  ((and (eq? name 'eq?) (= len 2))
-                   (comp-push (car args))
-                   (comp-push (cadr args))
-                   (emit-branch src 'br-if-not-eq L1))
-
-                  ((and (eq? name 'null?) (= len 1))
-                   (comp-push (car args))
-                   (emit-branch src 'br-if-not-null L1))
-
-                  ((and (eq? name 'not) (= len 1))
-                   (let ((app (car args)))
-                     (record-case app
-                       ((<application> proc args)
-                        (let ((len (length args)))
-                          (record-case proc
-                            ((<primitive-ref> name)
-                             (cond
-
-                              ((and (eq? name 'eq?) (= len 2))
-                               (comp-push (car args))
-                               (comp-push (cadr args))
-                               (emit-branch src 'br-if-eq L1))
-                            
-                              ((and (eq? name 'null?) (= len 1))
-                               (comp-push (car args))
-                               (emit-branch src 'br-if-null L1))
-
-                              (else
-                               (comp-push app)
-                               (emit-branch src 'br-if L1))))
-                            (else
-                             (comp-push app)
-                             (emit-branch src 'br-if L1)))))
-                       (else
-                        (comp-push app)
-                        (emit-branch src 'br-if L1)))))
-                  
-                  (else
-                   (comp-push test)
-                   (emit-branch src 'br-if-not L1)))))
+           ((<primcall> name args)
+            (pmatch (cons name args)
+              ((eq? ,a ,b)
+               (comp-push a)
+               (comp-push b)
+               (emit-branch src 'br-if-not-eq L1))
+              ((null? ,x)
+               (comp-push x)
+               (emit-branch src 'br-if-not-null L1))
+              ((nil? ,x)
+               (comp-push x)
+               (emit-branch src 'br-if-not-nil L1))
+              ((not ,x)
+               (record-case x
+                 ((<primcall> name args)
+                  (pmatch (cons name args)
+                    ((eq? ,a ,b)
+                     (comp-push a)
+                     (comp-push b)
+                     (emit-branch src 'br-if-eq L1))
+                    ((null? ,x)
+                     (comp-push x)
+                     (emit-branch src 'br-if-null L1))
+                    ((nil? ,x)
+                     (comp-push x)
+                     (emit-branch src 'br-if-nil L1))
+                    (else
+                     (comp-push x)
+                     (emit-branch src 'br-if L1))))
+                 (else
+                  (comp-push x)
+                  (emit-branch src 'br-if L1))))
               (else
                (comp-push test)
                (emit-branch src 'br-if-not L1))))
@@ -800,6 +783,7 @@
                      (,loc (error "bad let var allocation" x loc))))
                  (reverse gensyms))
        (comp-tail body)
+       (clear-stack-slots context gensyms)
        (emit-code #f (make-glil-unbind)))
 
       ((<letrec> src in-order? names gensyms vals body)
@@ -832,6 +816,7 @@
                        (,loc (error "bad letrec var allocation" x loc))))
                    (reverse gensyms))))
        (comp-tail body)
+       (clear-stack-slots context gensyms)
        (emit-code #f (make-glil-unbind)))
 
       ((<fix> src names gensyms vals body)
@@ -920,6 +905,7 @@
          (comp-tail body)
          (if new-RA
              (emit-label new-RA))
+         (clear-stack-slots context gensyms)
          (emit-code #f (make-glil-unbind))))
 
       ((<let-values> src exp body)
@@ -945,16 +931,41 @@
                           (,loc (error "bad let-values var allocation" x loc))))
                       (reverse gensyms))
             (comp-tail body)
+            (clear-stack-slots context gensyms)
             (emit-code #f (make-glil-unbind))))))
 
       ;; much trickier than i thought this would be, at first, due to the need
       ;; to have body's return value(s) on the stack while the unwinder runs,
       ;; then proceed with returning or dropping or what-have-you, interacting
       ;; with RA and MVRA. What have you, I say.
-      ((<dynwind> src body winder unwinder)
+      ((<dynwind> src winder pre body post unwinder)
+       (define (thunk? x)
+         (and (lambda? x)
+              (null? (lambda-case-gensyms (lambda-body x)))))
+       (define (make-wrong-type-arg x)
+         (make-primcall src 'scm-error
+                        (list
+                         (make-const #f 'wrong-type-arg)
+                         (make-const #f "dynamic-wind")
+                         (make-const #f "Wrong type (expecting thunk): ~S")
+                         (make-primcall #f 'list (list x))
+                         (make-primcall #f 'list (list x)))))
+       (define (emit-thunk-check x)
+         (comp-drop (make-conditional
+                     src
+                     (make-primcall src 'thunk? (list x))
+                     (make-void #f)
+                     (make-wrong-type-arg x))))
+
+       ;; We know at this point that `winder' and `unwinder' are
+       ;; constant expressions and can be duplicated.
+       (if (not (thunk? winder))
+           (emit-thunk-check winder))
        (comp-push winder)
+       (if (not (thunk? unwinder))
+           (emit-thunk-check unwinder))
        (comp-push unwinder)
-       (comp-drop (make-application src winder '()))
+       (comp-drop pre)
        (emit-code #f (make-glil-call 'wind 2))
 
        (case context
@@ -963,14 +974,14 @@
             (comp-vals body MV)
             ;; one value: unwind...
             (emit-code #f (make-glil-call 'unwind 0))
-            (comp-drop (make-application src unwinder '()))
+            (comp-drop post)
             ;; ...and return the val
             (emit-code #f (make-glil-call 'return 1))
             
             (emit-label MV)
             ;; multiple values: unwind...
             (emit-code #f (make-glil-call 'unwind 0))
-            (comp-drop (make-application src unwinder '()))
+            (comp-drop post)
             ;; and return the values.
             (emit-code #f (make-glil-call 'return/nvalues 1))))
          
@@ -979,7 +990,7 @@
           (comp-push body)
           ;; and unwind, leaving the val on the stack
           (emit-code #f (make-glil-call 'unwind 0))
-          (comp-drop (make-application src unwinder '())))
+          (comp-drop post))
          
          ((vals)
           (let ((MV (make-label)))
@@ -990,7 +1001,7 @@
             (emit-label MV)
             ;; multiple values: unwind...
             (emit-code #f (make-glil-call 'unwind 0))
-            (comp-drop (make-application src unwinder '()))
+            (comp-drop post)
             ;; and goto the MVRA.
             (emit-branch #f 'br MVRA)))
          
@@ -998,7 +1009,7 @@
           ;; compile body, discarding values. then unwind...
           (comp-drop body)
           (emit-code #f (make-glil-call 'unwind 0))
-          (comp-drop (make-application src unwinder '()))
+          (comp-drop post)
           ;; and fall through, or goto RA if there is one.
           (if RA
               (emit-branch #f 'br RA)))))