diff --git a/scheme/ikarus.boot.orig b/scheme/ikarus.boot.orig index f3b6484..69071c8 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 00e14d8..ebe634a 100644 --- a/scheme/ikarus.bytevectors.ss +++ b/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)) diff --git a/scheme/ikarus.compiler.altcogen.ss b/scheme/ikarus.compiler.altcogen.ss index d559117..b217445 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: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"))]) diff --git a/scheme/ikarus.intel-assembler.ss b/scheme/ikarus.intel-assembler.ss index 6a7ebef..9d7a508 100644 --- a/scheme/ikarus.intel-assembler.ss +++ b/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) - (cond - [(and (xmmreg? dst) (mem? src)) - (CODE #x66 - (CODE #x0F - (CODE #x38 - ((CODE/digit #x00 dst) src ac))))] - [else (error who "invalid" instr)])] + ;[(pshufb src dst) + ; ;;; unfortunately, this is an SSE3 instr. + ; (cond + ; [(and (xmmreg? dst) (mem? src)) + ; (CODE #x0F + ; (CODE #x38 + ; ((CODE/digit #x00 dst) src ac)))] + ; [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) diff --git a/scheme/makefile.ss b/scheme/makefile.ss index 2142ea7..8863d22 100755 --- a/scheme/makefile.ss +++ b/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] diff --git a/scheme/pass-specify-rep-primops.ss b/scheme/pass-specify-rep-primops.ss index 72acb66..8cef6fb 100644 --- a/scheme/pass-specify-rep-primops.ss +++ b/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) - (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)]) + (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)) + (with-tmp ([t (prm 'int+ (T bv) + (prm 'sra (T i) (K fixnum-shift)))]) + (with-tmp ([x0 (prm 'mref t (K bvoff))]) + (prm 'bswap! x0 x0) + (prm 'mset x (K (+ floff wordsize)) x0)) + (with-tmp ([x0 (prm 'mref t (K (+ bvoff wordsize)))]) + (prm 'bswap! x0 x0) + (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 diff --git a/scheme/tests/bytevectors.ss b/scheme/tests/bytevectors.ss index 25ca4eb..a7c7a28 100644 --- a/scheme/tests/bytevectors.ss +++ b/scheme/tests/bytevectors.ss @@ -286,6 +286,11 @@ (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 ([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)]) diff --git a/src/geninstr/Makefile b/src/geninstr/Makefile deleted file mode 100644 index 6a8a144..0000000 --- a/src/geninstr/Makefile +++ /dev/null @@ -1,7 +0,0 @@ - -all: - ./gen.pl > tmp.s - gcc -o tmp.o -c tmp.s - otool -t tmp.o - otool -tv tmp.o - diff --git a/src/geninstr/gen.pl b/src/geninstr/gen.pl deleted file mode 100755 index 230450b..0000000 --- a/src/geninstr/gen.pl +++ /dev/null @@ -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"; - diff --git a/src/geninstr/t.s b/src/geninstr/t.s deleted file mode 100644 index 5c32913..0000000 --- a/src/geninstr/t.s +++ /dev/null @@ -1,4 +0,0 @@ - -.text - pshufb ($0x12345678), %xmm0 - ret diff --git a/src/geninstr/tmp.dump b/src/geninstr/tmp.dump deleted file mode 100644 index e69de29..0000000 diff --git a/src/geninstr/tmp.s b/src/geninstr/tmp.s deleted file mode 100644 index bc551ee..0000000 --- a/src/geninstr/tmp.s +++ /dev/null @@ -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)