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

* Added native support for $fl+, $fl-, $fl*, $fl/

This commit is contained in:
Abdulaziz Ghuloum 2007-06-15 08:53:34 +03:00
parent f1674cbaef
commit 3acdcb6c04
11 changed files with 220 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
benchmarks.larceny/results.Larceny-r6rs
View File

@ -6362,3 +6362,63 @@ Words allocated: 151779700
Words reclaimed: 0
Elapsed time...: 4619 ms (User: 3127 ms; System: 1452 ms)
Elapsed GC time: 276 ms (CPU: 252 in 579 collections.)
****************************
Benchmarking Larceny-r6rs on Thu Jun 14 20:31:38 AST 2007 under Darwin Vesuvius.local 8.9.1 Darwin Kernel Version 8.9.1: Thu Feb 22 20:55:00 PST 2007; root:xnu-792.18.15~1/RELEASE_I386 i386 i386
Testing cpstak under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 318239872
Words reclaimed: 0
Elapsed time...: 1497 ms (User: 1479 ms; System: 10 ms)
Elapsed GC time: 444 ms (CPU: 436 in 1214 collections.)
****************************
Benchmarking Larceny-r6rs on Thu Jun 14 20:34:33 AST 2007 under Darwin Vesuvius.local 8.9.1 Darwin Kernel Version 8.9.1: Thu Feb 22 20:55:00 PST 2007; root:xnu-792.18.15~1/RELEASE_I386 i386 i386
Testing mbrot under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 551809361
Words reclaimed: 0
Elapsed time...: 2293 ms (User: 2246 ms; System: 24 ms)
Elapsed GC time: 781 ms (CPU: 744 in 2105 collections.)
****************************
Benchmarking Larceny-r6rs on Thu Jun 14 20:38:10 AST 2007 under Darwin Vesuvius.local 8.9.1 Darwin Kernel Version 8.9.1: Thu Feb 22 20:55:00 PST 2007; root:xnu-792.18.15~1/RELEASE_I386 i386 i386
Testing mbrot under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 551809361
Words reclaimed: 0
Elapsed time...: 2272 ms (User: 2241 ms; System: 20 ms)
Elapsed GC time: 763 ms (CPU: 755 in 2105 collections.)

42
benchmarks/BUGS Normal file
View File

@ -0,0 +1,42 @@
* conform needs char-downcase.
* maze needs bitwise-and
* ray needs many fl procedures
* quicksort needs bignum modulo.
* scheme needs complex? and other stuff.
* simplex needs flpositive?
* slatex needs string-ci=?
* compiler needs string-downcase
* ctak crashes with a bus error.
* fibc crashes with a segfault.
* ntakl kinda slow
* string too slow
* nbody does not work
* fibfp does not terminate
* mbrot too slow
* pnpoly kinda slow
* sumfp/fpsum too slow
BEFORE:
running stats for fibfp:
no collections
13316 ms elapsed cpu time
13984 ms elapsed real time
1433313736 bytes allocated
running stats for mbrot:
12145 collections
7608 ms elapsed cpu time
7660 ms elapsed real time
2215766392 bytes allocated
running stats for pnpoly:
81 collections
2622 ms elapsed cpu time
2637 ms elapsed real time
335204784 bytes allocated
running stats for sumfp:
no collections
13917 ms elapsed cpu time
30995 ms elapsed real time
1600160040 bytes allocated

2
benchmarks/bench.ss
View File

@ -2,7 +2,7 @@
(import
(ikarus)
(r6rs-benchmarks))
#;(r6rs-benchmarks))
(define (run name)
(eval '(main) (environment (list 'r6rs-benchmarks name))))

18
benchmarks/r6rs-benchmarks/BUGS
View File

@ -1,18 +0,0 @@
* conform needs char-downcase.
* maze needs bitwise-and
* ray needs many fl procedures
* quicksort needs bignum modulo.
* scheme needs complex? and other stuff.
* simplex needs flpositive?
* slatex needs string-ci=?
* compiler needs string-downcase
* ctak crashes with a bus error.
* fibc crashes with a segfault.
* fibfp does not terminate
* mbrot too slow
* ntakl kinda slow
* pnpoly kinda slow
* sumfp/fpsum too slow
* string too slow
* nbody does not work

20
benchmarks/r6rs-benchmarks/ctak.ss
View File

