[Guile-commits] 09/11: Use new instructions for less-than, etc

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit f8ac6809651343ea3e0b5104d817b6b2f3609aff
Author: Andy Wingo <address@hidden>
Date:   Fri Oct 27 16:12:42 2017 +0200

    Use new instructions for less-than, etc
    
    * module/language/cps/compile-bytecode.scm (compile-function): Use new
      instructions for generic numeric comparisons (< <= = >= >).
---
 module/language/cps/compile-bytecode.scm | 27 +++++++++++++++------------
 1 file changed, 15 insertions(+), 12 deletions(-)

diff --git a/module/language/cps/compile-bytecode.scm 
b/module/language/cps/compile-bytecode.scm
index b7e162b..2a1717c 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -394,24 +394,27 @@
             ;; Otherwise prefer a backwards
             ;; branch or a near jump.
             (< kt kf)))
-      (define (emit-branch-for-test)
+      (define (emit-branch emit-jt emit-jf)
         (cond
          ((eq? kt next-label)
-          (emit-jne asm kf))
+          (emit-jf asm kf))
          ((eq? kf next-label)
-          (emit-je asm kt))
+          (emit-jt asm kt))
          ((prefer-true?)
-          (emit-je asm kt)
+          (emit-jt asm kt)
           (emit-j asm kf))
          (else
-          (emit-jne asm kf)
+          (emit-jf asm kf)
           (emit-j asm kt))))
       (define (unary op a)
         (op asm (from-sp (slot a)))
-        (emit-branch-for-test))
+        (emit-branch emit-je emit-jne))
       (define (binary-test op a b)
         (op asm (from-sp (slot a)) (from-sp (slot b)))
-        (emit-branch-for-test))
+        (emit-branch emit-je emit-jne))
+      (define (binary* op emit-jt emit-jf a b)
+        (op asm (from-sp (slot a)) (from-sp (slot b)))
+        (emit-branch emit-jt emit-jf))
       (define (binary op a b)
         (cond
          ((eq? kt next-label)
@@ -443,11 +446,11 @@
         ;; the set of macro-instructions in assembly.scm.
         (($ $primcall 'eq? (a b)) (binary-test emit-eq? a b))
         (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b))
-        (($ $primcall '< (a b)) (binary emit-br-if-< a b))
-        (($ $primcall '<= (a b)) (binary emit-br-if-<= a b))
-        (($ $primcall '= (a b)) (binary emit-br-if-= a b))
-        (($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
-        (($ $primcall '> (a b)) (binary emit-br-if-< b a))
+        (($ $primcall '< (a b)) (binary* emit-<? emit-jl emit-jnl a b))
+        (($ $primcall '<= (a b)) (binary* emit-<? emit-jge emit-jnge b a))
+        (($ $primcall '= (a b)) (binary-test emit-=? a b))
+        (($ $primcall '>= (a b)) (binary* emit-<? emit-jge emit-jnge a b))
+        (($ $primcall '> (a b)) (binary* emit-<? emit-jl emit-jnl b a))
         (($ $primcall 'u64-< (a b)) (binary emit-br-if-u64-< a b))
         (($ $primcall 'u64-<= (a b)) (binary emit-br-if-u64-<= a b))
         (($ $primcall 'u64-= (a b)) (binary emit-br-if-u64-= a b))