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

* Added bytevector-ieee-single-native-ref and bytevector-ieee-single-native-set!

This commit is contained in:
Abdulaziz Ghuloum 2007-11-08 22:22:24 -05:00
parent 62c0643c19
commit 5ce6ca4efb
9 changed files with 190 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -8514,3 +8514,23 @@ Words allocated: 29621942
Words reclaimed: 0
Elapsed time...: 1199 ms (User: 1195 ms; System: 4 ms)
Elapsed GC time: 44 ms (CPU: 48 in 113 collections.)
****************************
Benchmarking Larceny-r6rs on Thu Nov 8 20:58:17 EST 2007 under Darwin Vesuvius.local 8.10.1 Darwin Kernel Version 8.10.1: Wed May 23 16:33:00 PDT 2007; root:xnu-792.22.5~1/RELEASE_I386 i386 i386
Testing maze 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: 36171538
Words reclaimed: 0
Elapsed time...: 5849 ms (User: 5815 ms; System: 31 ms)
Elapsed GC time: 83 ms (CPU: 86 in 138 collections.)

BIN
scheme/ikarus.boot.orig
View File

Binary file not shown.

65
scheme/ikarus.bytevectors.ss
View File

@ -33,7 +33,9 @@
bytevector->uint-list bytevector->sint-list
uint-list->bytevector sint-list->bytevector
bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!
bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
bytevector-ieee-double-ref bytevector-ieee-double-set!
bytevector-ieee-single-ref bytevector-ieee-single-set!
native-endianness)
(import
(except (ikarus)
@ -55,8 +57,9 @@
uint-list->bytevector sint-list->bytevector
bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!
bytevector-ieee-double-ref bytevector-ieee-double-set!
bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
bytevector-ieee-single-ref bytevector-ieee-single-set!
native-endianness)
;(only (rnrs) bitwise-and)
(ikarus system $fx)
(ikarus system $bignums)
(ikarus system $pairs)
@ -972,30 +975,52 @@
(if (bytevector? bv)
(if (and (fixnum? i)
($fx>= i 0)
($fxzero? ($fxlogand i 3))
($fxzero? ($fxlogand i 7))
($fx< i ($bytevector-length bv)))
($bytevector-ieee-double-native-ref bv i)
(error 'bytevector-ieee-double-native-ref "invalid index" i))
(error 'bytevector-ieee-double-native-ref "not a bytevector" bv)))
(define (bytevector-ieee-double-native-set! bv i x)
(define (bytevector-ieee-single-native-ref bv i)
(if (bytevector? bv)
(if (and (fixnum? i)
($fx>= i 0)
($fxzero? ($fxlogand i 3))
($fx< i ($bytevector-length bv)))
($bytevector-ieee-single-native-ref bv i)
(error 'bytevector-ieee-single-native-ref "invalid index" i))
(error 'bytevector-ieee-single-native-ref "not a bytevector" bv)))
(define (bytevector-ieee-double-native-set! bv i x)
(if (bytevector? bv)
(if (and (fixnum? i)
($fx>= i 0)
($fxzero? ($fxlogand i 7))
($fx< i ($bytevector-length bv)))
(if (flonum? x)
($bytevector-ieee-double-native-set! bv i x)
(error 'bytevector-ieee-double-native-set! "not a flonum" x))
(error 'bytevector-ieee-double-native-set! "invalid index" i))
(error 'bytevector-ieee-double-native-set! "not a bytevector" bv)))
(define (bytevector-ieee-double-ref bv i endianness)
(define (bytevector-ieee-single-native-set! bv i x)
(if (bytevector? bv)
(if (and (fixnum? i)
($fx>= i 0)
($fxzero? ($fxlogand i 3))
($fx< i ($bytevector-length bv)))
(if (flonum? x)
($bytevector-ieee-single-native-set! bv i x)
(error 'bytevector-ieee-single-native-set! "not a flonum" x))
(error 'bytevector-ieee-single-native-set! "invalid index" i))
(error 'bytevector-ieee-single-native-set! "not a bytevector" bv)))
(define (bytevector-ieee-double-ref bv i endianness)
(if (bytevector? bv)
(if (and (fixnum? i)
($fx>= i 0)
($fxzero? ($fxlogand i 7))
($fx< i ($bytevector-length bv)))
(case endianness
[(little) ($bytevector-ieee-double-native-ref bv i)]
[(big) ($bytevector-ieee-double-nonnative-ref bv i)]
@ -1004,12 +1029,26 @@
(error 'bytevector-ieee-double-ref "invalid index" i))
(error 'bytevector-ieee-double-ref "not a bytevector" bv)))
(define (bytevector-ieee-double-set! bv i x endianness)
(define (bytevector-ieee-single-ref bv i endianness)
(if (bytevector? bv)
(if (and (fixnum? i)
($fx>= i 0)
($fxzero? ($fxlogand i 3))
($fx< i ($bytevector-length bv)))
(case endianness
[(little) ($bytevector-ieee-single-native-ref bv i)]
;[(big) ($bytevector-ieee-single-nonnative-ref bv i)]
[else (error 'bytevector-ieee-single-ref
"invalid endianness" endianness)])
(error 'bytevector-ieee-single-ref "invalid index" i))
(error 'bytevector-ieee-single-ref "not a bytevector" bv)))
(define (bytevector-ieee-double-set! bv i x endianness)
(if (bytevector? bv)
(if (and (fixnum? i)
($fx>= i 0)
($fxzero? ($fxlogand i 7))
($fx< i ($bytevector-length bv)))
(if (flonum? x)
(case endianness
[(little) ($bytevector-ieee-double-native-set! bv i x)]
@ -1020,6 +1059,22 @@
(error 'bytevector-ieee-double-set! "invalid index" i))
(error 'bytevector-ieee-double-set! "not a bytevector" bv)))
(define (bytevector-ieee-single-set! bv i x endianness)
(if (bytevector? bv)
(if (and (fixnum? i)
($fx>= i 0)
($fxzero? ($fxlogand i 3))
($fx< i ($bytevector-length bv)))
(if (flonum? x)
(case endianness
[(little) ($bytevector-ieee-single-native-set! bv i x)]
; [(big) ($bytevector-ieee-single-nonnative-set! bv i x)]
[else (error 'bytevector-ieee-single-set!
"invalid endianness" endianness)])
(error 'bytevector-ieee-single-set! "not a flonum" x))
(error 'bytevector-ieee-single-set! "invalid index" i))
(error 'bytevector-ieee-single-set! "not a bytevector" bv)))
)

35
scheme/ikarus.compiler.altcogen.ss
View File

@ -548,11 +548,13 @@
(make-disp (car s*) (cadr s*))
(caddr s*))))]
[(fl:load fl:store fl:add! fl:sub! fl:mul! fl:div!
fl:from-int fl:shuffle bswap!)
fl:from-int fl:shuffle bswap!
fl:store-single fl:load-single)
(S* rands
(lambda (s*)
(make-asm-instr op (car s*) (cadr s*))))]
[(nop interrupt incr/zero?) x]
[(nop interrupt incr/zero? fl:double->single
fl:single->double) x]
[else (error 'impose-effect "invalid instr" x)])]
[(funcall rator rands)
(handle-nontail-call rator rands #f #f)]
@ -1504,7 +1506,8 @@
(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:from-int fl:shuffle)
fl:mul! fl:div! fl:from-int fl:shuffle
fl:load-single fl:store-single)
(R* (list s d) vs rs fs ns)]
[else (error who "invalid effect op" (unparse x))])]
[(ntcall target value args mask size)
@ -1517,7 +1520,7 @@
(E body vs rs fs ns)]
[(primcall op args)
(case op
[(nop) (values vs rs fs ns)]
[(nop fl:double->single fl:single->double) (values vs rs fs ns)]
[(interrupt incr/zero?)
(let ([v (exception-live-set)])
(unless (vector? v)
@ -1709,7 +1712,7 @@
sll sra srl bswap!
cltd idiv int-/overflow int+/overflow int*/overflow
fl:load fl:store fl:add! fl:sub! fl:mul! fl:div!
fl:from-int fl:shuffle)
fl:from-int fl:shuffle fl:load-single fl:store-single)
(make-asm-instr op (R d) (R s))]
[(nop) (make-primcall 'nop '())]
[else (error who "invalid op" op)])]
@ -1809,7 +1812,8 @@
(NFE (fxsub1 i) (make-mask (fxsub1 i)) body)))]
[(primcall op args)
(case op
[(nop interrupt incr/zero?) x]
[(nop interrupt incr/zero? fl:double->single
fl:single->double) x]
[else (error who "invalid effect prim" op)])]
[(shortcut body handler)
(make-shortcut (E body) (E handler))]
@ -1956,7 +1960,8 @@
(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!
fl:from-int fl:shuffle)
fl:from-int fl:shuffle fl:store-single
fl:load-single)
(set-union (R v) (set-union (R d) s))]
[else (error who "invalid effect" x)])]
[(seq e0 e1) (E e0 (E e1 s))]
@ -1967,7 +1972,7 @@
(set-union (R* args) s)]
[(primcall op arg*)
(case op
[(nop) s]
[(nop fl:single->double fl:double->single) s]
[(interrupt incr/zero?)
(or (exception-live-set) (error who "uninitialized exception"))]
[else (error who "invalid effect primcall" op)])]
@ -2289,7 +2294,8 @@
(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!)
[(fl:load fl:store fl:add! fl:sub! fl:mul! fl:div!
fl:load-single fl:store-single)
(cond
[(mem? a)
(let ([u (mku)])
@ -2301,7 +2307,8 @@
[else (error who "invalid effect" op)])]
[(primcall op rands)
(case op
[(nop interrupt incr/zero?) x]
[(nop interrupt incr/zero? fl:single->double
fl:double->single) x]
[else (error who "invalid op in" (unparse x))])]
[(ntcall) x]
[(shortcut body handler)
@ -2581,8 +2588,12 @@
ac))]
[(fl:store)
(cons `(movsd xmm0 ,(R (make-disp s d))) ac)]
[(fl:store-single)
(cons `(movss xmm0 ,(R (make-disp s d))) ac)]
[(fl:load)
(cons `(movsd ,(R (make-disp s d)) xmm0) ac)]
[(fl:load-single)
(cons `(movss ,(R (make-disp s d)) xmm0) ac)]
[(fl:from-int)
(cons `(cvtsi2sd ,(R s) xmm0) ac)]
[(fl:shuffle)
@ -2610,6 +2621,10 @@
`(addl 1 ,(R (make-disp (car rands) (cadr rands))))
`(je ,l)
ac))]
[(fl:double->single)
(cons '(cvtsd2ss xmm0 xmm0) ac)]
[(fl:single->double)
(cons '(cvtss2sd xmm0 xmm0) ac)]
[else (error who "invalid effect" (unparse x))])]
[(shortcut body handler)
(let ([L (unique-interrupt-label)] [L2 (unique-label)])

21
scheme/ikarus.intel-assembler.ss
View File

@ -504,6 +504,27 @@
[(and (xmmreg? dst) (mem? src))
(CODE #xF2 (CODE #x0F ((CODE/digit #x2A dst) src ac)))]
[else (error who "invalid" instr)])]
[(cvtsd2ss src dst)
(cond
[(and (xmmreg? dst) (reg? src))
(CODE #xF2 (CODE #x0F (CODE #x5A (ModRM 3 src dst ac))))]
;[(and (xmmreg? dst) (mem? src))
; (CODE #xF2 (CODE #x0F ((CODE/digit #x5A dst) src ac)))]
[else (error who "invalid" instr)])]
[(cvtss2sd src dst)
(cond
[(and (xmmreg? dst) (reg? src))
(CODE #xF3 (CODE #x0F (CODE #x5A (ModRM 3 src dst ac))))]
;[(and (xmmreg? dst) (mem? src))
; (CODE #xF3 (CODE #x0F ((CODE/digit #x5A dst) src ac)))]
[else (error who "invalid" instr)])]
[(movss src dst)
(cond
[(and (xmmreg? dst) (or (xmmreg? src) (mem? src)))
(CODE #xF3 (CODE #x0F ((CODE/digit #x10 dst) src ac)))]
[(and (xmmreg? src) (or (xmmreg? dst) (mem? dst)))
(CODE #xF3 (CODE #x0F ((CODE/digit #x11 src) dst ac)))]
[else (error who "invalid" instr)])]
[(addsd src dst)
(cond
[(and (xmmreg? dst) (or (xmmreg? src) (mem? src)))

11
scheme/makefile.ss
View File

@ -411,6 +411,10 @@
[$bytevector-ieee-double-native-set! $bytes]
[$bytevector-ieee-double-nonnative-ref $bytes]
[$bytevector-ieee-double-nonnative-set! $bytes]
[$bytevector-ieee-single-native-ref $bytes]
[$bytevector-ieee-single-native-set! $bytes]
[$bytevector-ieee-single-nonnative-ref $bytes]
[$bytevector-ieee-single-nonnative-set! $bytes]
[$flonum-u8-ref $flonums]
[$make-flonum $flonums]
[$flonum-set! $flonums]
@ -867,9 +871,10 @@
[bytevector-ieee-double-native-set! i r bv]
[bytevector-ieee-double-ref i r bv]
[bytevector-ieee-double-set! i r bv]
[bytevector-ieee-single-native-ref r bv]
[bytevector-ieee-single-native-set! r bv]
[bytevector-ieee-single-ref r bv]
[bytevector-ieee-single-native-ref i r bv]
[bytevector-ieee-single-native-set! i r bv]
[bytevector-ieee-single-ref i r bv]
[bytevector-ieee-single-set! i r bv]
[bytevector-length i r bv]
[bytevector-s16-native-ref i r bv]
[bytevector-s16-native-set! i r bv]

22
scheme/pass-specify-rep-primops.ss
View File

@ -1438,6 +1438,7 @@
(prm 'fl:store x (K (- disp-flonum-data vector-tag)))
x)])
;;; the following uses unsupported sse3 instructions
;(define-primop $bytevector-ieee-double-nonnative-ref unsafe
; [(V bv i)
@ -1477,6 +1478,27 @@
(prm 'int+ (T bv) (prm 'sra (T i) (K fixnum-shift)))
(K (- disp-bytevector-data bytevector-tag))))])
(define-primop $bytevector-ieee-single-native-ref unsafe
[(V bv i)
(with-tmp ([x (prm 'alloc (K (align flonum-size)) (K vector-tag))])
(prm 'mset x (K (- vector-tag)) (K flonum-tag))
(prm 'fl:load-single
(prm 'int+ (T bv) (prm 'sra (T i) (K fixnum-shift)))
(K (- disp-bytevector-data bytevector-tag)))
(prm 'fl:single->double)
(prm 'fl:store x (K (- disp-flonum-data vector-tag)))
x)])
(define-primop $bytevector-ieee-single-native-set! unsafe
[(E bv i x)
(seq*
(prm 'fl:load (T x) (K (- disp-flonum-data vector-tag)))
(prm 'fl:double->single)
(prm 'fl:store-single
(prm 'int+ (T bv) (prm 'sra (T i) (K fixnum-shift)))
(K (- disp-bytevector-data bytevector-tag))))])
;;; the following uses unsupported sse3 instructions
;(define-primop $bytevector-ieee-double-nonnative-set! unsafe
; [(E bv i x)

33
scheme/tests/bytevectors.ss
View File

@ -272,6 +272,7 @@
(let ([v (make-bytevector 4)])
(bytevector-s32-set! v 0 -12345 'little)
(bytevector-s32-ref v 0 'little))]
[(lambda (x) (= x -12345))
(let ([v (make-bytevector 4)])
(bytevector-s32-set! v 0 -12345 'big)
@ -306,6 +307,38 @@
(reverse (bytevector->u8-list v1)))])
(bytevector-ieee-double-ref v2 0 'little)))]
[(lambda (x) (= x 17.0))
(let ([v (make-bytevector 4)])
(bytevector-ieee-single-native-set! v 0 17.0)
(bytevector-ieee-single-native-ref v 0))]
[(lambda (x) (= x 17.0))
(let ([v (make-bytevector 4)])
(bytevector-ieee-single-set! v 0 17.0 'little)
(bytevector-ieee-single-ref v 0 'little))]
; [(lambda (x) (= x 17.0))
; (let ([v (make-bytevector 8)])
; (bytevector-ieee-single-set! v 0 17.0 'big)
; (bytevector-ieee-single-ref v 0 'big))]
;
; [(lambda (x) (= x 17.0))
; (let ([v1 (make-bytevector 8)])
; (bytevector-ieee-single-set! v1 0 17.0 'little)
; (let ([v2 (u8-list->bytevector
; (reverse (bytevector->u8-list v1)))])
; (bytevector-ieee-single-ref v2 0 'big)))]
;
; [(lambda (x) (= x 17.0))
; (let ([v1 (make-bytevector 8)])
; (bytevector-ieee-single-set! v1 0 17.0 'big)
; (let ([v2 (u8-list->bytevector
; (reverse (bytevector->u8-list v1)))])
; (bytevector-ieee-single-ref v2 0 'little)))]
))

2
scheme/todo-r6rs.ss
View File

@ -255,7 +255,7 @@
[bitwise-arithmetic-shift C bw]
[bitwise-arithmetic-shift-left C bw]
[bitwise-arithmetic-shift-right C bw]
[bitwise-not S bw]
[bitwise-not C bw]
[bitwise-and C bw]
[bitwise-ior S bw]
[bitwise-xor S bw]