all existing tests pass under 64-bit
This commit is contained in:
parent
81a1a640df
commit
4f48c55bfc
|
@ -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)]
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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"))
|
||||
|
|
|
@ -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))))))
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -1 +1 @@
|
|||
1542
|
||||
1543
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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")
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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);
|
||||
}
|
||||
|
|
|
@ -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);
|
||||
|
|
Loading…
Reference in New Issue