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

* $fixnum->flonum now works.

This commit is contained in:
Abdulaziz Ghuloum 2007-06-18 14:29:39 +03:00
parent d3b2ee35f3
commit dd1634e755
5 changed files with 32 additions and 18 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.

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

@ -478,6 +478,13 @@
[(and (xmmreg? src) (or (xmmreg? dst) (mem? dst)))
(CODE #xF2 (CODE #x0F ((CODE/digit #x11 src) dst ac)))]
[else (error who "invalid ~s" instr)])]
[(cvtsi2sd src dst)
(cond
[(and (xmmreg? dst) (reg? src))
(CODE #xF2 (CODE #x0F (CODE #x2A (ModRM 3 src dst ac))))]
[(and (xmmreg? dst) (mem? src))
(CODE #xF2 (CODE #x0F ((CODE/digit #x2A dst) src ac)))]
[else (error who "invalid ~s" instr)])]
[(addsd src dst)
(cond
[(and (xmmreg? dst) (or (xmmreg? src) (mem? src)))

25
src/ikarus.numerics.ss
View File

@ -152,8 +152,7 @@
sin cos atan sqrt
flround flmax))
(define (fixnum->flonum x)
(foreign-call "ikrt_fixnum_to_flonum" x))
; (foreign-call "ikrt_fixnum_to_flonum" x))
(module (bignum->flonum)
; sbe f6 f5 f4 f3 f2 f1 f0
@ -362,7 +361,7 @@
[(bignum? y)
(foreign-call "ikrt_fxbnplus" x y)]
[(flonum? y)
($fl+ (fixnum->flonum x) y)]
($fl+ ($fixnum->flonum x) y)]
[(ratnum? y)
($make-ratnum
(+ (* x ($ratnum-d y)) ($ratnum-n y))
@ -386,7 +385,7 @@
[(flonum? x)
(cond
[(fixnum? y)
($fl+ x (fixnum->flonum y))]
($fl+ x ($fixnum->flonum y))]
[(bignum? y)
($fl+ x (bignum->flonum y))]
[(flonum? y)
@ -445,7 +444,7 @@
[(flonum? y)
(if ($fx= x 0)
($fl* y -1.0)
($fl- (fixnum->flonum x) y))]
($fl- ($fixnum->flonum x) y))]
[(ratnum? y)
(let ([n ($ratnum-n y)] [d ($ratnum-d y)])
(binary/ (binary- (binary* d x) n) d))]
@ -467,7 +466,7 @@
[(flonum? x)
(cond
[(fixnum? y)
($fl- x (fixnum->flonum y))]
($fl- x ($fixnum->flonum y))]
[(bignum? y)
($fl- x (bignum->flonum y))]
[(flonum? y)
@ -500,7 +499,7 @@
[(bignum? y)
(foreign-call "ikrt_fxbnmult" x y)]
[(flonum? y)
($fl* (fixnum->flonum x) y)]
($fl* ($fixnum->flonum x) y)]
[(ratnum? y)
(binary/ (binary* x ($ratnum-n y)) ($ratnum-d y))]
[else
@ -520,7 +519,7 @@
[(flonum? x)
(cond
[(fixnum? y)
($fl* x (fixnum->flonum y))]
($fl* x ($fixnum->flonum y))]
[(bignum? y)
($fl* x (bignum->flonum y))]
[(flonum? y)
@ -684,13 +683,13 @@
[(flonum? x)
(cond
[(flonum? y) ($fl/ x y)]
[(fixnum? y) ($fl/ x (fixnum->flonum y))]
[(fixnum? y) ($fl/ x ($fixnum->flonum y))]
[(bignum? y) ($fl/ x (bignum->flonum y))]
[(ratnum? y) ($fl/ x (ratnum->flonum y))]
[else (error '/ "unspported ~s ~s" x y)])]
[(fixnum? x)
(cond
[(flonum? y) ($fl/ (fixnum->flonum x) y)]
[(flonum? y) ($fl/ ($fixnum->flonum x) y)]
[(fixnum? y)
(cond
[($fx= y 0) (error '/ "division by 0")]
@ -936,7 +935,7 @@
(define exact->inexact
(lambda (x)
(cond
[(fixnum? x) (fixnum->flonum x)]
[(fixnum? x) ($fixnum->flonum x)]
[(bignum? x) (bignum->flonum x)]
[(ratnum? x)
(binary/ (exact->inexact ($ratnum-n x)) ($ratnum-d x))]
@ -1201,11 +1200,11 @@
(define-syntax flfl?
(syntax-rules () [(_ x y) (fl? x y)]))
(define-syntax flfx?
(syntax-rules () [(_ x y) (fl? x (fixnum->flonum y))]))
(syntax-rules () [(_ x y) (fl? x ($fixnum->flonum y))]))
(define-syntax flbn?
(syntax-rules () [(_ x y) (fl? x (bignum->flonum y))]))
(define-syntax fxfl?
(syntax-rules () [(_ x y) (fl? (fixnum->flonum x) y)]))
(syntax-rules () [(_ x y) (fl? ($fixnum->flonum x) y)]))
(define-syntax bnfl?
(syntax-rules () [(_ x y) (fl? (bignum->flonum x) y)])))]))

14
src/libaltcogen.ss
View File

@ -443,7 +443,8 @@
(make-asm-instr op
(make-disp (car s*) (cadr s*))
(caddr s*))))]
[(fl:load fl:store fl:add! fl:sub! fl:mul! fl:div!)
[(fl:load fl:store fl:add! fl:sub! fl:mul! fl:div!
fl:from-int)
(S* rands
(lambda (s*)
(make-asm-instr op (car s*) (cadr s*))))]
@ -1398,7 +1399,7 @@
(mark-reg/vars-conf! edx vs)
(R s vs (rem-reg edx rs) fs ns)]
[(mset bset/c bset/h fl:load fl:store fl:add! fl:sub!
fl:mul! fl:div!)
fl:mul! fl:div! fl:from-int)
(R* (list s d) vs rs fs ns)]
[else (error who "invalid effect op ~s" (unparse x))])]
[(ntcall target value args mask size)
@ -1602,7 +1603,8 @@
[(logand logor logxor int+ int- int* mset bset/c bset/h
sll sra srl
cltd idiv int-/overflow int+/overflow int*/overflow
fl:load fl:store fl:add! fl:sub! fl:mul! fl:div!)
fl:load fl:store fl:add! fl:sub! fl:mul! fl:div!
fl:from-int)
(make-asm-instr op (R d) (R s))]
[(nop) (make-primcall 'nop '())]
[else (error who "invalid op ~s" op)])]
@ -1848,7 +1850,8 @@
s))
(set-union (set-union (R eax) (R edx))
(set-union (R v) s)))]
[(mset fl:load fl:store fl:add! fl:sub! fl:mul! fl:div!)
[(mset fl:load fl:store fl:add! fl:sub! fl:mul! fl:div!
fl:from-int)
(set-union (R v) (set-union (R d) s))]
[else (error who "invalid effect ~s" x)])]
[(seq e0 e1) (E e0 (E e1 s))]
@ -2180,6 +2183,7 @@
(E (make-asm-instr 'move u a))
(E (make-asm-instr op u b))))]
[else x])]
[(fl:from-int) x]
[else (error who "invalid effect ~s" op)])]
[(primcall op rands)
(case op
@ -2461,6 +2465,8 @@
(cons `(movsd xmm0 ,(R (make-disp s d))) ac)]
[(fl:load)
(cons `(movsd ,(R (make-disp s d)) xmm0) ac)]
[(fl:from-int)
(cons `(cvtsi2sd ,(R s) xmm0) ac)]
[(fl:add!)
(cons `(addsd ,(R (make-disp s d)) xmm0) ac)]
[(fl:sub!)

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

@ -777,7 +777,9 @@
[(V fx)
(with-tmp ([x (prm 'alloc (K (align flonum-size)) (K vector-tag))])
(prm 'mset x (K (- vector-tag)) (K flonum-tag))
(prm 'fl:from-int (prm 'sll (T fx) (K fx-shift)))
(prm 'fl:from-int
(K 0) ; dummy
(prm 'sra (T fx) (K fx-shift)))
(prm 'fl:store x (K (- disp-flonum-data vector-tag)))
x)])