@ -6,21 +6,21 @@
(define (ctak x y z)
(call-with-current-continuation
(lambda (k) (ctak-aux k x y z))))
(lambda (k) (ctak-aux k x y z))))
(define (ctak-aux k x y z)
(if (not (< y x))
(k z)
(call-with-current-continuation
(lambda (k)
(ctak-aux
k
(call-with-current-continuation
(lambda (k) (ctak-aux k (- x 1) y z)))
(call-with-current-continuation
(lambda (k) (ctak-aux k (- y 1) z x)))
(call-with-current-continuation
(lambda (k) (ctak-aux k (- z 1) x y))))))))
(lambda (k)
(ctak-aux
k
(call-with-current-continuation
(lambda (k) (ctak-aux k (- x 1) y z)))
(call-with-current-continuation
(lambda (k) (ctak-aux k (- y 1) z x)))
(call-with-current-continuation
(lambda (k) (ctak-aux k (- z 1) x y))))))))
(define (main . args)
(run-benchmark

BIN
src/ikarus.boot
View File

Binary file not shown.

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

@ -43,6 +43,14 @@
[/5 0 5]
[/6 0 6]
[/7 0 7]
[xmm0 xmm 0]
[xmm1 xmm 1]
[xmm2 xmm 2]
[xmm3 xmm 3]
[xmm4 xmm 4]
[xmm5 xmm 5]
[xmm6 xmm 6]
[xmm7 xmm 7]
))
(define register-index
@ -55,14 +63,21 @@
(lambda (x)
(cond
[(assq x register-mapping) =>
(lambda (x) (fx= (cadr x) 32))]
(lambda (x) (eqv? (cadr x) 32))]
[else #f])))
(define reg8?
(lambda (x)
(cond
[(assq x register-mapping) =>
(lambda (x) (fx= (cadr x) 8))]
(lambda (x) (eqv? (cadr x) 8))]
[else #f])))
(define xmmreg?
(lambda (x)
(cond
[(assq x register-mapping) =>
(lambda (x) (eqv? (cadr x) 'xmm))]
[else #f])))
(define reg?
@ -343,7 +358,6 @@
[else (error 'CODE/digit "unhandled ~s ~s" a0 a1)])))]
[else (error 'CODE/digit "unhandled ~s" dst)])))
(define CODEid
(lambda (c /? n disp ac)
(with-args disp
@ -455,6 +469,33 @@
[(and (reg8? src) (mem? dst)) (CODErd #x88 src dst ac)]
[(and (mem? src) (reg8? dst)) (CODErd #x8A dst src ac)]
[else (error who "invalid ~s" instr)])]
[(movsd src dst)
(cond
[(and (xmmreg? dst) (or (xmmreg? src) (mem? src)))
(CODE #xF2 (CODE #x0F ((CODE/digit #x10 dst) src ac)))]
[(and (xmmreg? src) (or (xmmreg? dst) (mem? dst)))
(CODE #xF2 (CODE #x0F ((CODE/digit #x11 src) dst ac)))]
[else (error who "invalid ~s" instr)])]
[(addsd src dst)
(cond
[(and (xmmreg? dst) (or (xmmreg? src) (mem? src)))
(CODE #xF2 (CODE #x0F ((CODE/digit #x58 dst) src ac)))]
[else (error who "invalid ~s" instr)])]
[(subsd src dst)
(cond
[(and (xmmreg? dst) (or (xmmreg? src) (mem? src)))
(CODE #xF2 (CODE #x0F ((CODE/digit #x5C dst) src ac)))]
[else (error who "invalid ~s" instr)])]
[(mulsd src dst)
(cond
[(and (xmmreg? dst) (or (xmmreg? src) (mem? src)))
(CODE #xF2 (CODE #x0F ((CODE/digit #x59 dst) src ac)))]
[else (error who "invalid ~s" instr)])]
[(divsd src dst)
(cond
[(and (xmmreg? dst) (or (xmmreg? src) (mem? src)))
(CODE #xF2 (CODE #x0F ((CODE/digit #x5E dst) src ac)))]
[else (error who "invalid ~s" instr)])]
[(addl src dst)
(cond
[(and (imm8? src) (reg? dst))

25
src/ikarus.numerics.ss
View File

@ -337,14 +337,17 @@
(define (ratnum->flonum x)
(binary/ (exact->inexact ($ratnum-n x))
(exact->inexact ($ratnum-d x))))
(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))
#;
(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)))
@ -440,7 +443,7 @@
(foreign-call "ikrt_fxbnminus" x y)]
[(flonum? y)
(if ($fx= x 0)
($fl* y -1.0)
(fl* y -1.0)
($fl- (fixnum->flonum x) y))]
[(ratnum? y)
(let ([n ($ratnum-n y)] [d ($ratnum-d y)])
@ -880,7 +883,7 @@
(if ($bignum-positive? x) x (- x))]
[(flonum? x)
(if ($flnegative? x)
($fl* x -1.0)
(fl* x -1.0)
x)]
[(ratnum? x)
(let ([n ($ratnum-n x)])
@ -1284,7 +1287,7 @@
(f (fl- ac (car rest)) (cdr rest))))]
[(x)
(if (flonum? x)
($fl- 0.0 x)
(fl- 0.0 x)
(error 'fl+ "~s is not a flonum" x))]))
(define fl*

32
src/libaltcogen.ss
View File

@ -443,6 +443,10 @@
(make-asm-instr op
(make-disp (car s*) (cadr s*))
(caddr s*))))]
[(fl:load fl:store fl:add! fl:sub! fl:mul! fl:div!)
(S* rands
(lambda (s*)
(make-asm-instr op (car s*) (cadr s*))))]
[(nop interrupt) x]
[else (error 'impose-effect "invalid instr ~s" x)])]
[(funcall rator rands)
@ -1394,7 +1398,8 @@
[(cltd)
(mark-reg/vars-conf! edx vs)
(R s vs (rem-reg edx rs) fs ns)]
[(mset bset/c bset/h)
[(mset bset/c bset/h fl:load fl:store fl:add! fl:sub!
fl:mul! fl:div!)
(R* (list s d) vs rs fs ns)]
[else (error who "invalid effect op ~s" (unparse x))])]
[(ntcall target value args mask size)
@ -1597,7 +1602,8 @@
(make-asm-instr op d s)]))]
[(logand logor logxor int+ int- int* mset bset/c bset/h
sll sra srl
cltd idiv int-/overflow int+/overflow int*/overflow)
cltd idiv int-/overflow int+/overflow int*/overflow
fl:load fl:store fl:add! fl:sub! fl:mul! fl:div!)
(make-asm-instr op (R d) (R s))]
[(nop) (make-primcall 'nop '())]
[else (error who "invalid op ~s" op)])]
@ -1843,7 +1849,7 @@
s))
(set-union (set-union (R eax) (R edx))
(set-union (R v) s)))]
[(mset)
[(mset fl:load fl:store fl:add! fl:sub! fl:mul! fl:div!)
(set-union (R v) (set-union (R d) s))]
[else (error who "invalid effect ~s" x)])]
[(seq e0 e1) (E e0 (E e1 s))]
@ -2167,6 +2173,14 @@
(E (make-asm-instr 'move u s2))
(E (make-asm-instr op (make-disp u s1) b))))]
[else x]))])]
[(fl:load fl:store fl:add! fl:sub! fl:mul! fl:div!)
(cond
[(mem? a)
(let ([u (mku)])
(make-seq
(E (make-asm-instr 'move u a))
(E (make-asm-instr op u b))))]
[else x])]
[else (error who "invalid effect ~s" op)])]
[(primcall op rands)
(case op
@ -2437,6 +2451,18 @@
(list* `(addl ,(R s) ,(R d))
`(jo ,L)
ac))]
[(fl:store)
(cons `(movsd xmm0 ,(R (make-disp s d))) ac)]
[(fl:load)
(cons `(movsd ,(R (make-disp s d)) xmm0) ac)]
[(fl:add!)
(cons `(addsd ,(R (make-disp s d)) xmm0) ac)]
[(fl:sub!)
(cons `(subsd ,(R (make-disp s d)) xmm0) ac)]
[(fl:mul!)
(cons `(mulsd ,(R (make-disp s d)) xmm0) ac)]
[(fl:div!)
(cons `(divsd ,(R (make-disp s d)) xmm0) ac)]
[else (error who "invalid instr ~s" x)])]
[(primcall op rands)
(case op

4
src/makefile.ss
View File

@ -603,6 +603,10 @@
[$flonum-signed-biased-exponent $flonums]
[$flonum-rational? $flonums]
[$flonum-integer? $flonums]
[$fl+ $flonums]
[$fl- $flonums]
[$fl* $flonums]
[$fl/ $flonums]
[$make-bignum $bignums]
[$bignum-positive? $bignums]

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

@ -721,6 +721,14 @@
(section ;;; flonums
(define ($flop-aux op fl0 fl1)
(with-tmp ([x (prm 'alloc (K (align flonum-size)) (K vector-tag))])
(prm 'mset x (K (- vector-tag)) (K flonum-tag))
(prm 'fl:load (T fl0) (K (- disp-flonum-data vector-tag)))
(prm op (T fl1) (K (- disp-flonum-data vector-tag)))
(prm 'fl:store x (K (- disp-flonum-data vector-tag)))
x))
(define-primop flonum? safe
[(P x) (sec-tag-test (T x) vector-mask vector-tag #f flonum-tag)]
[(E x) (nop)])
@ -760,6 +768,14 @@
(prm 'sll (T v) (K (- 8 fx-shift))))]
[else (interrupt)])])
(define-primop $fl+ unsafe
[(V x y) ($flop-aux 'fl:add! x y)])
(define-primop $fl- unsafe
[(V x y) ($flop-aux 'fl:sub! x y)])
(define-primop $fl* unsafe
[(V x y) ($flop-aux 'fl:mul! x y)])
(define-primop $fl/ unsafe
[(V x y) ($flop-aux 'fl:div! x y)])
/section)