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

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

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

1
scheme/ikarus.compiler.ss
View File

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

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

@ -451,13 +451,13 @@
[(and (imm? a0) (reg32? a1)) [(and (imm? a0) (reg32? a1))
(error 'REC+RM "not here 1") (error 'REC+RM "not here 1")
(if (reg-requires-REX? a1) (if (reg-requires-REX? a1)
(C 0 (REX.R #b101 ac)) (REX.R #b101 ac)
(C 1 (REX.R #b100 ac)))] (REX.R #b100 ac))]
[(and (imm? a1) (reg32? a0)) [(and (imm? a1) (reg32? a0))
(error 'REC+RM "not here 2") (error 'REC+RM "not here 2")
(if (reg-requires-REX? a0) (if (reg-requires-REX? a0)
(C 2 (REX.R #b101 ac)) (REX.R #b101 ac)
(C 3 (REX.R #b100 ac)))] (REX.R #b100 ac))]
[(and (reg32? a0) (reg32? a1)) [(and (reg32? a0) (reg32? a1))
(error 'REC+RM "not here 3") (error 'REC+RM "not here 3")
(if (or (reg-requires-REX? a0) (reg-requires-REX? a1)) (if (or (reg-requires-REX? a0) (reg-requires-REX? a1))
@ -482,7 +482,7 @@
(if (reg-requires-REX? a0) (if (reg-requires-REX? a0)
(if (reg-requires-REX? a1) (if (reg-requires-REX? a1)
(error 'REX+RM "unhandled x1" a0 a1) (error 'REX+RM "unhandled x1" a0 a1)
(C 6 (REX.R #b010 ac))) (REX.R #b010 ac))
(if (reg-requires-REX? a1) (if (reg-requires-REX? a1)
(error 'REX+RM "unhandled x3" a0 a1) (error 'REX+RM "unhandled x3" a0 a1)
(REX.R 0 ac)))] (REX.R 0 ac)))]
@ -519,11 +519,12 @@
(define (CR c r ac) (define (CR c r ac)
(REX+r r (CODE+r c r ac))) (REX+r r (CODE+r c r ac)))
(define (CR* c r rm ac) (define (CR* c r rm ac)
;(CODE c (RM r rm ac)))
(REX+RM r rm (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) (define (CCR* c0 c1 r rm ac)
(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))))) (REX+RM r rm (CODE c0 (CODE c1 (RM r rm ac)))))
(define (CCR c0 c1 r ac) (define (CCR c0 c1 r ac)
(CODE c0 (CODE+r c1 r ac))) (CODE c0 (CODE+r c1 r ac)))
;(REX+r r (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 (reg? src) (mem? dst)) (CR* #x89 src dst ac)]
[(and (mem? src) (reg? dst)) (CR* #x8B dst src ac)] [(and (mem? src) (reg? dst)) (CR* #x8B dst src ac)]
[else (die who "invalid" instr)])] [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) [(movb src dst)
(cond (cond
[(and (imm8? src) (mem? dst)) (CR* #xC6 '/0 dst (IMM8 src ac))] [(and (imm8? src) (mem? dst)) (CR* #xC6 '/0 dst (IMM8 src ac))]
@ -784,10 +801,10 @@
(fx+ ac 1) (fx+ ac 1)
(case (car x) (case (car x)
[(byte) (fx+ ac 1)] [(byte) (fx+ ac 1)]
[(relative reloc-word+ foreign-label local-relative) [(relative foreign-label local-relative)
(fx+ ac 4)] (fx+ ac 4)]
[(label) ac] [(label) ac]
[(word reloc-word label-addr current-frame-offset) [(word reloc-word reloc-word+ label-addr current-frame-offset)
(+ ac wordsize)] (+ ac wordsize)]
[else (die 'compute-code-size "unknown instr" x)]))) [else (die 'compute-code-size "unknown instr" x)])))
0 0
@ -858,11 +875,9 @@
[(byte) [(byte)
(code-set! x idx (cdr a)) (code-set! x idx (cdr a))
(f (cdr ls) (fx+ idx 1) reloc)] (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) [(relative local-relative foreign-label)
(f (cdr ls) (fx+ idx 4) (cons (cons idx a) reloc))] (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))] (f (cdr ls) (fx+ idx wordsize) (cons (cons idx a) reloc))]
[(word) [(word)
(let ([v (cdr a)]) (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 (struct-case i
[(constant i) [(constant i)
(unless (fixnum? i) (interrupt)) (unless (fixnum? i) (interrupt))
(prm 'mref (T s) (prm 'mref32 (T s)
(K (+ (* i fx-scale) (K (+ (* i char-size)
(- disp-string-data string-tag))))] (- disp-string-data string-tag))))]
[else [else
(prm 'mref (T s) (prm 'mref32 (T s)
(prm 'int+ (T i) (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))))])] (K (- disp-string-data string-tag))))])]
[(P s i) (K #t)] [(P s i) (K #t)]
[(E s i) (nop)]) [(E s i) (nop)])
@ -1903,12 +1907,18 @@
(struct-case i (struct-case i
[(constant i) [(constant i)
(unless (fixnum? i) (interrupt)) (unless (fixnum? i) (interrupt))
(prm 'mset (T x) (prm 'mset32 (T x)
(K (+ (* i fx-scale) (- disp-string-data string-tag))) (K (+ (* i char-size)
(- disp-string-data string-tag)))
(T c))] (T c))]
[else [else
(prm 'mset (T x) (prm 'mset32 (T x)
(prm 'int+ (T i) (K (- disp-string-data string-tag))) (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))])]) (T c))])])
/section) /section)

12
scheme/test64.ss
View File

@ -140,6 +140,11 @@
...)])))] ...)])))]
[(begin ,[e] ,[e*] ...) [(begin ,[e] ,[e*] ...)
`(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" _)])) [,_ (error 'fixup "invalid expression" _)]))
(Expr x '())) (Expr x '()))
@ -160,9 +165,10 @@
(include "tests/tests-1.6-req.scm") (include "tests/tests-1.6-req.scm")
(include "tests/tests-1.7-req.scm") (include "tests/tests-1.7-req.scm")
(include "tests/tests-1.8-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.1-req.scm") (include "tests/tests-2.2-req.scm")
(include "tests/tests-2.3-req.scm"))
(current-primitive-locations (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){ else if(tagof(x) == string_tag){
ikptr fxlen = ref(x, off_string_length); ikptr fxlen = ref(x, off_string_length);
int len = unfix(fxlen); int len = unfix(fxlen);
long int * data = (long int*)(x + off_string_data); int * data = (int*)(x + off_string_data);
fprintf(fh, "\""); fprintf(fh, "\"");
int i; int i;
for(i=0; i<len; i++){ for(i=0; i<len; i++){