diff --git a/src/ikarus.boot b/src/ikarus.boot index 1a8d1b4..6608e8b 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/ikarus.intel-assembler.ss b/src/ikarus.intel-assembler.ss index 19c650b..a9a6e60 100644 --- a/src/ikarus.intel-assembler.ss +++ b/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)) diff --git a/src/ikarus.numerics.ss b/src/ikarus.numerics.ss index 0fa5dc7..e414cf6 100644 --- a/src/ikarus.numerics.ss +++ b/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)])) - (define-syntax $fl< - (syntax-rules () [(_ x y) (foreign-call "ikrt_fl_less" x y)])) - (define-syntax $fl<= - (syntax-rules () [(_ x y) (foreign-call "ikrt_fl_less_or_equal" x y)])) - (define-syntax $fl> - (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)])) + ;;; #; + ;;; (begin + ;;; (define-syntax $fl= + ;;; (syntax-rules () [(_ x y) (foreign-call "ikrt_fl_equal" x y)])) + ;;; (define-syntax $fl< + ;;; (syntax-rules () [(_ x y) (foreign-call "ikrt_fl_less" x y)])) + ;;; (define-syntax $fl<= + ;;; (syntax-rules () [(_ x y) (foreign-call "ikrt_fl_less_or_equal" x y)])) + ;;; (define-syntax $fl> + ;;; (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 () diff --git a/src/libaltcogen.ss b/src/libaltcogen.ss index f1b05d3..e18e8c1 100644 --- a/src/libaltcogen.ss +++ b/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) diff --git a/src/makefile.ss b/src/makefile.ss index fde54aa..28cced3 100755 --- a/src/makefile.ss +++ b/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] diff --git a/src/pass-specify-rep-primops.ss b/src/pass-specify-rep-primops.ss index a6fd80b..f41426a 100644 --- a/src/pass-specify-rep-primops.ss +++ b/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