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

35
scheme/test64.ss
View File

@ -99,6 +99,8 @@
[char= $char=]
[fixnum->char $fixnum->char]
[char->fixnum $char->fixnum]
[procedure? procedure?]
[fxzero? $fxzero?]
))
@ -128,6 +130,14 @@
,(map (lambda (x) (Expr x env)) body*)
...)])
,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* ...)]
[,_ (error 'fixup "invalid expression" _)]))
@ -141,21 +151,26 @@
(append all-tests
'([test string] ...)))])))
; (include "tests/tests-1.1-req.scm")
; (include "tests/tests-1.2-req.scm")
; (include "tests/tests-1.3-req.scm")
; (include "tests/tests-1.4-req.scm")
; (include "tests/tests-1.5-req.scm")
; (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")
(begin
(include "tests/tests-1.1-req.scm")
(include "tests/tests-1.2-req.scm")
(include "tests/tests-1.3-req.scm")
(include "tests/tests-1.4-req.scm")
(include "tests/tests-1.5-req.scm")
(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-2.1-req.scm")
(current-primitive-locations
(lambda (x)
(define prims
'(do-overflow
error
$do-event
$apply-nonprocedure-error-handler
$incorrect-args-error-handler
$multiple-values-error))
@ -164,6 +179,8 @@
[else (error 'current-primloc "invalid" x)])))
;(assembler-output #t)
(test-all)
(printf "Passed ~s tests\n" (length all-tests))
(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){
/* jump label */
long int obj_off = unfix(ref(p, wordsize));
ikptr obj = ref(p, 2*wordsize);
ikptr displaced_object = obj + obj_off;
ikptr next_word = data + code_off + wordsize;
ikptr relative_distance = displaced_object - (long int)next_word;
ref(next_word, -wordsize) = relative_distance;
long int obj = ref(p, 2*wordsize);
long int displaced_object = obj + obj_off;
long int next_word = data + code_off + 4;
long int relative_distance = displaced_object - next_word;
#if 0
if(wordsize == 8){
relative_distance += 4;
}
#endif
*((int*)(data+code_off)) = relative_distance;
// ref(next_word, -wordsize) = relative_distance;
p += (3*wordsize);
}
else if(tag == 1){