From 62d3430cb618e8d45b0e72d195fdee6e2550ea91 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Tue, 13 Aug 2013 09:03:23 -0400
Subject: [PATCH] Convert branchable primitives into binary operations only.

* module/language/tree-il/primitives.scm (maybe-simplify-to-eq): Wrap
  within another lambda, binding the primitive name.  If there are less
  than two arguments, expand to constant #t.  If there are more than two
  arguments, convert into a conjunction of binary applications.
  (expand-chained-comparisons): New procedure.
  (*primitive-expand-table*): Add entries for (< <= = >= > eq?).
---
 module/language/tree-il/primitives.scm | 28 +++++++++++++++++++++++---
 1 file changed, 25 insertions(+), 3 deletions(-)

diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index 06b7a110f..0fe444567 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -509,8 +509,10 @@
   (bytevector-ieee-double-native-set! vec (* i 8) x))
 
 ;; Appropriate for use with either 'eqv?' or 'equal?'.
-(define maybe-simplify-to-eq
+(define (maybe-simplify-to-eq prim)
   (case-lambda
+    ((src) (make-const src #t))
+    ((src a) (make-const src #t))
     ((src a b)
      ;; Simplify cases where either A or B is constant.
      (define (maybe-simplify a b)
@@ -524,10 +526,30 @@
                             (>= v most-negative-fixnum)))
                    (make-primcall src 'eq? (list a b))))))
      (or (maybe-simplify a b) (maybe-simplify b a)))
+    ((src a b . rest)
+     (make-conditional src (make-primcall src prim (list a b))
+                       (make-primcall src prim (cons b rest))
+                       (make-const src #f)))
     (else #f)))
 
-(hashq-set! *primitive-expand-table* 'eqv?   maybe-simplify-to-eq)
-(hashq-set! *primitive-expand-table* 'equal? maybe-simplify-to-eq)
+(hashq-set! *primitive-expand-table* 'eqv?   (maybe-simplify-to-eq 'eqv?))
+(hashq-set! *primitive-expand-table* 'equal? (maybe-simplify-to-eq 'equal?))
+
+(define (expand-chained-comparisons prim)
+  (case-lambda
+    ((src) (make-const src #t))
+    ((src a) (make-const src #t))
+    ((src a b) #f)
+    ((src a b . rest)
+     (make-conditional src (make-primcall src prim (list a b))
+                       (make-primcall src prim (cons b rest))
+                       (make-const src #f)))
+    (else #f)))
+
+(for-each (lambda (prim)
+            (hashq-set! *primitive-expand-table* prim
+                        (expand-chained-comparisons prim)))
+ '(< <= = >= > eq?))
 
 (hashq-set! *primitive-expand-table*
             'call-with-prompt