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

Now passing 682 tests in 64-bit mode.

This commit is contained in:
Abdulaziz Ghuloum 2008-04-09 05:34:36 -04:00
parent f63f85e1cc
commit 866b2b1c17
5 changed files with 138 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2338,6 +2338,16 @@
(E (make-asm-instr 'move u a)) (E (make-asm-instr 'move u a))
(make-asm-instr op u b))) (make-asm-instr op u b)))
x)] x)]
[(and (not (mem? a)) (not (small-operand? a)))
(let ([u (mku)])
(make-seq
(E (make-asm-instr 'move u a))
(P (make-asm-instr op u b))))]
[(and (not (mem? b)) (not (small-operand? b)))
(let ([u (mku)])
(make-seq
(E (make-asm-instr 'move u b))
(P (make-asm-instr op a u))))]
[(and (mem? a) (mem? b)) [(and (mem? a) (mem? b))
(let ([u (mku)]) (let ([u (mku)])
(make-seq (make-seq

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

@ -401,11 +401,11 @@
[(and (imm8? a0) (reg32? a1)) [(and (imm8? a0) (reg32? a1))
(ModRM 1 /d a1 (IMM8 a0 ac))] (ModRM 1 /d a1 (IMM8 a0 ac))]
[(and (imm? a0) (reg32? a1)) [(and (imm? a0) (reg32? a1))
(ModRM 2 /d a1 (IMM a0 ac))] (ModRM 2 /d a1 (IMM32 a0 ac))]
[(and (imm8? a1) (reg32? a0)) [(and (imm8? a1) (reg32? a0))
(ModRM 1 /d a0 (IMM8 a1 ac))] (ModRM 1 /d a0 (IMM8 a1 ac))]
[(and (imm? a1) (reg32? a0)) [(and (imm? a1) (reg32? a0))
(ModRM 2 /d a0 (IMM a1 ac))] (ModRM 2 /d a0 (IMM32 a1 ac))]
[(and (reg32? a0) (reg32? a1)) [(and (reg32? a0) (reg32? a1))
(RegReg /d a0 a1 ac)] (RegReg /d a0 a1 ac)]
[(and (imm? a0) (imm? a1)) [(and (imm? a0) (imm? a1))
@ -536,6 +536,7 @@
(define (CCI32 c0 c1 i32 ac) (define (CCI32 c0 c1 i32 ac)
(CODE c0 (CODE c1 (IMM32 i32 ac)))) (CODE c0 (CODE c1 (IMM32 i32 ac))))
(define (dotrace orig ls) (define (dotrace orig ls)
(printf "TRACE: ~s\n" (printf "TRACE: ~s\n"
(let f ([ls ls]) (let f ([ls ls])
@ -580,7 +581,7 @@
[(addl src dst) [(addl src dst)
(cond (cond
[(and (imm8? src) (reg? dst)) (CR* #x83 '/0 dst (IMM8 src ac))] [(and (imm8? src) (reg? dst)) (CR* #x83 '/0 dst (IMM8 src ac))]
[(and (imm32? src) (eq? dst '%eax)) (CODE #x05 (IMM32 src ac))] [(and (imm32? src) (eq? dst '%eax)) (C #x05 (IMM32 src ac))]
[(and (imm32? src) (reg? dst)) (CR* #x81 '/0 dst (IMM32 src ac))] [(and (imm32? src) (reg? dst)) (CR* #x81 '/0 dst (IMM32 src ac))]
[(and (reg? src) (reg? dst)) (CR* #x01 src dst ac)] [(and (reg? src) (reg? dst)) (CR* #x01 src dst ac)]
[(and (mem? src) (reg? dst)) (CR* #x03 dst src ac)] [(and (mem? src) (reg? dst)) (CR* #x03 dst src ac)]
@ -590,7 +591,7 @@
[(subl src dst) [(subl src dst)
(cond (cond
[(and (imm8? src) (reg? dst)) (CR* #x83 '/5 dst (IMM8 src ac))] [(and (imm8? src) (reg? dst)) (CR* #x83 '/5 dst (IMM8 src ac))]
[(and (imm32? src) (eq? dst '%eax)) (CODE #x2D (IMM32 src ac))] [(and (imm32? src) (eq? dst '%eax)) (C #x2D (IMM32 src ac))]
[(and (imm32? src) (reg? dst)) (CR* #x81 '/5 dst (IMM32 src ac))] [(and (imm32? src) (reg? dst)) (CR* #x81 '/5 dst (IMM32 src ac))]
[(and (reg? src) (reg? dst)) (CR* #x29 src dst ac)] [(and (reg? src) (reg? dst)) (CR* #x29 src dst ac)]
[(and (mem? src) (reg? dst)) (CR* #x2B dst src ac)] [(and (mem? src) (reg? dst)) (CR* #x2B dst src ac)]

2
scheme/last-revision
View File

@ -1 +1 @@
1441 1442

96
scheme/test64.ss
View File

@ -101,10 +101,14 @@
[char->fixnum $char->fixnum] [char->fixnum $char->fixnum]
[procedure? procedure?] [procedure? procedure?]
[fxzero? $fxzero?] [fxzero? $fxzero?]
[vector vector]
[symbol? symbol?]
)) ))
(define (fixup x) (define (fixup x)
(define (P x)
`(primitive ,x))
(define (Expr x env) (define (Expr x env)
(match x (match x
[,n (guard (self-evaluating? n)) `(quote ,n)] [,n (guard (self-evaluating? n)) `(quote ,n)]
@ -130,6 +134,22 @@
,(map (lambda (x) (Expr x env)) body*) ,(map (lambda (x) (Expr x env)) body*)
...)]) ...)])
,rhs* ...)))] ,rhs* ...)))]
[(letrec ([,lhs* ,rhs*] ...) ,body ,body* ...)
(let* ([nlhs* (map gensym lhs*)]
[env (append (map cons lhs* nlhs*) env)]
[E (lambda (x) (Expr x env))])
`(letrec ([,nlhs* ,(map E rhs*)] ...)
(begin
,(E body)
,(map E body*) ...)))]
[(letrec* ([,lhs* ,rhs*] ...) ,body ,body* ...)
(let* ([nlhs* (map gensym lhs*)]
[env (append (map cons lhs* nlhs*) env)]
[E (lambda (x) (Expr x env))])
`(letrec* ([,nlhs* ,(map E rhs*)] ...)
(begin
,(E body)
,(map E body*) ...)))]
[(lambda (,fml* ...) ,body ,body* ...) [(lambda (,fml* ...) ,body ,body* ...)
(let ([g* (map gensym fml*)]) (let ([g* (map gensym fml*)])
(let ([env (append (map cons fml* g*) env)]) (let ([env (append (map cons fml* g*) env)])
@ -138,8 +158,77 @@
(begin ,(Expr body env) (begin ,(Expr body env)
,(map (lambda (x) (Expr x env)) body*) ,(map (lambda (x) (Expr x env)) body*)
...)])))] ...)])))]
[(lambda (,fml* ... . ,fml) ,body ,body* ...)
(let ([g* (map gensym fml*)]
[g (gensym fml)])
(let ([env (append (map cons
(cons fml fml*)
(cons g g*))
env)])
`(case-lambda
[(,g* ... . ,g)
(begin ,(Expr body env)
,(map (lambda (x) (Expr x env)) body*)
...)])))]
[(begin ,[e] ,[e*] ...) [(begin ,[e] ,[e*] ...)
`(begin ,e ,e* ...)] `(begin ,e ,e* ...)]
[(and) ''#t]
[(and ,[e]) e]
[(and ,[e] ,e* ...)
`(if ,e ,(Expr `(and ,e* ...) env) (quote #f))]
[(or) ''#f]
[(or ,[e]) e]
[(or ,[e] ,e* ...)
(let ([t (gensym)])
`((case-lambda
[(,t)
(if ,t ,t ,(Expr `(or ,e* ...) env))])
,e))]
[(when ,[e] ,[b] ,[b*] ...)
`(if ,e
(begin ,b ,b* ...)
(,(P 'void)))]
[(unless ,[e] ,[b] ,[b*] ...)
`(if (,(P 'not) ,e)
(begin ,b ,b* ...)
(,(P 'void)))]
[(cond) `(,(P 'void))]
[(cond ,cls* ... ,cls)
(let ()
(define (fst-clause x rest)
(match x
[(,e ,arr ,v)
(guard (and (eq? arr '=>) (not (assq arr env))))
(let ([t (gensym)])
`((case-lambda
[(,t)
(if ,t (,(Expr v env) ,t) ,rest)])
,(Expr e env)))]
[(,e)
(let ([t (gensym)])
`((case-lambda
[(,t)
(if ,t ,t ,rest)])
,(Expr e env)))]
[(,e ,e* ...)
`(if ,(Expr e env)
(begin ,(map (lambda (x) (Expr x env)) e*) ...)
,rest)]
[,others (error 'cond "invalid clause" others)]))
(define (last-clause x)
(match x
[(,els ,e ,e* ...)
(guard (and (eq? els 'else) (not (assq els env))))
`(begin ,(Expr e env)
,(map (lambda (x) (Expr x env)) e*)
...)]
[,others
(fst-clause others `(,(P 'void)))]))
(let f ([cls* cls*] [ac (last-clause cls)])
(cond
[(null? cls*) ac]
[else (fst-clause (car cls*)
(f (cdr cls*) ac))])))]
[(set! ,x ,[v]) [(set! ,x ,[v])
(cond (cond
[(assq x env) => (lambda (p) `(set! ,(cdr p) ,v))] [(assq x env) => (lambda (p) `(set! ,(cdr p) ,v))]
@ -168,13 +257,16 @@
(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.2-req.scm")
(include "tests/tests-2.3-req.scm")) (include "tests/tests-2.3-req.scm")
(include "tests/tests-2.4-req.scm")
(include "tests/tests-2.6-req.scm")
(include "tests/tests-2.8-req.scm"))
(current-primitive-locations (current-primitive-locations
(lambda (x) (lambda (x)
(define prims (define prims
'(do-overflow '(do-overflow
do-vararg-overflow
error error
$do-event $do-event
$apply-nonprocedure-error-handler $apply-nonprocedure-error-handler

41
src/ikarus-print.c
View File

@ -84,20 +84,35 @@ print(FILE* fh, ikptr x){
} }
#endif #endif
else if(tagof(x) == vector_tag){ else if(tagof(x) == vector_tag){
ikptr len = ref(x, off_vector_length); ikptr fst = ref(x, off_vector_length);
if(len == 0){ if(is_fixnum(fst)){
fprintf(fh, "#()"); ikptr len = fst;
} else { if(len == 0){
fprintf(fh, "#("); fprintf(fh, "#()");
ikptr data = x + off_vector_data; } else {
print(fh, ref(data, 0)); fprintf(fh, "#(");
ikptr i = (ikptr)wordsize; ikptr data = x + off_vector_data;
while(i<len){ print(fh, ref(data, 0));
fprintf(fh, " "); ikptr i = (ikptr)wordsize;
print(fh, ref(data,i)); while(i<len){
i += wordsize; fprintf(fh, " ");
print(fh, ref(data,i));
i += wordsize;
}
fprintf(fh, ")");
} }
fprintf(fh, ")"); } else if (fst == symbol_record_tag){
ikptr str = ref(x, off_symbol_record_string);
ikptr fxlen = ref(str, off_string_length);
int len = unfix(fxlen);
int * data = (int*)(str + off_string_data);
int i;
for(i=0; i<len; i++){
char c = (data[i]) >> char_shift;
fprintf(fh, "%c", c);
}
} else {
fprintf(fh, "#<unknown fst=0x%p>", (void*)fst);
} }
} }
else if(is_closure(x)){ else if(is_closure(x)){