* bytevector-ieee-double-ref/set! now work

scheme/ikarus.bytevectors.ss

@@ -446,7 +446,6 @@
               (error 'bytevector-s16-ref "invalid index" i))
           (error 'bytevector-s16-ref "not a bytevector" x))))
 
-
   (define bytevector-s16-set!
     (lambda (x i n end) 
       (if (bytevector? x) 
@@ -468,11 +467,6 @@
               (error 'bytevector-s16-set! "invalid value" n))
           (error 'bytevector-s16-set! "not a bytevector" x))))
 
-
-
-
-
-
   (define bytevector->u8-list
     (lambda (x)
       (unless (bytevector? x)
@@ -514,7 +508,6 @@
            (let ([s ($make-bytevector n)])
              (fill s 0 ls))))))
 
-
   (define bytevector-copy
     (lambda (src)
       (unless (bytevector? src)
@@ -984,7 +977,6 @@
             (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) 
     (if (bytevector? bv) 
         (if (and (fixnum? i) 
@@ -1020,7 +1012,7 @@
             (if (flonum? x)
                 (case endianness
                   [(little) ($bytevector-ieee-double-native-set! bv i x)]
-                  [(big) (error 'bytevector-ieee-double-set! "no big")]
+                  [(big) ($bytevector-ieee-double-nonnative-set! bv i x)]
                   [else (error 'bytevector-ieee-double-set! 
                           "invalid endianness" endianness)])
                 (error 'bytevector-ieee-double-set! "not a flonum" x))

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:shuffle) 
+                   fl:from-int fl:shuffle bswap!) 
           (S* rands
               (lambda (s*)
                 (make-asm-instr op (car s*) (cadr s*))))]
@@ -1464,7 +1464,7 @@
                       (mark-nfv/frms-conf! d fs)
                       (R s vs rs fs (add-nfv d ns)))])]
                 [else (error who "invalid op d" (unparse x))])))] 
-         [(logand logor logxor sll sra srl int+ int- int*) 
+         [(logand logor logxor sll sra srl int+ int- int* bswap!) 
           (cond
             [(var? d) 
              (cond
@@ -1706,7 +1706,7 @@
                 [else
                  (make-asm-instr op d s)]))]
            [(logand logor logxor int+ int- int* mset bset/c bset/h 
-              sll sra srl
+              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)
@@ -1931,7 +1931,7 @@
             (let ([s (set-rem d (set-union s (exception-live-set)))])
               (set-for-each (lambda (y) (add-edge! g d y)) s)
               (set-union (set-union (R v) (R d)) s))] 
-           [(logand logxor int+ int- int* logor sll sra srl)
+           [(logand logxor int+ int- int* logor sll sra srl bswap!)
             (let ([s (set-rem d s)])
               (set-for-each (lambda (y) (add-edge! g d y)) s)
               (set-union (set-union (R v) (R d)) s))]
@@ -2234,6 +2234,15 @@
                         (E (make-asm-instr op a (make-disp s0 u)))))]
                    [else x]))] 
               [else x])]
