all existing tests pass under 64-bit

This commit is contained in:
Abdulaziz Ghuloum 2008-07-19 14:41:06 -07:00
parent 81a1a640df
commit 4f48c55bfc
12 changed files with 173 additions and 105 deletions

View File

@ -608,7 +608,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 bset/c bset/h mset32) [(mset bset bset/c mset32)
(S* rands (S* rands
(lambda (s*) (lambda (s*)
(make-asm-instr op (make-asm-instr op
@ -1508,7 +1508,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 mset32 bset bset/c bset/h [(mset mset32 bset bset/c
fl:load fl:store fl:add! fl:sub! fl:mul! fl:div! fl:from-int fl:load fl:store fl:add! fl:sub! fl:mul! fl:div! fl:from-int
fl:shuffle fl:load-single fl:store-single) fl:shuffle fl:load-single fl:store-single)
(R* (list s d) vs rs fs ns)] (R* (list s d) vs rs fs ns)]
@ -1711,7 +1711,7 @@
(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 mset32 bset/c bset/h [(logand logor logxor int+ int- int* mset bset mset32 bset/c
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!
@ -1946,7 +1946,7 @@
(set-union (set-union (R v) (R d)) s))] (set-union (set-union (R v) (R d)) s))]
[(bset/c) [(bset/c)
(set-union (set-union (R v) (R d)) s)] (set-union (set-union (R v) (R d)) s)]
[(bset/h bset) [(bset)
(when (var? v) (when (var? v)
(for-each (lambda (r) (add-edge! g v r)) (for-each (lambda (r) (add-edge! g v r))
non-8bit-registers)) non-8bit-registers))
@ -2316,7 +2316,7 @@
(eq? b ecx)) (eq? b ecx))
(error who "invalid shift" b)) (error who "invalid shift" b))
x] x]
[(mset mset32 bset bset/c bset/h) [(mset mset32 bset bset/c )
(cond (cond
[(not (small-operand? b)) [(not (small-operand? b))
(let ([u (mku)]) (let ([u (mku)])
@ -2646,7 +2646,6 @@
ac ac
(cons `(movb ,(R/l s) ,(R/l d)) ac))] (cons `(movb ,(R/l s) ,(R/l d)) ac))]
[(bset/c) (cons `(movb ,(BYTE s) ,(R d)) ac)] [(bset/c) (cons `(movb ,(BYTE s) ,(R d)) ac)]
[(bset/h) (cons `(movb ,(reg/h s) ,(R d)) ac)]
[(bset) (cons `(movb ,(reg/l s) ,(R d)) ac)] [(bset) (cons `(movb ,(reg/l s) ,(R d)) ac)]
[(sll) (cons `(sall ,(R/cl s) ,(R d)) ac)] [(sll) (cons `(sall ,(R/cl s) ,(R d)) ac)]
[(sra) (cons `(sarl ,(R/cl s) ,(R d)) ac)] [(sra) (cons `(sarl ,(R/cl s) ,(R d)) ac)]

View File

@ -28,7 +28,7 @@
(define-record-type enum (define-record-type enum
(fields g univ values) (fields g univ values)
(opaque #t) (sealed #t) (opaque #f) (sealed #t)
(nongenerative)) (nongenerative))
(define (remove-dups ls) (define (remove-dups ls)
@ -64,18 +64,22 @@
[else #f])))) [else #f]))))
(define (enum-set-constructor x) (define (enum-set-constructor x)
(unless (enum? x) (unless (enum? x)
(die 'enum-set-constructor "not an enumeration" x)) (die 'enum-set-constructor "not an enumeration" x))
(lambda (ls) (lambda (ls)
(unless (and (list? ls) (for-all symbol? ls)) (unless (and (list? ls) (for-all symbol? ls))
(die 'enum-set-constructor "not a list of symbols" ls)) (die 'enum-set-constructor "not a list of symbols" ls))
(for-each (for-each
(lambda (s) (lambda (s)
(unless (memq s (enum-univ x)) (unless (memq s (enum-univ x))
(die 'enum-set-constructor "not in the universe" s x))) (die 'enum-set-constructor "not in the universe" s x)))
ls) ls)
(make-enum (enum-g x) (enum-univ x) (let ([idx (enum-set-indexer x)])
(remove-dups ls)))) (make-enum (enum-g x) (enum-univ x)
(map car
(list-sort (lambda (a b) (< (cdr a) (cdr b)))
(map (lambda (x) (cons x (idx x)))
ls)))))))
(define (enum-set->list x) (define (enum-set->list x)
(unless (enum? x) (unless (enum? x)

View File

@ -90,44 +90,74 @@
(char->integer x) (char->integer x)
(die who "unexpected eof inside a fasl object"))) (die who "unexpected eof inside a fasl object")))
(define (read-fixnum p) (define (read-u32 p)
(let* ([c0 (read-u8 p)] (let* ([c0 (read-u8 p)]
[c1 (read-u8 p)] [c1 (read-u8 p)]
[c2 (read-u8 p)] [c2 (read-u8 p)]
[c3 (read-u8 p)]) [c3 (read-u8 p)])
(cond (bitwise-ior c0 (sll c1 8) (sll c2 16) (sll c3 24))))
[(fx<= c3 127)
(fxlogor (fxlogor (fxsra c0 2) (fxsll c1 6)) (define (read-fixnum p)
(fxlogor (fxsll c2 14) (fxsll c3 22)))] (case (fixnum-width)
[else [(30)
(let ([c0 (fxlogand #xFF (fxlognot c0))] (let* ([c0 (read-u8 p)]
[c1 (fxlogand #xFF (fxlognot c1))] [c1 (read-u8 p)]
[c2 (fxlogand #xFF (fxlognot c2))] [c2 (read-u8 p)]
[c3 (fxlogand #xFF (fxlognot c3))]) [c3 (read-u8 p)])
(fx- -1 (cond
(fxlogor (fxlogor (fxsra c0 2) [(fx<= c3 127)
(fxsll c1 6)) (fxlogor (fxlogor (fxsra c0 2) (fxsll c1 6))
(fxlogor (fxsll c2 14) (fxlogor (fxsll c2 14) (fxsll c3 22)))]
(fxsll c3 22)))))]))) [else
(let ([c0 (fxlogand #xFF (fxlognot c0))]
[c1 (fxlogand #xFF (fxlognot c1))]
[c2 (fxlogand #xFF (fxlognot c2))]
[c3 (fxlogand #xFF (fxlognot c3))])
(fx- -1
(fxlogor (fxlogor (fxsra c0 2)
(fxsll c1 6))
(fxlogor (fxsll c2 14)
(fxsll c3 22)))))]))]
[else
(let* ([u0 (read-u32 p)]
[u1 (read-u32 p)])
(if (<= u1 #x7FFFFFF)
(sra (bitwise-ior u0 (sll u1 32)) 3)
(let ([u0 (fxlogand #xFFFFFFFF (fxlognot u0))]
[u1 (fxlogand #xFFFFFFFF (fxlognot u1))])
(fx- -1
(fxlogor (fxsra u0 3) (fxsll u1 29))))))]))
(define (read-int p) (define (read-int p)
(let* ([c0 (char->int (read-u8-as-char p))] (case (fixnum-width)
[c1 (char->int (read-u8-as-char p))] [(30)
[c2 (char->int (read-u8-as-char p))] (let* ([c0 (char->int (read-u8-as-char p))]
[c3 (char->int (read-u8-as-char p))]) [c1 (char->int (read-u8-as-char p))]
(cond [c2 (char->int (read-u8-as-char p))]
[(fx<= c3 127) [c3 (char->int (read-u8-as-char p))])
(fxlogor (fxlogor c0 (fxsll c1 8)) (cond
(fxlogor (fxsll c2 16) (fxsll c3 24)))] [(fx<= c3 127)
[else (fxlogor (fxlogor c0 (fxsll c1 8))
(let ([c0 (fxlogand #xFF (fxlognot c0))] (fxlogor (fxsll c2 16) (fxsll c3 24)))]
[c1 (fxlogand #xFF (fxlognot c1))] [else
[c2 (fxlogand #xFF (fxlognot c2))] (let ([c0 (fxlogand #xFF (fxlognot c0))]
[c3 (fxlogand #xFF (fxlognot c3))]) [c1 (fxlogand #xFF (fxlognot c1))]
(fx- -1 [c2 (fxlogand #xFF (fxlognot c2))]
(fxlogor (fxlogor c0 [c3 (fxlogand #xFF (fxlognot c3))])
(fxsll c1 8)) (fx- -1
(fxlogor (fxsll c2 16) (fxlogor (fxlogor c0
(fxsll c3 24)))))]))) (fxsll c1 8))
(fxlogor (fxsll c2 16)
(fxsll c3 24)))))]))]
[else
(let* ([u0 (read-u32 p)]
[u1 (read-u32 p)])
(if (<= u1 #x7FFFFFF)
(bitwise-ior u0 (sll u1 32))
(let ([u0 (fxlogand #xFFFFFFFF (fxlognot u0))]
[u1 (fxlogand #xFFFFFFFF (fxlognot u1))])
(- -1 (bitwise-ior u0 (sll u1 32))))))]))
(define (do-read p) (define (do-read p)
(define marks (make-vector 1 #f)) (define marks (make-vector 1 #f))
(define (max x y) (define (max x y)
@ -380,7 +410,9 @@
(assert-eq? (read-u8-as-char p) #\I) (assert-eq? (read-u8-as-char p) #\I)
(assert-eq? (read-u8-as-char p) #\K) (assert-eq? (read-u8-as-char p) #\K)
(assert-eq? (read-u8-as-char p) #\0) (assert-eq? (read-u8-as-char p) #\0)
(assert-eq? (read-u8-as-char p) #\1) (case (fixnum-width)
[(30) (assert-eq? (read-u8-as-char p) #\1)]
[else (assert-eq? (read-u8-as-char p) #\2)])
(let ([v (do-read p)]) (let ([v (do-read p)])
(unless (port-eof? p) (unless (port-eof? p)
(printf "port did not reach eof\n")) (printf "port did not reach eof\n"))

View File

@ -532,8 +532,8 @@
;(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))))
(define (CCCR* c0 c1 c2 r rm ac) (define (CCCR* c0 c1 c2 r rm ac)
;(CODE c0 (CODE c1 (CODE c2 (RM r rm ac))))) ;(CODE c0 (CODE c1 (CODE c2 (RM r rm ac)))))
(REX+RM r rm (CODE c0 (CODE c1 (CODE c2 (RM r rm ac)))))) (REX+RM r rm (CODE c0 (CODE c1 (CODE c2 (RM r rm ac))))))

View File

@ -2574,23 +2574,14 @@
(define exact-integer-sqrt (define exact-integer-sqrt
(lambda (x) (lambda (x)
(define who 'exact-integer-sqrt) (define who 'exact-integer-sqrt)
(define (fxsqrt x i k)
(let ([j ($fxsra ($fx+ i k) 1)])
(let ([j^2 ($fx* j j)])
(if ($fx> j^2 x)
(fxsqrt x i j)
(if ($fx= i j)
(values j ($fx- x j^2))
(fxsqrt x j k))))))
(cond (cond
[(fixnum? x) [(fixnum? x)
(cond (cond
[($fx< x 0) (die who "invalid argument" x)]
[($fx= x 0) (values 0 0)] [($fx= x 0) (values 0 0)]
[($fx< x 4) (values 1 ($fx- x 1))] [($fx< x 0) (die who "invalid argument" x)]
[($fx< x 9) (values 2 ($fx- x 4))] [else
[($fx< x 46340) (fxsqrt x 3 ($fxsra x 1))] (let ([s (foreign-call "ikrt_exact_fixnum_sqrt" x)])
[else (fxsqrt x 215 23171)])] (values s ($fx- x ($fx* s s))))])]
[(bignum? x) [(bignum? x)
(cond (cond
[($bignum-positive? x) [($bignum-positive? x)

View File

@ -1 +1 @@
1542 1543

View File

@ -41,11 +41,9 @@
(define (dirty-vector-set address) (define (dirty-vector-set address)
(define shift-bits 2) (define shift-bits 2)
(prm 'mset (prm 'mset32
(prm 'int+ (prm 'mref pcr (K pcb-dirty-vector))
(prm 'mref pcr (K pcb-dirty-vector)) (prm 'sll (prm 'srl address (K pageshift)) (K shift-bits))
(prm 'sll (prm 'srl address (K pageshift)) (K shift-bits)))
(K 0)
(K dirty-word))) (K dirty-word)))
(define (smart-dirty-vector-set addr what) (define (smart-dirty-vector-set addr what)
@ -1062,9 +1060,10 @@
[(constant i) [(constant i)
(unless (and (fixnum? i) (fx<= 0 i) (fx<= i 7)) (unless (and (fixnum? i) (fx<= 0 i) (fx<= i 7))
(interrupt)) (interrupt))
(prm 'bset/h (T x) (prm 'bset
(T x)
(K (+ (- 7 i) (- disp-flonum-data vector-tag))) (K (+ (- 7 i) (- disp-flonum-data vector-tag)))
(prm 'sll (T v) (K (- 8 fx-shift))))] (prm 'sra (T v) (K fx-shift)))]
[(known) (error 'translate "$flonum-set!")] [(known) (error 'translate "$flonum-set!")]
[else (interrupt)])]) [else (interrupt)])])
@ -1967,19 +1966,30 @@
(define-primop $bytevector-ieee-double-nonnative-ref unsafe (define-primop $bytevector-ieee-double-nonnative-ref unsafe
[(V bv i) [(V bv i)
(let ([bvoff (- disp-bytevector-data bytevector-tag)] (case wordsize
[floff (- disp-flonum-data vector-tag)]) [(4)
(with-tmp ([x (prm 'alloc (K (align flonum-size)) (K vector-tag))]) (let ([bvoff (- disp-bytevector-data bytevector-tag)]
(prm 'mset x (K (- vector-tag)) (K flonum-tag)) [floff (- disp-flonum-data vector-tag)])
(with-tmp ([t (prm 'int+ (T bv) (with-tmp ([x (prm 'alloc (K (align flonum-size)) (K vector-tag))])
(prm 'sra (T i) (K fx-shift)))]) (prm 'mset x (K (- vector-tag)) (K flonum-tag))
(with-tmp ([x0 (prm 'mref t (K bvoff))]) (with-tmp ([t (prm 'int+ (T bv)
(prm 'bswap! x0 x0) (prm 'sra (T i) (K fx-shift)))])
(prm 'mset x (K (+ floff wordsize)) x0)) (with-tmp ([x0 (prm 'mref t (K bvoff))])
(with-tmp ([x0 (prm 'mref t (K (+ bvoff wordsize)))]) (prm 'bswap! x0 x0)
(prm 'bswap! x0 x0) (prm 'mset x (K (+ floff wordsize)) x0))
(prm 'mset x (K floff) x0))) (with-tmp ([x0 (prm 'mref t (K (+ bvoff wordsize)))])
x))]) (prm 'bswap! x0 x0)
(prm 'mset x (K floff) x0)))
x))]
[else
(let ([bvoff (- disp-bytevector-data bytevector-tag)]
[floff (- disp-flonum-data vector-tag)])
(with-tmp ([x (prm 'alloc (K (align flonum-size)) (K vector-tag))])
(prm 'mset x (K (- vector-tag)) (K flonum-tag))
(with-tmp ([x0 (prm 'mref (T bv) (K bvoff))])
(prm 'bswap! x0 x0)
(prm 'mset x (K floff) x0))
x))])])
(define-primop $bytevector-ieee-double-native-set! unsafe (define-primop $bytevector-ieee-double-native-set! unsafe
@ -2021,7 +2031,7 @@
(with-tmp ([x0 (prm 'mref t (K bvoff))]) (with-tmp ([x0 (prm 'mref t (K bvoff))])
(prm 'bswap! x0 x0) (prm 'bswap! x0 x0)
(prm 'mset x (K floff) x0))) (prm 'mset x (K floff) x0)))
(prm 'fl:load-single x (K floff)) (prm 'fl:load-single x (K (+ floff (- wordsize 4))))
(prm 'fl:single->double) (prm 'fl:single->double)
(prm 'fl:store x (K floff)) (prm 'fl:store x (K floff))
x))]) x))])
@ -2041,16 +2051,26 @@
(define-primop $bytevector-ieee-double-nonnative-set! unsafe (define-primop $bytevector-ieee-double-nonnative-set! unsafe
[(E bv i x) [(E bv i x)
(let ([bvoff (- disp-bytevector-data bytevector-tag)] (case wordsize
[floff (- disp-flonum-data vector-tag)]) [(4)
(with-tmp ([t (prm 'int+ (T bv) (let ([bvoff (- disp-bytevector-data bytevector-tag)]
(prm 'sra (T i) (K fx-shift)))]) [floff (- disp-flonum-data vector-tag)])
(with-tmp ([x0 (prm 'mref (T x) (K floff))]) (with-tmp ([t (prm 'int+ (T bv)
(prm 'bswap! x0 x0) (prm 'sra (T i) (K fx-shift)))])
(prm 'mset t (K (+ bvoff wordsize)) x0)) (with-tmp ([x0 (prm 'mref (T x) (K floff))])
(with-tmp ([x0 (prm 'mref (T x) (K (+ floff wordsize)))]) (prm 'bswap! x0 x0)
(prm 'bswap! x0 x0) (prm 'mset t (K (+ bvoff wordsize)) x0))
(prm 'mset t (K bvoff) x0))))]) (with-tmp ([x0 (prm 'mref (T x) (K (+ floff wordsize)))])
(prm 'bswap! x0 x0)
(prm 'mset t (K bvoff) x0))))]
[else
(let ([bvoff (- disp-bytevector-data bytevector-tag)]
[floff (- disp-flonum-data vector-tag)])
(with-tmp ([t (prm 'int+ (T bv)
(prm 'sra (T i) (K fx-shift)))])
(with-tmp ([x0 (prm 'mref (T x) (K floff))])
(prm 'bswap! x0 x0)
(prm 'mset t (K bvoff) x0))))])])
(define-primop $bytevector-ieee-single-nonnative-set! unsafe (define-primop $bytevector-ieee-single-nonnative-set! unsafe
[(E bv i x) [(E bv i x)
@ -2062,9 +2082,15 @@
(with-tmp ([t (prm 'int+ (T bv) (with-tmp ([t (prm 'int+ (T bv)
(prm 'sra (T i) (K fx-shift)))]) (prm 'sra (T i) (K fx-shift)))])
(prm 'fl:store-single t (K bvoff)) (prm 'fl:store-single t (K bvoff))
(with-tmp ([x0 (prm 'mref t (K bvoff))]) (case wordsize
(prm 'bswap! x0 x0) [(4)
(prm 'mset t (K bvoff) x0)))))]) (with-tmp ([x0 (prm 'mref t (K bvoff))])
(prm 'bswap! x0 x0)
(prm 'mset t (K bvoff) x0))]
[else
(with-tmp ([x0 (prm 'mref32 t (K bvoff))])
(prm 'bswap! x0 x0)
(prm 'mset32 t (K bvoff) (prm 'sra x0 (K 32))))]))))])
/section) /section)
(section ;;; strings (section ;;; strings

View File

@ -58,11 +58,11 @@
(test-case-folding) (test-case-folding)
(test-reader) (test-reader)
(test-char-syntax) (test-char-syntax)
;(test-bytevectors) (test-bytevectors)
(test-strings) (test-strings)
;(test-exact-integer-sqrt) (test-exact-integer-sqrt)
(test-bignum-to-flonum) (test-bignum-to-flonum)
;(test-bignum->flonum) (test-bignum->flonum)
(test-string-to-number) (test-string-to-number)
(test-div-and-mod) (test-div-and-mod)
(test-bignums) (test-bignums)
@ -78,9 +78,9 @@
(test-fxdiv0-and-mod0) (test-fxdiv0-and-mod0)
(test-fxlength) (test-fxlength)
(test-bitwise-bit-count) (test-bitwise-bit-count)
;(test-io) (test-io)
(test-sorting) (test-sorting)
;(test-fasl) (test-fasl)
(test-numerics) (test-numerics)
(printf "Happy Happy Joy Joy\n") (printf "Happy Happy Joy Joy\n")

View File

@ -15,12 +15,14 @@
(define (test-fasl) (define (test-fasl)
(test 12) (test 12)
(test -12) (test -12)
(test (greatest-fixnum))
(test (least-fixnum))
(test 0) (test 0)
(test #t) (test #t)
(test #f) (test #f)
(test '()) (test '())
(test 'hello)
(test "Hello") (test "Hello")
(test 'hello)
(test '(Hello There)) (test '(Hello There))
(test 3498798327498723894789237489324) (test 3498798327498723894789237489324)
(test -3498798327498723894789237489324) (test -3498798327498723894789237489324)

View File

@ -9,7 +9,7 @@
(lambda () (lambda ()
(let ([p p0] [e e0]) (let ([p p0] [e e0])
(unless (p e) (unless (p e)
(error 'test-all "~s failed, got ~s" (error 'test-all "failed"
'(p0 e0) e))) '(p0 e0) e)))
... ...
(printf "[~s: ~s] Happy Happy Joy Joy\n" (printf "[~s: ~s] Happy Happy Joy Joy\n"

View File

@ -1334,6 +1334,11 @@ relocate_new_code(ikptr x, gc_t* gc){
ikptr displaced_object = obj + obj_off; ikptr displaced_object = obj + obj_off;
long int next_word = code + code_off + 4; long int next_word = code + code_off + 4;
ikptr relative_distance = displaced_object - (long int)next_word; ikptr relative_distance = displaced_object - (long int)next_word;
if(relative_distance != (int)relative_distance){
fprintf(stderr, "relocation error with relative=0x%016lx\n",
relative_distance);
exit(-1);
}
*((int*)(code+code_off)) = relative_distance; *((int*)(code+code_off)) = relative_distance;
p += (3*wordsize); p += (3*wordsize);
} }

View File

@ -35,7 +35,7 @@
// #define most_positive_fixnum 0x1FFFFFFF // #define most_positive_fixnum 0x1FFFFFFF
// #define most_negative_fixnum 0x20000000 // #define most_negative_fixnum 0x20000000
#define max_digits_per_limb 10 #define max_digits_per_limb ((wordsize==4)?10:20)
#ifdef NDEBUG #ifdef NDEBUG
#define verify_bignum(x,caller) (x) #define verify_bignum(x,caller) (x)
@ -2075,6 +2075,15 @@ ikrt_bignum_to_flonum(ikptr bn, ikptr more_bits, ikptr fl){
return fl; return fl;
} }
ikptr
ikrt_exact_fixnum_sqrt(ikptr fx /*, ikpcb* pcb*/){
mp_limb_t x = unfix(fx);
mp_limb_t s;
mp_limb_t r;
mpn_sqrtrem(&s, &r, &x, 1);
return fix(s);
}
ikptr ikptr
ikrt_exact_bignum_sqrt(ikptr bn, ikpcb* pcb){ ikrt_exact_bignum_sqrt(ikptr bn, ikpcb* pcb){
ikptr fst = ref(bn, -vector_tag); ikptr fst = ref(bn, -vector_tag);