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

fixed a couple of bugs in 64bit assembler.

This commit is contained in:
Abdulaziz Ghuloum 2008-04-08 02:22:26 -04:00
parent 6bdb38ca16
commit 5eaa2ff469
4 changed files with 53 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -205,6 +205,8 @@
(byte (sra n 16)) (byte (sra n 16))
(byte (sra n 24)) (byte (sra n 24))
ac)] ac)]
[(label? n)
(cons (cons 'relative (label-name n)) ac)]
[else (die 'IMM32 "invalid" n)]))) [else (die 'IMM32 "invalid" n)])))
(define IMM (define IMM
@ -531,11 +533,11 @@
(define (CCI32 c0 c1 i32 ac) (define (CCI32 c0 c1 i32 ac)
(CODE c0 (CODE c1 (IMM 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])
(if (eq? ls orig) (if (eq? ls orig)
'() '()
(cons (car ls) (f (cdr ls)))))) (cons (car ls) (f (cdr ls))))))
@ -672,7 +674,7 @@
[(notl dst) [(notl dst)
(cond (cond
[(reg? dst) (CR* #xF7 '/2 dst ac)] [(reg? dst) (CR* #xF7 '/2 dst ac)]
[(mem? dst) (CR* #xF7 '/7 dst ac)] [(mem? dst) (CR* #xF7 '/7 dst ac)]
[else (die who "invalid" instr)])] [else (die who "invalid" instr)])]
[(bswap dst) [(bswap dst)
(cond (cond
@ -680,18 +682,18 @@
[else (die who "invalid" instr)])] [else (die who "invalid" instr)])]
[(negl dst) [(negl dst)
(cond (cond
[(reg? dst) (CR* #xF7 '/3 dst ac)] [(reg? dst) (CR* #xF7 '/3 dst ac)]
[else (die who "invalid" instr)])] [else (die who "invalid" instr)])]
[(jmp dst) [(jmp dst)
(cond (cond
[(imm? dst) (CODE #xE9 (IMM dst ac))] [(imm? dst) (CODE #xE9 (IMM32 dst ac))]
[(mem? dst) (CR* #xFF '/4 dst ac)] [(mem? dst) (CR* #xFF '/4 dst ac)]
[else (die who "invalid jmp target" dst)])] [else (die who "invalid jmp target" dst)])]
[(call dst) [(call dst)
(cond (cond
[(imm? dst) (CODE #xE8 (IMM dst ac))] [(imm? dst) (CODE #xE8 (IMM32 dst ac))]
[(mem? dst) (CR* #xFF '/2 dst ac)] [(mem? dst) (CR* #xFF '/2 dst ac)]
[(reg? dst) (CR* #xFF '/2 dst ac)] [(reg? dst) (CR* #xFF '/2 dst ac)]
[else (die who "invalid jmp target" dst)])] [else (die who "invalid jmp target" dst)])]
[(movsd src dst) [(movsd src dst)
(cond (cond
@ -782,11 +784,11 @@
(fx+ ac 1) (fx+ ac 1)
(case (car x) (case (car x)
[(byte) (fx+ ac 1)] [(byte) (fx+ ac 1)]
[(reloc-word reloc-word+ label-addr foreign-label [(relative reloc-word+ foreign-label local-relative)
local-relative)
(fx+ ac 4)] (fx+ ac 4)]
[(label) ac] [(label) ac]
[(word relative current-frame-offset) (+ ac wordsize)] [(word reloc-word label-addr current-frame-offset)
(+ ac wordsize)]
[else (die 'compute-code-size "unknown instr" x)]))) [else (die 'compute-code-size "unknown instr" x)])))
0 0
ls))) ls)))
@ -856,11 +858,11 @@
[(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 reloc-word+) [(reloc-word+)
(f (cdr ls) (fx+ idx 4) (cons (cons idx a) reloc))] (f (cdr ls) (fx+ idx 4) (cons (cons idx a) reloc))]
[(local-relative label-addr 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))]
[(relative) [(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 @@
1438 1439

35
scheme/test64.ss
View File

@ -99,6 +99,8 @@
[char= $char=] [char= $char=]
[fixnum->char $fixnum->char] [fixnum->char $fixnum->char]
[char->fixnum $char->fixnum] [char->fixnum $char->fixnum]
[procedure? procedure?]
[fxzero? $fxzero?]
)) ))
@ -128,6 +130,14 @@
,(map (lambda (x) (Expr x env)) body*) ,(map (lambda (x) (Expr x env)) body*)
...)]) ...)])
,rhs* ...)))] ,rhs* ...)))]
[(lambda (,fml* ...) ,body ,body* ...)
(let ([g* (map gensym fml*)])
(let ([env (append (map cons fml* g*) env)])
`(case-lambda
[(,g* ...)
(begin ,(Expr body env)
,(map (lambda (x) (Expr x env)) body*)
...)])))]
[(begin ,[e] ,[e*] ...) [(begin ,[e] ,[e*] ...)
`(begin ,e ,e* ...)] `(begin ,e ,e* ...)]
[,_ (error 'fixup "invalid expression" _)])) [,_ (error 'fixup "invalid expression" _)]))
@ -141,21 +151,26 @@
(append all-tests (append all-tests
'([test string] ...)))]))) '([test string] ...)))])))
; (include "tests/tests-1.1-req.scm") (begin
; (include "tests/tests-1.2-req.scm") (include "tests/tests-1.1-req.scm")
; (include "tests/tests-1.3-req.scm") (include "tests/tests-1.2-req.scm")
; (include "tests/tests-1.4-req.scm") (include "tests/tests-1.3-req.scm")
; (include "tests/tests-1.5-req.scm") (include "tests/tests-1.4-req.scm")
; (include "tests/tests-1.6-req.scm") (include "tests/tests-1.5-req.scm")
; (include "tests/tests-1.7-req.scm") (include "tests/tests-1.6-req.scm")
; (include "tests/tests-1.8-req.scm") (include "tests/tests-1.7-req.scm")
(include "tests/tests-1.9-req.scm") (include "tests/tests-1.8-req.scm")
(include "tests/tests-1.9-req.scm"))
(include "tests/tests-2.1-req.scm")
(current-primitive-locations (current-primitive-locations
(lambda (x) (lambda (x)
(define prims (define prims
'(do-overflow '(do-overflow
error
$do-event
$apply-nonprocedure-error-handler $apply-nonprocedure-error-handler
$incorrect-args-error-handler $incorrect-args-error-handler
$multiple-values-error)) $multiple-values-error))
@ -164,6 +179,8 @@
[else (error 'current-primloc "invalid" x)]))) [else (error 'current-primloc "invalid" x)])))
;(assembler-output #t)
(test-all) (test-all)
(printf "Passed ~s tests\n" (length all-tests)) (printf "Passed ~s tests\n" (length all-tests))
(printf "Happy Happy Joy Joy\n") (printf "Happy Happy Joy Joy\n")

16
src/ikarus-fasl.c
View File

@ -183,11 +183,17 @@ ik_relocate_code(ikptr code){
else if(tag == 3){ else if(tag == 3){
/* jump label */ /* jump label */
long int obj_off = unfix(ref(p, wordsize)); long int obj_off = unfix(ref(p, wordsize));
ikptr obj = ref(p, 2*wordsize); long int obj = ref(p, 2*wordsize);
ikptr displaced_object = obj + obj_off; long int displaced_object = obj + obj_off;
ikptr next_word = data + code_off + wordsize; long int next_word = data + code_off + 4;
ikptr relative_distance = displaced_object - (long int)next_word; long int relative_distance = displaced_object - next_word;
ref(next_word, -wordsize) = relative_distance; #if 0
if(wordsize == 8){
relative_distance += 4;
}
#endif
*((int*)(data+code_off)) = relative_distance;
// ref(next_word, -wordsize) = relative_distance;
p += (3*wordsize); p += (3*wordsize);
} }
else if(tag == 1){ else if(tag == 1){