Optimize branches in the evaluator

* module/ice-9/eval.scm (primitive-eval): Factor out primitive=?
  helper.  Simplify compile-top-call.  Add compile-top-branch for
  primcall branches, so the compiler can see the specialized branch
  operator.

module/ice-9/eval.scm

@@ -122,10 +122,7 @@
     (lambda (env)
       (env-ref env depth width)))
 
-  (define (compile-top-call cenv loc args)
+  (define (primitive=? name loc module var)
-    (let* ((module (env-toplevel cenv))
-           (var (%resolve-variable loc module)))
-      (define (primitive=? name)
     "Return true if VAR is the same as the primitive bound to NAME."
     (match loc
       ((mode . loc)
@@ -136,35 +133,31 @@
             ;; booted when the environment was captured.
             (or (not module)
                 (eq? var (module-local-variable the-root-module name)))))))
+
+  (define (compile-top-call cenv loc args)
+    (let* ((module (env-toplevel cenv))
+           (var (%resolve-variable loc module)))
       (define-syntax-rule (maybe-primcall (prim ...) arg ...)
+        (let ((arg (compile arg))
+              ...)
           (cond
-         ((primitive=? 'prim) (lambda (env) (prim (arg env) ...)))
+           ((primitive=? 'prim loc module var)
+            (lambda (env) (prim (arg env) ...)))
            ...
-         (else (lambda (env) ((variable-ref var) (arg env) ...)))))
+           (else (lambda (env) ((variable-ref var) (arg env) ...))))))
       (match args
         (()
          (lambda (env) ((variable-ref var))))
         ((a)
-         (let ((a (compile a)))
+         (maybe-primcall (1+ 1- car cdr lognot vector-length
-           (maybe-primcall
-            (null? nil? pair? struct? string? vector? symbol?
-             keyword? variable? bitvector? char? zero?
-             1+ 1- car cdr lognot not vector-length
                           variable-ref string-length struct-vtable)
-            a)))
+                         a))
         ((a b)
-         (let ((a (compile a))
+         (maybe-primcall (+ - * / ash logand logior logxor
-               (b (compile b)))
-           (maybe-primcall
-            (+ - * / eq? eqv? equal? = < > <= >=
-               ash logand logior logxor logtest logbit?
                           cons vector-ref struct-ref allocate-struct variable-set!)
-            a b)))
+                         a b))
         ((a b c)
-         (let ((a (compile a))
+         (maybe-primcall (vector-set! struct-set!) a b c))
-               (b (compile b))
-               (c (compile c)))
-           (maybe-primcall (vector-set! struct-set!) a b c)))
         ((a b c . args)
          (let ((a (compile a))
                (b (compile b))
@@ -237,12 +230,49 @@
     (let ((var (%resolve-variable loc (env-toplevel cenv))))
       (lambda (env) var)))
 
+  (define (compile-top-branch cenv loc args consequent alternate)
+    (let* ((module (env-toplevel cenv))
+           (var (%resolve-variable loc module))
+           (consequent (compile consequent))
+           (alternate (compile alternate)))
+      (define (generic-top-branch)
+        (let ((test (compile-top-call cenv loc args)))
+          (lambda (env)
+            (if (test env) (consequent env) (alternate env)))))
+      (define-syntax-rule (maybe-primcall (prim ...) arg ...)
+        (cond
+         ((primitive=? 'prim loc module var)
+          (let ((arg (compile arg))
+                ...)
+            (lambda (env)
+              (if (prim (arg env) ...)
+                  (consequent env)
+                  (alternate env)))))
+         ...
+         (else (generic-top-branch))))
+      (match args
+        ((a)
+         (maybe-primcall (null? nil? pair? struct? string? vector? symbol?
+                          keyword? variable? bitvector? char? zero? not)
+                         a))
+        ((a b)
+         (maybe-primcall (eq? eqv? equal? = < > <= >= logtest logbit?)
+                         a b))
+        (_
+         (generic-top-branch)))))
+
   (define (compile-if test consequent alternate)
+    (match test
+      ((,(typecode call)
+        (,(typecode box-ref) . (,(typecode resolve) . loc))
+        . args)
+       (lazy (env) (compile-top-branch env loc args consequent alternate)))
+      (_
        (let ((test (compile test))
              (consequent (compile consequent))
              (alternate (compile alternate)))
          (lambda (env)
-        (if (test env) (consequent env) (alternate env)))))
+           (if (test env) (consequent env) (alternate env)))))))
 
   (define (compile-quote x)
     (lambda (env) x))