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

570 tests in 64-bit mode

This commit is contained in:
Abdulaziz Ghuloum 2008-04-09 03:05:19 -04:00
parent aa44ce2733
commit f63f85e1cc
7 changed files with 91 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -486,6 +486,11 @@
(S* rands
(lambda (rands)
(make-set d (make-disp (car rands) (cadr rands)))))]
[(mref32)
(S* rands
(lambda (rands)
(make-asm-instr 'load32 d
(make-disp (car rands) (cadr rands)))))]
[(bref)
(S* rands
(lambda (rands)
@ -571,7 +576,7 @@
(do-bind lhs* rhs* (E e))]
[(primcall op rands)
(case op
[(mset bset/c bset/h)
[(mset bset/c bset/h mset32)
(S* rands
(lambda (s*)
(make-asm-instr op
@ -1280,7 +1285,7 @@
(union-nfvs ns1 ns2)))]
[(asm-instr op d s)
(case op
[(move move-byte)
[(move move-byte load32)
(cond
[(reg? d)
(cond
@ -1459,7 +1464,7 @@
[(cltd)
(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!
[(mset mset32 bset/c bset/h fl:load fl:store fl:add! fl:sub!
fl:mul! fl:div! fl:from-int fl:shuffle
fl:load-single fl:store-single)
(R* (list s d) vs rs fs ns)]
@ -1655,14 +1660,14 @@
(make-conditional (P e0) (E e1) (E e2))]
[(asm-instr op d s)
(case op
[(move move-byte)
[(move move-byte load32)
(let ([d (R d)] [s (R s)])
(cond
[(eq? d s)
(make-primcall 'nop '())]
[else
(make-asm-instr op d s)]))]
[(logand logor logxor int+ int- int* mset bset/c bset/h
[(logand logor logxor int+ int- int* mset mset32 bset/c bset/h
sll sra srl bswap!
cltd idiv int-/overflow int+/overflow int*/overflow
fl:load fl:store fl:add! fl:sub! fl:mul! fl:div!
@ -1872,7 +1877,7 @@
(struct-case x
[(asm-instr op d v)
(case op
[(move)
[(move load32)
(let ([s (set-rem d s)])
(set-for-each (lambda (y) (add-edge! g d y)) s)
(set-union (R v) s))]
@ -1915,7 +1920,7 @@
s))
(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!
[(mset mset32 fl:load fl:store fl:add! fl:sub! fl:mul! fl:div!
fl:from-int fl:shuffle fl:store-single
fl:load-single)
(set-union (R v) (set-union (R d) s))]
@ -2176,7 +2181,8 @@
(make-conditional (P e0) (E e1) (E e2))]
[(asm-instr op a b)
(case op
[(logor logxor logand int+ int- int* move move-byte
[(logor logxor logand int+ int- int* move
move-byte load32
int-/overflow int+/overflow int*/overflow)
(cond
[(and (eq? op 'move) (eq? a b))
@ -2196,19 +2202,26 @@
(E (make-asm-instr op u b)))
(E (make-asm-instr 'move a u))))]
[(and (mem? a) (not (small-operand? b)))
(case op
[(load32)
(let ([u (mku)])
(make-seq
(E (make-asm-instr 'load32 u b))
(E (make-asm-instr 'move a u))))]
[else
(let ([u (mku)])
(make-seq
(E (make-asm-instr 'move u b))
(E (make-asm-instr op a u))))]
(E (make-asm-instr op a u))))])]
[(disp? a)
(let ([s0 (disp-s0 a)] [s1 (disp-s1 a)])
(cond
[(mem? s0)
[(not (small-operand? s0))
(let ([u (mku)])
(make-seq
(E (make-asm-instr 'move u s0))
(E (make-asm-instr op (make-disp u s1) b))))]
[(mem? s1)
[(not (small-operand? s1))
(let ([u (mku)])
(make-seq
(E (make-asm-instr 'move u s1))
@ -2222,12 +2235,12 @@
[(disp? b)
(let ([s0 (disp-s0 b)] [s1 (disp-s1 b)])
(cond
[(mem? s0)
[(not (small-operand? s0))
(let ([u (mku)])
(make-seq
(E (make-asm-instr 'move u s0))
(E (make-asm-instr op a (make-disp u s1)))))]
[(mem? s1)
[(not (small-operand? s1))
(let ([u (mku)])
(make-seq
(E (make-asm-instr 'move u s1))
@ -2259,7 +2272,7 @@
(eq? b ecx))
(error who "invalid shift" b))
x]
[(mset bset/c bset/h)
[(mset mset32 bset/c bset/h)
(cond
[(not (small-operand? b))
(let ([u (mku)])
@ -2299,7 +2312,7 @@
(E (make-asm-instr op u b))))]
[else x])]
[(fl:from-int fl:shuffle) x]
[else (error who "invalid effect" op)])]
[else (error who "invalid effect op" op)])]
[(primcall op rands)
(case op
[(nop interrupt incr/zero? fl:single->double
@ -2568,6 +2581,8 @@
(let ([s (R s)] [d (R d)])
(unless (eq? s d) (error who "invalid instr" x))
(cons `(bswap ,s) ac))]
[(mset32) (cons `(mov32 ,(R s) ,(R d)) ac)]
[(load32) (cons `(mov32 ,(R s) ,(R d)) ac)]
[(int-/overflow)
(let ([L (or (exception-label)
(error who "no exception label"))])

1
scheme/ikarus.compiler.ss
View File

@ -2450,6 +2450,7 @@
(define unbound #x6F) ; double check
(define void-object #x7F) ; double check
(define bwp-object #x8F) ; double check
(define char-size 4)
(define char-shift 8)
(define char-tag #x0F)
(define char-mask #xFF)

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

@ -451,13 +451,13 @@
[(and (imm? a0) (reg32? a1))
(error 'REC+RM "not here 1")
(if (reg-requires-REX? a1)
(C 0 (REX.R #b101 ac))
(C 1 (REX.R #b100 ac)))]
(REX.R #b101 ac)
(REX.R #b100 ac))]
[(and (imm? a1) (reg32? a0))
(error 'REC+RM "not here 2")
(if (reg-requires-REX? a0)
(C 2 (REX.R #b101 ac))
(C 3 (REX.R #b100 ac)))]
(REX.R #b101 ac)
(REX.R #b100 ac))]
[(and (reg32? a0) (reg32? a1))
(error 'REC+RM "not here 3")
(if (or (reg-requires-REX? a0) (reg-requires-REX? a1))
@ -482,7 +482,7 @@
(if (reg-requires-REX? a0)
(if (reg-requires-REX? a1)
(error 'REX+RM "unhandled x1" a0 a1)
(C 6 (REX.R #b010 ac)))
(REX.R #b010 ac))
(if (reg-requires-REX? a1)
(error 'REX+RM "unhandled x3" a0 a1)
(REX.R 0 ac)))]
@ -519,11 +519,12 @@
(define (CR c r ac)
(REX+r r (CODE+r c r ac)))
(define (CR* c r rm ac)
;(CODE c (RM r rm ac)))
(REX+RM r rm (CODE c (RM r rm ac))))
(define (CR*-no-rex c r rm ac)
(CODE c (RM r rm ac)))
(define (CCR* c0 c1 r rm ac)
(CODE c0 (CODE c1 (RM r rm ac))))
;(REX+RM r rm (CODE c0 (CODE c1 (RM r rm ac)))))
;(CODE c0 (CODE c1 (RM r rm ac))))
(REX+RM r rm (CODE c0 (CODE c1 (RM r rm ac)))))
(define (CCR c0 c1 r ac)
(CODE c0 (CODE+r c1 r ac)))
;(REX+r r (CODE c0 (CODE+r c1 r ac))))
@ -554,6 +555,22 @@
[(and (reg? src) (mem? dst)) (CR* #x89 src dst ac)]
[(and (mem? src) (reg? dst)) (CR* #x8B dst src ac)]
[else (die who "invalid" instr)])]
[(mov32 src dst)
;;; FIXME
(cond
[(and (imm? src) (reg? dst))
(error 'mov32 "here1")
(CR #xB8 dst (IMM32 src ac))]
[(and (imm? src) (mem? dst)) (CR*-no-rex #xC7 '/0 dst (IMM32 src ac))]
[(and (reg? src) (reg? dst))
(error 'mov32 "here3")
(CR* #x89 src dst ac)]
[(and (reg? src) (mem? dst)) (CR*-no-rex #x89 src dst ac)]
[(and (mem? src) (reg? dst))
(if (= wordsize 4)
(CR* #x8B dst src ac)
(CCR* #x0F #xB7 dst src ac))]
[else (die who "invalid" instr)])]
[(movb src dst)
(cond
[(and (imm8? src) (mem? dst)) (CR* #xC6 '/0 dst (IMM8 src ac))]
@ -784,10 +801,10 @@
(fx+ ac 1)
(case (car x)
[(byte) (fx+ ac 1)]
[(relative reloc-word+ foreign-label local-relative)
[(relative foreign-label local-relative)
(fx+ ac 4)]
[(label) ac]
[(word reloc-word label-addr current-frame-offset)
[(word reloc-word reloc-word+ label-addr current-frame-offset)
(+ ac wordsize)]
[else (die 'compute-code-size "unknown instr" x)])))
0
@ -858,11 +875,9 @@
[(byte)
(code-set! x idx (cdr a))
(f (cdr ls) (fx+ idx 1) reloc)]
[(reloc-word+)
(f (cdr ls) (fx+ idx 4) (cons (cons idx a) reloc))]
[(relative local-relative foreign-label)
(f (cdr ls) (fx+ idx 4) (cons (cons idx a) reloc))]
[(reloc-word label-addr)
[(reloc-word reloc-word+ label-addr)
(f (cdr ls) (fx+ idx wordsize) (cons (cons idx a) reloc))]
[(word)
(let ([v (cdr a)])

2
scheme/last-revision
View File

@ -1 +1 @@
1440
1441

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

@ -1857,12 +1857,16 @@
(struct-case i
[(constant i)
(unless (fixnum? i) (interrupt))
(prm 'mref (T s)
(K (+ (* i fx-scale)
(prm 'mref32 (T s)
(K (+ (* i char-size)
(- disp-string-data string-tag))))]
[else
(prm 'mref (T s)
(prm 'int+ (T i)
(prm 'mref32 (T s)
(prm 'int+
(cond
[(= wordsize char-size) (T i)]
[(= wordsize 8) (prm 'sra (T i) (K 1))]
[else (error '$string-ref "invalid operand")])
(K (- disp-string-data string-tag))))])]
[(P s i) (K #t)]
[(E s i) (nop)])
@ -1903,12 +1907,18 @@
(struct-case i
[(constant i)
(unless (fixnum? i) (interrupt))
(prm 'mset (T x)
(K (+ (* i fx-scale) (- disp-string-data string-tag)))
(prm 'mset32 (T x)
(K (+ (* i char-size)
(- disp-string-data string-tag)))
(T c))]
[else
(prm 'mset (T x)
(prm 'int+ (T i) (K (- disp-string-data string-tag)))
(prm 'mset32 (T x)
(prm 'int+
(cond
[(= wordsize char-size) (T i)]
[(= wordsize 8) (prm 'sra (T i) (K 1))]
[else (error '$string-set! "invalid operand")])
(K (- disp-string-data string-tag)))
(T c))])])
/section)

10
scheme/test64.ss
View File

@ -140,6 +140,11 @@
...)])))]
[(begin ,[e] ,[e*] ...)
`(begin ,e ,e* ...)]
[(set! ,x ,[v])
(cond
[(assq x env) => (lambda (p) `(set! ,(cdr p) ,v))]
[else (error 'fixup "unbound" x)])]
[(,[rator] ,[rand*] ...) `(,rator ,rand* ...)]
[,_ (error 'fixup "invalid expression" _)]))
(Expr x '()))
@ -160,9 +165,10 @@
(include "tests/tests-1.6-req.scm")
(include "tests/tests-1.7-req.scm")
(include "tests/tests-1.8-req.scm")
(include "tests/tests-1.9-req.scm"))
(include "tests/tests-1.9-req.scm")
(include "tests/tests-2.1-req.scm")
(include "tests/tests-2.2-req.scm")
(include "tests/tests-2.3-req.scm"))
(current-primitive-locations

2
src/ikarus-print.c
View File

@ -129,7 +129,7 @@ print(FILE* fh, ikptr x){
else if(tagof(x) == string_tag){
ikptr fxlen = ref(x, off_string_length);
int len = unfix(fxlen);
long int * data = (long int*)(x + off_string_data);
int * data = (int*)(x + off_string_data);
fprintf(fh, "\"");
int i;
for(i=0; i<len; i++){