diff --git a/scheme/ikarus.boot.orig b/scheme/ikarus.boot.orig index a29623e..f3b6484 100644 Binary files a/scheme/ikarus.boot.orig and b/scheme/ikarus.boot.orig differ diff --git a/scheme/ikarus.bytevectors.ss b/scheme/ikarus.bytevectors.ss index 12b02ca..00e14d8 100644 --- a/scheme/ikarus.bytevectors.ss +++ b/scheme/ikarus.bytevectors.ss @@ -33,6 +33,7 @@ bytevector->uint-list bytevector->sint-list uint-list->bytevector sint-list->bytevector bytevector-ieee-double-native-ref bytevector-ieee-double-native-set! + bytevector-ieee-double-ref bytevector-ieee-double-set! native-endianness) (import (except (ikarus) @@ -53,6 +54,7 @@ bytevector->uint-list bytevector->sint-list uint-list->bytevector sint-list->bytevector bytevector-ieee-double-native-ref bytevector-ieee-double-native-set! + bytevector-ieee-double-ref bytevector-ieee-double-set! native-endianness) (ikarus system $fx) (ikarus system $bignums) @@ -991,10 +993,39 @@ ($fx< i ($bytevector-length bv))) (if (flonum? x) ($bytevector-ieee-double-native-set! bv i x) - (error 'bytevector-ieee-double-native-ref "not a flonum" x)) - (error 'bytevector-ieee-double-native-ref "invalid index" i)) - (error 'bytevector-ieee-double-native-ref "not a bytevector" bv))) - + (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) + (if (bytevector? bv) + (if (and (fixnum? i) + ($fx>= i 0) + ($fxzero? ($fxlogand i 3)) + ($fx< i ($bytevector-length bv))) + (case endianness + [(little) ($bytevector-ieee-double-native-ref bv i)] + [(big) ($bytevector-ieee-double-nonnative-ref bv i)] + [else (error 'bytevector-ieee-double-ref + "invalid endianness" endianness)]) + (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) + (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-double-native-set! bv i x)] + [(big) (error 'bytevector-ieee-double-set! "no big")] + [else (error 'bytevector-ieee-double-set! + "invalid endianness" endianness)]) + (error 'bytevector-ieee-double-set! "not a flonum" x)) + (error 'bytevector-ieee-double-set! "invalid index" i)) + (error 'bytevector-ieee-double-set! "not a bytevector" bv))) ) diff --git a/scheme/ikarus.compiler.altcogen.ss b/scheme/ikarus.compiler.altcogen.ss index e8f7b2b..d559117 100644 --- a/scheme/ikarus.compiler.altcogen.ss +++ b/scheme/ikarus.compiler.altcogen.ss @@ -548,7 +548,7 @@ (make-disp (car s*) (cadr s*)) (caddr s*))))] [(fl:load fl:store fl:add! fl:sub! fl:mul! fl:div! - fl:from-int) + fl:from-int fl:shuffle) (S* rands (lambda (s*) (make-asm-instr op (car s*) (cadr s*))))] @@ -1504,7 +1504,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:from-int) + fl:mul! fl:div! fl:from-int fl:shuffle) (R* (list s d) vs rs fs ns)] [else (error who "invalid effect op" (unparse x))])] [(ntcall target value args mask size) @@ -1709,7 +1709,7 @@ sll sra srl cltd idiv int-/overflow int+/overflow int*/overflow fl:load fl:store fl:add! fl:sub! fl:mul! fl:div! - fl:from-int) + fl:from-int fl:shuffle) (make-asm-instr op (R d) (R s))] [(nop) (make-primcall 'nop '())] [else (error who "invalid op" op)])] @@ -1956,7 +1956,7 @@ (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:from-int fl:shuffle) (set-union (R v) (set-union (R d) s))] [else (error who "invalid effect" x)])] [(seq e0 e1) (E e0 (E e1 s))] @@ -2288,7 +2288,7 @@ (E (make-asm-instr 'move u a)) (E (make-asm-instr op u b))))] [else x])] - [(fl:from-int) x] + [(fl:from-int fl:shuffle) x] [else (error who "invalid effect" op)])] [(primcall op rands) (case op @@ -2572,6 +2572,8 @@ (cons `(movsd ,(R (make-disp s d)) xmm0) ac)] [(fl:from-int) (cons `(cvtsi2sd ,(R s) xmm0) ac)] + [(fl:shuffle) + (cons `(pshufb ,(R (make-disp s d)) xmm0) ac)] [(fl:add!) (cons `(addsd ,(R (make-disp s d)) xmm0) ac)] [(fl:sub!) diff --git a/scheme/ikarus.intel-assembler.ss b/scheme/ikarus.intel-assembler.ss index a773e9b..6a7ebef 100644 --- a/scheme/ikarus.intel-assembler.ss +++ b/scheme/ikarus.intel-assembler.ss @@ -529,6 +529,14 @@ [(and (xmmreg? dst) (or (xmmreg? src) (mem? src))) (CODE #x66 (CODE #x0F ((CODE/digit #x2E dst) src ac)))] [else (error who "invalid" instr)])] + [(pshufb src dst) + (cond + [(and (xmmreg? dst) (mem? src)) + (CODE #x66 + (CODE #x0F + (CODE #x38 + ((CODE/digit #x00 dst) src ac))))] + [else (error who "invalid" instr)])] [(addl src dst) (cond [(and (imm8? src) (reg? dst)) diff --git a/scheme/makefile.ss b/scheme/makefile.ss index 0e1d89b..2142ea7 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -409,6 +409,7 @@ [$bytevector-u8-ref $bytes] [$bytevector-set! $bytes] [$bytevector-ieee-double-native-ref $bytes] + [$bytevector-ieee-double-nonnative-ref $bytes] [$bytevector-ieee-double-native-set! $bytes] [$flonum-u8-ref $flonums] [$make-flonum $flonums] @@ -864,7 +865,8 @@ [bytevector-fill! i r bv] [bytevector-ieee-double-native-ref i r bv] [bytevector-ieee-double-native-set! i r bv] - [bytevector-ieee-double-ref 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] diff --git a/scheme/pass-specify-rep-primops.ss b/scheme/pass-specify-rep-primops.ss index f3ed52d..72acb66 100644 --- a/scheme/pass-specify-rep-primops.ss +++ b/scheme/pass-specify-rep-primops.ss @@ -1375,6 +1375,20 @@ (prm 'fl:store x (K (- disp-flonum-data vector-tag))) x)]) +(define-primop $bytevector-ieee-double-nonnative-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 + (prm 'int+ (T bv) (prm 'sra (T i) (K fixnum-shift))) + (K (- disp-bytevector-data bytevector-tag))) + (prm 'fl:shuffle + (K (make-object '#vu8(7 6 2 3 4 5 1 0))) + (K (- disp-bytevector-data bytevector-tag))) + (prm 'fl:store x (K (- disp-flonum-data vector-tag))) + x)]) + + (define-primop $bytevector-ieee-double-native-set! unsafe [(E bv i x) (seq* diff --git a/scheme/tests/bytevectors.ss b/scheme/tests/bytevectors.ss index 8c1f4ff..25ca4eb 100644 --- a/scheme/tests/bytevectors.ss +++ b/scheme/tests/bytevectors.ss @@ -282,9 +282,17 @@ (bytevector-ieee-double-native-set! v 0 17.0) (bytevector-ieee-double-native-ref v 0))] - - - + [(lambda (x) (= x 17.0)) + (let ([v (make-bytevector 8)]) + (bytevector-ieee-double-set! v 0 17.0 'little) + (bytevector-ieee-double-ref v 0 'little))] + + [(lambda (x) (= x 17.0)) + (let ([v1 (make-bytevector 8)]) + (bytevector-ieee-double-set! v1 0 17.0 'little) + (let ([v2 (u8-list->bytevector + (reverse (bytevector->u8-list v1)))]) + (bytevector-ieee-double-ref v2 0 'big)))] )) diff --git a/src/geninstr/t.s b/src/geninstr/t.s index d0664ee..5c32913 100644 --- a/src/geninstr/t.s +++ b/src/geninstr/t.s @@ -1,4 +1,4 @@ .text - addl $10, %esp - addl $-10, %esp + pshufb ($0x12345678), %xmm0 + ret