+           [(bswap!) 
+            (cond
+              [(mem? b)
+               (let ([u (mku)])
+                 (make-seq
+                   (E (make-asm-instr 'move u a))
+                   (E (make-asm-instr 'bswap! u u))
+                   (E (make-asm-instr 'move b u))))]
+              [else x])]
            [(cltd) 
             (unless (and (symbol? a) (symbol? b)) 
               (error who "invalid args to cltd"))
@@ -2548,6 +2557,10 @@
          [(srl)  (cons `(shrl ,(R/cl s) ,(R d)) ac)]
          [(idiv) (cons `(idivl ,(R s)) ac)]
          [(cltd) (cons `(cltd) ac)]
+         [(bswap!) 
+          (let ([s (R s)] [d (R d)])
+            (unless (eq? s d) (error who "invalid instr" x))
+            (cons `(bswap ,s) ac))]
          [(int-/overflow)
           (let ([L (or (exception-label) 
                        (error who "no exception label"))])

scheme/ikarus.intel-assembler.ss

@@ -529,14 +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)
+   ;[(pshufb src dst)
-    (cond
+   ; ;;; unfortunately, this is an SSE3 instr.
-      [(and (xmmreg? dst) (mem? src))
+   ; (cond
-       (CODE #x66
+   ;   [(and (xmmreg? dst) (mem? src))
-         (CODE #x0F
+   ;    (CODE #x0F
-           (CODE #x38 
+   ;      (CODE #x38 
-             ((CODE/digit #x00 dst) src ac))))]
+   ;        ((CODE/digit #x00 dst) src ac)))]
-      [else (error who "invalid" instr)])]
+   ;   [else (error who "invalid" instr)])]
    [(addl src dst)
     (cond   
       [(and (imm8? src) (reg? dst)) 
@@ -726,6 +726,11 @@
        ;;; maybe error 
        (CODErd #xF7 '/7 dst ac)]
       [else (error who "invalid" instr)])]
+   [(bswap dst)
+    (cond
+      [(reg? dst) 
+       (CODE #x0F (CODE+r #xC8 dst ac))]
+      [else (error who "invalid" instr)])]
    [(negl dst)
     (cond
       [(reg? dst)

scheme/makefile.ss

@@ -409,8 +409,9 @@
     [$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]
+    [$bytevector-ieee-double-nonnative-ref       $bytes]
+    [$bytevector-ieee-double-nonnative-set!      $bytes]
     [$flonum-u8-ref                              $flonums]
     [$make-flonum                                $flonums]
     [$flonum-set!                                $flonums]

scheme/pass-specify-rep-primops.ss

@@ -1364,7 +1364,6 @@
                     (K (- disp-bytevector-data bytevector-tag)))
                (prm 'sll (T c) (K (- 8 fx-shift))))])])])
 
-
 (define-primop $bytevector-ieee-double-native-ref unsafe
   [(V bv i)
    (with-tmp ([x (prm 'alloc (K (align flonum-size)) (K vector-tag))])
@@ -1375,18 +1374,35 @@
      (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)
+;   (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-nonnative-ref unsafe
   [(V bv i)
+   (let ([bvoff (- disp-bytevector-data bytevector-tag)]
+         [floff (- disp-flonum-data vector-tag)])
      (with-tmp ([x (prm 'alloc (K (align flonum-size)) (K vector-tag))])
        (prm 'mset x (K (- vector-tag)) (K flonum-tag))
-     (prm 'fl:load 
+       (with-tmp ([t (prm 'int+ (T bv) 
-       (prm 'int+ (T bv) (prm 'sra (T i) (K fixnum-shift)))
+                        (prm 'sra (T i) (K fixnum-shift)))])
-       (K (- disp-bytevector-data bytevector-tag)))
+         (with-tmp ([x0 (prm 'mref t (K bvoff))])
-     (prm 'fl:shuffle
+           (prm 'bswap! x0 x0)
-       (K (make-object '#vu8(7 6 2 3 4 5 1 0)))
+           (prm 'mset x (K (+ floff wordsize)) x0))
-       (K (- disp-bytevector-data bytevector-tag)))
+         (with-tmp ([x0 (prm 'mref t (K (+ bvoff wordsize)))])
-     (prm 'fl:store x (K (- disp-flonum-data vector-tag)))
+           (prm 'bswap! x0 x0)
-     x)])
+           (prm 'mset x (K floff) x0)))
+       x))])
 
 
 (define-primop $bytevector-ieee-double-native-set! unsafe
@@ -1397,6 +1413,31 @@
        (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)
+;   (seq*
+;     (prm 'fl:load (T x) (K (- disp-flonum-data vector-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
+;       (prm 'int+ (T bv) (prm 'sra (T i) (K fixnum-shift)))
+;       (K (- disp-bytevector-data bytevector-tag))))])
+
+(define-primop $bytevector-ieee-double-nonnative-set! unsafe
+  [(E bv i x)
+   (let ([bvoff (- disp-bytevector-data bytevector-tag)]
+         [floff (- disp-flonum-data vector-tag)])
+     (with-tmp ([t (prm 'int+ (T bv)
+                      (prm 'sra (T i) (K fixnum-shift)))])
+       (with-tmp ([x0 (prm 'mref (T x) (K floff))])
+         (prm 'bswap! x0 x0)
+         (prm 'mset t (K (+ bvoff wordsize)) x0))
+       (with-tmp ([x0 (prm 'mref (T x) (K (+ floff wordsize)))])
+         (prm 'bswap! x0 x0)
+         (prm 'mset t (K bvoff) x0))))])
+
 /section)
 
 (section ;;; strings

scheme/tests/bytevectors.ss

@@ -287,6 +287,11 @@
        (bytevector-ieee-double-set! v 0 17.0 'little)
        (bytevector-ieee-double-ref v 0 'little))]
 
+    [(lambda (x) (= x 17.0))
+     (let ([v (make-bytevector 8)])
+       (bytevector-ieee-double-set! v 0 17.0 'big)
+       (bytevector-ieee-double-ref v 0 'big))]
+    
     [(lambda (x) (= x 17.0))
      (let ([v1 (make-bytevector 8)])
        (bytevector-ieee-double-set! v1 0 17.0 'little)

src/geninstr/Makefile

@@ -1,7 +0,0 @@
-
-all:
-	./gen.pl	> tmp.s
-	gcc	-o tmp.o -c tmp.s
-	otool	-t tmp.o 
-	otool -tv tmp.o
-

src/geninstr/gen.pl

@@ -1,131 +0,0 @@
-#!/usr/bin/perl -w
-
-my @regs = 
-  ('%eax', '%ecx', '%edx', '%ebx', '%esp', '%ebp', '%esi', '%edi');
-
-my @regs_no_esp = 
-  ('%eax', '%ecx', '%edx', '%ebx', '%ebp', '%esi', '%edi');
-
-print ".text\n";
-
-
-sub gen1{
-  my $tmpl = shift;
-  foreach my $r1 (@regs){
-      my $x = $tmpl;
-      $x =~ s/r1/$r1/g;
-      print $x;
-  }
-}
-
-
-
-
-sub gen2{
-  my $tmpl = shift;
-  foreach my $r1 (@regs){
-    foreach my $r2 (@regs){
-      my $x = $tmpl;
-      $x =~ s/r1/$r1/g;
-      $x =~ s/r2/$r2/g;
-      print $x;
-    }
-  }
-}
-
-sub gen2_no_esp{
-  my $tmpl = shift;
-  foreach my $r1 (@regs){
-    foreach my $r2 (@regs_no_esp){
-      my $x = $tmpl;
-      $x =~ s/r1/$r1/g;
-      $x =~ s/r2/$r2/g;
-      print $x;
-    }
-  }
-}
-
-
-
-sub gen3{
-  my $tmpl = shift;
-  foreach my $r1 (@regs){
-      foreach my $r3 (@regs_no_esp){
-    foreach my $r2 (@regs){
-        my $x = $tmpl;
-        $x =~ s/r1/$r1/g;
-        $x =~ s/r2/$r2/g;
-        $x =~ s/r3/$r3/g;
-        print $x;
-      }
-    }
-  }
-}
-
-#gen1 "addl \$0x12345678, 7(r1)\n";
-
-#gen2 "addl 0x23(r1), r2\n";
-gen2_no_esp "movb \$24, 0(r1,r2)\n";
-
-#gen1 "movb \$0, 4(r1)\n";
-#gen1 "movb -2(r1), %ah\n";
-
-#gen2 "xorl r1,r2\n";
-
-#gen3 "movl (r2,r3), r1\n";
-
-
-#print "sete %al\n";
-#print "sete %cl\n";
-#print "sete %dl\n";
-#print "sete %bl\n";
-#print "sete %ah\n";
-#print "sete %ch\n";
-#print "sete %dh\n";
-#print "sete %bh\n";
-
-#gen1 "pop r1\n";
-#gen1 "pop 12(r1)\n";
-#gen1 "pop 10000(r1)\n";
-#print "pushl \$0x5\n";
-#print "pushl \$0x500\n";
-#gen1 "pushl r1\n";
-#gen1 "pushl 1(r1)\n";
-#gen1 "pushl 1000(r1)\n";
-#gen2 "orl 12(r2), r1\n";
-#gen1 "orl \$0x400, r1\n";
-#gen1 "cmpl \$0x4, r1\n";
-#gen2 "cmpl 12(r2), r1\n";
-#gen1 "cmpl \$0x400, 12(r1)\n";
-#gen1 "cmpl \$0x4, 12000(r1)\n";
-#gen1 "cmpl \$0x400, 12(r1)\n";
-#gen2 "cmp r2, r1\n";
-#gen1 "cmp \$0x312, r1\n";
-#gen1 "cmp \$0x3, r1\n";
-#gen2 "imull 0x10(r2), r1\n";
-#gen2 "imull r2, r1\n";
-#gen1 "imull \$0x1010, r1\n";
-#gen1 "imull \$0x1000, r1\n";
-#print "movl \$10, -1(%esp)\n";
-#gen1 "jmp *-3(r1)\n";
-#print "jmp L1+0x8\n";
-#print "L1:\n";
-#print "jmp .+0x8000\n";
-#gen1 "negl r1\n";
-#gen1 "notl r1\n";
-#gen2 "andl 0x1200(r2), r1\n";
-#gen2 "andl r1, r2\n";
-#gen1 "andl \$0x10, r1\n";
-#gen1 "sarl \$1, r1\n";
-#gen1 "sarl %cl, r1\n";
-#gen1 "sarl \$9, r1\n";
-#gen2 "addl 0x10(r2), r1\n";
-#gen2 "addl 0x100(r2), r1\n";
-#gen1 "addl \$0x12, 0x10(r1)\n";
-#gen1 "addl \$0x12, 0x100(r1)\n";
-#gen1 "addl \$0x120, 0x10(r1)\n";
-#gen1 "addl \$0x120, 0x100(r1)\n";
-#gen2 "addl r1, r2\n";
-#gen1 "addl \$0x10, r1\n";
-#gen1 "addl \$0x1000, r1\n";
-

src/geninstr/t.s

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

src/geninstr/tmp.s

@@ -1,57 +0,0 @@
-.text
-movb $24, 0(%eax,%eax)
-movb $24, 0(%eax,%ecx)
-movb $24, 0(%eax,%edx)
-movb $24, 0(%eax,%ebx)
-movb $24, 0(%eax,%ebp)
-movb $24, 0(%eax,%esi)
-movb $24, 0(%eax,%edi)
-movb $24, 0(%ecx,%eax)
-movb $24, 0(%ecx,%ecx)
-movb $24, 0(%ecx,%edx)
-movb $24, 0(%ecx,%ebx)
-movb $24, 0(%ecx,%ebp)
-movb $24, 0(%ecx,%esi)
-movb $24, 0(%ecx,%edi)
-movb $24, 0(%edx,%eax)
-movb $24, 0(%edx,%ecx)
-movb $24, 0(%edx,%edx)
-movb $24, 0(%edx,%ebx)
-movb $24, 0(%edx,%ebp)
-movb $24, 0(%edx,%esi)
-movb $24, 0(%edx,%edi)
-movb $24, 0(%ebx,%eax)
-movb $24, 0(%ebx,%ecx)
-movb $24, 0(%ebx,%edx)
-movb $24, 0(%ebx,%ebx)
-movb $24, 0(%ebx,%ebp)
-movb $24, 0(%ebx,%esi)
-movb $24, 0(%ebx,%edi)
-movb $24, 0(%esp,%eax)
-movb $24, 0(%esp,%ecx)
-movb $24, 0(%esp,%edx)
-movb $24, 0(%esp,%ebx)
-movb $24, 0(%esp,%ebp)
-movb $24, 0(%esp,%esi)
-movb $24, 0(%esp,%edi)
-movb $24, 0(%ebp,%eax)
-movb $24, 0(%ebp,%ecx)
-movb $24, 0(%ebp,%edx)
-movb $24, 0(%ebp,%ebx)
-movb $24, 0(%ebp,%ebp)
-movb $24, 0(%ebp,%esi)
-movb $24, 0(%ebp,%edi)
-movb $24, 0(%esi,%eax)
-movb $24, 0(%esi,%ecx)
-movb $24, 0(%esi,%edx)
-movb $24, 0(%esi,%ebx)
-movb $24, 0(%esi,%ebp)
-movb $24, 0(%esi,%esi)
-movb $24, 0(%esi,%edi)
-movb $24, 0(%edi,%eax)
-movb $24, 0(%edi,%ecx)
-movb $24, 0(%edi,%edx)
-movb $24, 0(%edi,%ebx)
-movb $24, 0(%edi,%ebp)
-movb $24, 0(%edi,%esi)
-movb $24, 0(%edi,%edi)