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

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

This commit is contained in:
Abdulaziz Ghuloum 2007-11-07 04:54:54 -05:00
parent 7dbce6e888
commit 1b103a4ab8
12 changed files with 90 additions and 232 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
scheme/ikarus.boot.orig
View File

Binary file not shown.

10
scheme/ikarus.bytevectors.ss
View File

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

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

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

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

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

3
scheme/makefile.ss
View File

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

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

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

5
scheme/tests/bytevectors.ss
View File

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

7
src/geninstr/Makefile
View File

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

131
src/geninstr/gen.pl
View File

@ -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";

4
src/geninstr/t.s
View File

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

0
src/geninstr/tmp.dump
View File

57
src/geninstr/tmp.s
View File

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