[Guile-commits] 02/12: Refactor numeric comparison bytecode emission

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 8b3258716cc456ad6adeb5c45e6b4910a5e4f4b6
Author: Andy Wingo <address@hidden>
Date:   Mon Nov 6 21:44:31 2017 +0100

    Refactor numeric comparison bytecode emission
    
    * module/language/cps/compile-bytecode.scm (compile-function): Refactor.
---
 module/language/cps/compile-bytecode.scm | 36 ++++++++++++++++++--------------
 1 file changed, 20 insertions(+), 16 deletions(-)

diff --git a/module/language/cps/compile-bytecode.scm 
b/module/language/cps/compile-bytecode.scm
index 1284e65..8e61604 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -419,6 +419,10 @@
         (emit-branch emit-jt emit-jf))
       (define (binary-test op a b)
         (binary op emit-je emit-jne a b))
+      (define (binary-< emit-<? a b)
+        (binary emit-<? emit-jl emit-jnl a b))
+      (define (binary->= emit-<? a b)
+        (binary emit-<? emit-jge emit-jnge a b))
       (match exp
         (($ $primcall 'heap-object? #f (a)) (unary emit-heap-object? a))
         (($ $primcall 'null? #f (a)) (unary emit-null? a))
@@ -442,26 +446,26 @@
         (($ $primcall 'eq? #f (a b)) (binary-test emit-eq? a b))
         (($ $primcall 'heap-numbers-equal? #f (a b))
          (binary-test emit-heap-numbers-equal? a b))
-        (($ $primcall '< #f (a b)) (binary emit-<? emit-jl emit-jnl a b))
-        (($ $primcall '<= #f (a b)) (binary emit-<? emit-jge emit-jnge b a))
+        (($ $primcall '< #f (a b)) (binary-< emit-<? a b))
+        (($ $primcall '<= #f (a b)) (binary->= emit-<? b a))
         (($ $primcall '= #f (a b)) (binary-test emit-=? a b))
-        (($ $primcall '>= #f (a b)) (binary emit-<? emit-jge emit-jnge a b))
-        (($ $primcall '> #f (a b)) (binary emit-<? emit-jl emit-jnl b a))
-        (($ $primcall 'u64-< #f (a b)) (binary emit-u64<? emit-jl emit-jnl a 
b))
-        (($ $primcall 'u64-<= #f (a b)) (binary emit-u64<? emit-jnl emit-jl b 
a))
+        (($ $primcall '>= #f (a b)) (binary->= emit-<? a b))
+        (($ $primcall '> #f (a b)) (binary-< emit-<? b a))
+        (($ $primcall 'u64-< #f (a b)) (binary-< emit-u64<? a b))
+        (($ $primcall 'u64-<= #f (a b)) (binary->= emit-u64<? b a))
         (($ $primcall 'u64-= #f (a b)) (binary-test emit-u64=? a b))
-        (($ $primcall 'u64->= #f (a b)) (binary emit-u64<? emit-jnl emit-jl a 
b))
-        (($ $primcall 'u64-> #f (a b)) (binary emit-u64<? emit-jl emit-jnl b 
a))
-        (($ $primcall 's64-< #f (a b)) (binary emit-s64<? emit-jl emit-jnl a 
b))
-        (($ $primcall 's64-<= #f (a b)) (binary emit-s64<? emit-jnl emit-jl b 
a))
+        (($ $primcall 'u64->= #f (a b)) (binary->= emit-u64<? a b))
+        (($ $primcall 'u64-> #f (a b)) (binary-< emit-u64<? b a))
+        (($ $primcall 's64-< #f (a b)) (binary-< emit-s64<? a b))
+        (($ $primcall 's64-<= #f (a b)) (binary->= emit-s64<? b a))
         (($ $primcall 's64-= #f (a b)) (binary-test emit-s64=? a b))
-        (($ $primcall 's64->= #f (a b)) (binary emit-s64<? emit-jnl emit-jl a 
b))
-        (($ $primcall 's64-> #f (a b)) (binary emit-s64<? emit-jl emit-jnl b 
a))
-        (($ $primcall 'f64-< #f (a b)) (binary emit-f64<? emit-jl emit-jnl a 
b))
-        (($ $primcall 'f64-<= #f (a b)) (binary emit-f64<? emit-jge emit-jnge 
b a))
+        (($ $primcall 's64->= #f (a b)) (binary->= emit-s64<? a b))
+        (($ $primcall 's64-> #f (a b)) (binary-< emit-s64<? b a))
+        (($ $primcall 'f64-< #f (a b)) (binary-< emit-f64<? a b))
+        (($ $primcall 'f64-<= #f (a b)) (binary->= emit-f64<? b a))
         (($ $primcall 'f64-= #f (a b)) (binary-test emit-f64=? a b))
-        (($ $primcall 'f64->= #f (a b)) (binary emit-f64<? emit-jge emit-jnge 
a b))
-        (($ $primcall 'f64-> #f (a b)) (binary emit-f64<? emit-jl emit-jnl b 
a))))
+        (($ $primcall 'f64->= #f (a b)) (binary->= emit-f64<? a b))
+        (($ $primcall 'f64-> #f (a b)) (binary-< emit-f64<? b a))))
 
     (define (compile-trunc label k exp nreq rest-var)
       (define (do-call proc args emit-call)