* Added bytevector-ieee-double-ref and bytevector-ieee-double-set!

(which does not yet support big endianness)

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-set! "not a flonum" x))
-            (error 'bytevector-ieee-double-native-ref "invalid index" i))
+            (error 'bytevector-ieee-double-native-set! "invalid index" i))
-        (error 'bytevector-ieee-double-native-ref "not a bytevector" bv)))
+        (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)))
 
   )
 

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

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

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]

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*

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

src/geninstr/t.s

@@ -1,4 +1,4 @@
 
 .text
-  addl $10, %esp
+  pshufb ($0x12345678), %xmm0
-  addl $-10, %esp
+  ret