* Added $fl=, $fl<, $fl>, $fl<=, $fl>= primops.

src/ikarus.intel-assembler.ss

@@ -496,6 +496,11 @@
       [(and (xmmreg? dst) (or (xmmreg? src) (mem? src)))
        (CODE #xF2 (CODE #x0F ((CODE/digit #x5E dst) src ac)))]
       [else (error who "invalid ~s" instr)])] 
+   [(ucomisd src dst)
+    (cond
+      [(and (xmmreg? dst) (or (xmmreg? src) (mem? src)))
+       (CODE #x66 (CODE #x0F ((CODE/digit #x2E dst) src ac)))]
+      [else (error who "invalid ~s" instr)])]
    [(addl src dst)
     (cond   
       [(and (imm8? src) (reg? dst)) 

src/ikarus.numerics.ss

@@ -338,19 +338,6 @@
     (binary/ (exact->inexact ($ratnum-n x)) 
              (exact->inexact ($ratnum-d x))))
 
-  #;
-  (begin
-    (define ($fl+ x y)
-      (foreign-call "ikrt_fl_plus" x y))
-    (define ($fl- x y)
-      (foreign-call "ikrt_fl_minus" x y))
-    (define ($fl* x y)
-      (foreign-call "ikrt_fl_times" x y))
-    (define ($fl/ x y)
-      (foreign-call "ikrt_fl_div" x y)))
-  
-
-
   (define binary+
     (lambda (x y)
       (cond
@@ -1187,16 +1174,18 @@
          (define-syntax bnfl? 
            (syntax-rules () [(_ x y) (fl? (bignum->flonum x) y)])))]))
 
-  (define-syntax $fl=
+ ;;;  #;
-    (syntax-rules () [(_ x y) (foreign-call "ikrt_fl_equal" x y)]))
+ ;;; (begin
-  (define-syntax $fl<
+ ;;;   (define-syntax $fl=
-    (syntax-rules () [(_ x y) (foreign-call "ikrt_fl_less" x y)]))
+ ;;;     (syntax-rules () [(_ x y) (foreign-call "ikrt_fl_equal" x y)]))
-  (define-syntax $fl<=
+ ;;;   (define-syntax $fl<
-    (syntax-rules () [(_ x y) (foreign-call "ikrt_fl_less_or_equal" x y)]))
+ ;;;     (syntax-rules () [(_ x y) (foreign-call "ikrt_fl_less" x y)]))
-  (define-syntax $fl>
+ ;;;   (define-syntax $fl<=
-    (syntax-rules () [(_ x y) (foreign-call "ikrt_fl_less" y x)]))
+ ;;;     (syntax-rules () [(_ x y) (foreign-call "ikrt_fl_less_or_equal" x y)]))
-  (define-syntax $fl>=
+ ;;;   (define-syntax $fl>
-    (syntax-rules () [(_ x y) (foreign-call "ikrt_fl_less_or_equal" y x)]))
+ ;;;     (syntax-rules () [(_ x y) (foreign-call "ikrt_fl_less" y x)]))
+ ;;;   (define-syntax $fl>=
+ ;;;     (syntax-rules () [(_ x y) (foreign-call "ikrt_fl_less_or_equal" y x)])))
 
   (define-syntax define-flcmp
     (syntax-rules ()

src/libaltcogen.ss

@@ -470,7 +470,6 @@
       [(bind lhs* rhs* e)
        (do-bind lhs* rhs* (P e))]
       [(primcall op rands)
-                (unless (pair? rands) (error 'car "ha ~s" x))
        (let ([a (car rands)] [b (cadr rands)])
          (cond
            [(and (constant? a) (constant? b))
@@ -2208,6 +2207,13 @@
         [(seq e0 e1) (make-seq (E e0) (P e1))]
         [(asm-instr op a b) 
          (cond
+           [(memq op '(fl:= fl:< fl:<= fl:> fl:>=)) 
+            (if (mem? a) 
+                (let ([u (mku)])
+                  (make-seq 
+                    (E (make-asm-instr 'move u a))
+                    (make-asm-instr op u b)))
+                x)]
            [(and (mem? a) (mem? b)) 
             (let ([u (mku)])
               (make-seq
@@ -2527,13 +2533,17 @@
          (define (notop x)
            (cond
              [(assq x '([= !=] [!= =] [< >=] [<= >] [> <=] [>= <]
-                        [u< u>=] [u<= u>] [u> u<=] [u>= u<]))
+                        [u< u>=] [u<= u>] [u> u<=] [u>= u<]
+                        [fl:= fl:!=] [fl:!= fl:=] 
+                        [fl:< fl:>=] [fl:<= fl:>] [fl:> fl:<=] [fl:>= fl:<]))
               => cadr]
              [else (error who "invalid op ~s" x)]))
          (define (jmpname x)
            (cond
              [(assq x '([= je] [!= jne] [< jl] [<= jle] [> jg] [>= jge]
-                        [u< jb] [u<= jbe] [u> ja] [u>= jae]))
+                        [u< jb] [u<= jbe] [u> ja] [u>= jae]
+                        [fl:= je] [fl:!= jne]
+                        [fl:< jl] [fl:> jg] [fl:<= jle] [fl:>= jge]))
               => cadr]
              [else (error who "invalid jmpname ~s" x)]))
          (define (revjmpname x)
@@ -2544,6 +2554,10 @@
              [else (error who "invalid jmpname ~s" x)]))
          (define (cmp op a0 a1 lab ac)
            (cond
+             [(memq op '(fl:= fl:!= fl:< fl:<= fl:> fl:>=))
+              (list* `(ucomisd ,(R (make-disp a0 a1)) xmm0)
+                     `(,(jmpname op) ,lab)
+                     ac)]
              [(or (symbol? a0) (constant? a1))
               (list* `(cmpl ,(R a1) ,(R a0))
                      `(,(jmpname op) ,lab)

src/makefile.ss

@@ -607,6 +607,11 @@
     [$fl-                           $flonums]
     [$fl*                           $flonums]
     [$fl/                           $flonums]
+    [$fl=                           $flonums]
+    [$fl<                           $flonums]
+    [$fl<=                           $flonums]
+    [$fl>                           $flonums]
+    [$fl>=                           $flonums]
 
     [$make-bignum       $bignums]
     [$bignum-positive?  $bignums]

src/pass-specify-rep-primops.ss

@@ -729,6 +729,11 @@
      (prm 'fl:store x (K (- disp-flonum-data vector-tag)))
      x))
 
+(define ($flcmp-aux op fl0 fl1)
+  (make-seq 
+    (prm 'fl:load (T fl0) (K (- disp-flonum-data vector-tag)))
+    (prm op (T fl1) (K (- disp-flonum-data vector-tag)))))
+
 (define-primop flonum? safe
   [(P x) (sec-tag-test (T x) vector-mask vector-tag #f flonum-tag)]
   [(E x) (nop)])
@@ -777,6 +782,17 @@
 (define-primop $fl/ unsafe
   [(V x y) ($flop-aux 'fl:div! x y)])
 
+(define-primop $fl= unsafe
+  [(P x y) ($flcmp-aux 'fl:= x y)])
+(define-primop $fl< unsafe
+  [(P x y) ($flcmp-aux 'fl:< x y)])
+(define-primop $fl<= unsafe
+  [(P x y) ($flcmp-aux 'fl:<= x y)])
+(define-primop $fl> unsafe
+  [(P x y) ($flcmp-aux 'fl:> x y)])
+(define-primop $fl>= unsafe
+  [(P x y) ($flcmp-aux 'fl:>= x y)])
+
 /section)
 
 (section ;;; ratnums