conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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

This commit is contained in:
Abdulaziz Ghuloum 2007-06-15 12:19:28 +03:00
parent d4facf79d3
commit 3f3767800d
6 changed files with 55 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

5
src/ikarus.intel-assembler.ss
View File

@ -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))

35
src/ikarus.numerics.ss
View File

@ -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 ()

20
src/libaltcogen.ss
View File

@ -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)

5
src/makefile.ss
View File

@ -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]

16
src/pass-specify-rep-primops.ss
View File

@ -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