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))]
[(primcall op rands)
(case op
[(mset bset bset/c bset/h mset32)
[(mset bset bset/c mset32)
(S* rands
(lambda (s*)
(make-asm-instr op
@ -1508,7 +1508,7 @@
[(cltd)
(mark-reg/vars-conf! edx vs)
(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:shuffle fl:load-single fl:store-single)
(R* (list s d) vs rs fs ns)]
@ -1711,7 +1711,7 @@
(make-primcall 'nop '())]
[else
(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!
cltd idiv int-/overflow int+/overflow int*/overflow
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))]
[(bset/c)
(set-union (set-union (R v) (R d)) s)]
[(bset/h bset)
[(bset)
(when (var? v)
(for-each (lambda (r) (add-edge! g v r))
non-8bit-registers))
@ -2316,7 +2316,7 @@
(eq? b ecx))
(error who "invalid shift" b))
x]
[(mset mset32 bset bset/c bset/h)
[(mset mset32 bset bset/c )
(cond
[(not (small-operand? b))
(let ([u (mku)])
@ -2646,7 +2646,6 @@
ac
(cons `(movb ,(R/l s) ,(R/l 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)]
[(sll) (cons `(sall ,(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
(fields g univ values)
(opaque #t) (sealed #t)
(opaque #f) (sealed #t)
(nongenerative))
(define (remove-dups ls)
@ -74,8 +74,12 @@
(unless (memq s (enum-univ x))
(die 'enum-set-constructor "not in the universe" s x)))
ls)
(make-enum (enum-g x) (enum-univ x)
(remove-dups ls))))
(let ([idx (enum-set-indexer x)])
(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)
(unless (enum? x)

View File

@ -90,44 +90,74 @@
(char->integer x)
(die who "unexpected eof inside a fasl object")))
(define (read-fixnum p)
(define (read-u32 p)
(let* ([c0 (read-u8 p)]
[c1 (read-u8 p)]
[c2 (read-u8 p)]
[c3 (read-u8 p)])
(cond
[(fx<= c3 127)
(fxlogor (fxlogor (fxsra c0 2) (fxsll c1 6))
(fxlogor (fxsll c2 14) (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)))))])))
(bitwise-ior c0 (sll c1 8) (sll c2 16) (sll c3 24))))
(define (read-fixnum p)
(case (fixnum-width)
[(30)
(let* ([c0 (read-u8 p)]
[c1 (read-u8 p)]
[c2 (read-u8 p)]
[c3 (read-u8 p)])
(cond
[(fx<= c3 127)
(fxlogor (fxlogor (fxsra c0 2) (fxsll c1 6))
(fxlogor (fxsll c2 14) (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)
(let* ([c0 (char->int (read-u8-as-char p))]
[c1 (char->int (read-u8-as-char p))]
[c2 (char->int (read-u8-as-char p))]
[c3 (char->int (read-u8-as-char p))])
(cond
[(fx<= c3 127)
(fxlogor (fxlogor c0 (fxsll c1 8))
(fxlogor (fxsll c2 16) (fxsll c3 24)))]
[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 c0
(fxsll c1 8))
(fxlogor (fxsll c2 16)
(fxsll c3 24)))))])))
(case (fixnum-width)
[(30)
(let* ([c0 (char->int (read-u8-as-char p))]
[c1 (char->int (read-u8-as-char p))]
[c2 (char->int (read-u8-as-char p))]
[c3 (char->int (read-u8-as-char p))])
(cond
[(fx<= c3 127)
(fxlogor (fxlogor c0 (fxsll c1 8))
(fxlogor (fxsll c2 16) (fxsll c3 24)))]
[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 c0
(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 marks (make-vector 1 #f))
(define (max x y)
@ -380,7 +410,9 @@
(assert-eq? (read-u8-as-char p) #\I)
(assert-eq? (read-u8-as-char p) #\K)
(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)])
(unless (port-eof? p)
(printf "port did not reach eof\n"))

View File

@ -532,8 +532,8 @@
;(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))))
;(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)
;(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
(lambda (x)
(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
[(fixnum? x)
(cond
[($fx< x 0) (die who "invalid argument" x)]
[($fx= x 0) (values 0 0)]
[($fx< x 4) (values 1 ($fx- x 1))]
[($fx< x 9) (values 2 ($fx- x 4))]
[($fx< x 46340) (fxsqrt x 3 ($fxsra x 1))]
[else (fxsqrt x 215 23171)])]
[($fx< x 0) (die who "invalid argument" x)]
[else
(let ([s (foreign-call "ikrt_exact_fixnum_sqrt" x)])
(values s ($fx- x ($fx* s s))))])]
[(bignum? x)
(cond
[($bignum-positive? x)

View File

@ -1 +1 @@
1542
1543

View File

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

View File

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

View File

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

View File

@ -9,7 +9,7 @@
(lambda ()
(let ([p p0] [e e0])
(unless (p e)
(error 'test-all "~s failed, got ~s"
(error 'test-all "failed"
'(p0 e0) e)))
...
(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;
long int next_word = code + code_off + 4;
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;
p += (3*wordsize);
}

View File

@ -35,7 +35,7 @@
// #define most_positive_fixnum 0x1FFFFFFF
// #define most_negative_fixnum 0x20000000
#define max_digits_per_limb 10
#define max_digits_per_limb ((wordsize==4)?10:20)
#ifdef NDEBUG
#define verify_bignum(x,caller) (x)
@ -2075,6 +2075,15 @@ ikrt_bignum_to_flonum(ikptr bn, ikptr more_bits, ikptr 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
ikrt_exact_bignum_sqrt(ikptr bn, ikpcb* pcb){
ikptr fst = ref(bn, -vector_tag);