From f63f85e1cca64b77a878a77409532b4643c46a18 Mon Sep 17 00:00:00 2001 From: Abdulaziz Ghuloum Date: Wed, 9 Apr 2008 03:05:19 -0400 Subject: [PATCH] 570 tests in 64-bit mode --- scheme/ikarus.compiler.altcogen.ss | 51 +++++++++++++++++++----------- scheme/ikarus.compiler.ss | 1 + scheme/ikarus.intel-assembler.ss | 41 ++++++++++++++++-------- scheme/last-revision | 2 +- scheme/pass-specify-rep-primops.ss | 26 ++++++++++----- scheme/test64.ss | 12 +++++-- src/ikarus-print.c | 2 +- 7 files changed, 91 insertions(+), 44 deletions(-) diff --git a/scheme/ikarus.compiler.altcogen.ss b/scheme/ikarus.compiler.altcogen.ss index 4d46107..5f37a15 100644 --- a/scheme/ikarus.compiler.altcogen.ss +++ b/scheme/ikarus.compiler.altcogen.ss @@ -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))) - (let ([u (mku)]) - (make-seq - (E (make-asm-instr 'move u b)) - (E (make-asm-instr op a u))))] + (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))))])] [(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"))]) diff --git a/scheme/ikarus.compiler.ss b/scheme/ikarus.compiler.ss index 09d10ba..e8030b1 100644 --- a/scheme/ikarus.compiler.ss +++ b/scheme/ikarus.compiler.ss @@ -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) diff --git a/scheme/ikarus.intel-assembler.ss b/scheme/ikarus.intel-assembler.ss index 84c9c9d..6239edc 100644 --- a/scheme/ikarus.intel-assembler.ss +++ b/scheme/ikarus.intel-assembler.ss @@ -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)]) diff --git a/scheme/last-revision b/scheme/last-revision index 68abbd9..4d851a7 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1440 +1441 diff --git a/scheme/pass-specify-rep-primops.ss b/scheme/pass-specify-rep-primops.ss index 98a8d35..8c05c6b 100644 --- a/scheme/pass-specify-rep-primops.ss +++ b/scheme/pass-specify-rep-primops.ss @@ -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) diff --git a/scheme/test64.ss b/scheme/test64.ss index 2a86339..48f315a 100755 --- a/scheme/test64.ss +++ b/scheme/test64.ss @@ -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-2.1-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 diff --git a/src/ikarus-print.c b/src/ikarus-print.c index cd02d3b..8299527 100644 --- a/src/ikarus-print.c +++ b/src/ikarus-print.c @@ -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