more progress on the AMD64 front, fixing more numeric and more cogen
64-bit bugs.
This commit is contained in:
Abdulaziz Ghuloum
parent
01c4afa320
commit
81a1a640df
|
|
@ -2348,13 +2348,11 @@
|
|||
[else x]))])]
|
||||
[(fl:load fl:store fl:add! fl:sub! fl:mul! fl:div!
|
||||
fl:load-single fl:store-single)
|
||||
(cond
|
||||
[(mem? a)
|
||||
(let ([u (mku)])
|
||||
(make-seq
|
||||
(E (make-asm-instr 'move u a))
|
||||
(E (make-asm-instr op u b))))]
|
||||
[else x])]
|
||||
(check-disp-arg a
|
||||
(lambda (a)
|
||||
(check-disp-arg b
|
||||
(lambda (b)
|
||||
(make-asm-instr op a b)))))]
|
||||
[(fl:from-int fl:shuffle) x]
|
||||
[else (error who "invalid effect op" op)])]
|
||||
[(primcall op rands)
|
||||
|
|
|
|||
|
|
@ -27,11 +27,14 @@
|
|||
(printf "Ikarus Scheme version ~a\n"
|
||||
(if (zero? (string-length ikarus-revision))
|
||||
ikarus-version
|
||||
(format "~a+ (revision ~a, build ~a)"
|
||||
(format "~a+ (revision ~a, build ~a~a)"
|
||||
ikarus-version
|
||||
(+ 1 (string->number ikarus-revision))
|
||||
(let-syntax ([ds (lambda (x) (date-string))])
|
||||
ds))))
|
||||
ds)
|
||||
(if (= (fixnum-width) 30)
|
||||
""
|
||||
", 64-bit"))))
|
||||
(display "Copyright (c) 2006-2008 Abdulaziz Ghuloum\n\n"))
|
||||
|
||||
(define (init-library-path)
|
||||
|
|
|
|||
|
|
@ -3470,13 +3470,25 @@
|
|||
(define (pos-fxbitcount n)
|
||||
;;; nifty parrallel count from:
|
||||
;;; http://infolab.stanford.edu/~manku/bitcount/bitcount.html
|
||||
(let ([m0 #x15555555]
|
||||
[m1 #x13333333]
|
||||
[m2 #x0f0f0f0f])
|
||||
(let* ([n ($fx+ ($fxlogand n m0) ($fxlogand ($fxsra n 1) m0))]
|
||||
[n ($fx+ ($fxlogand n m1) ($fxlogand ($fxsra n 2) m1))]
|
||||
[n ($fx+ ($fxlogand n m2) ($fxlogand ($fxsra n 4) m2))])
|
||||
($fxmodulo n 255))))
|
||||
(case (fixnum-width)
|
||||
[(30)
|
||||
(let ([m0 #x15555555]
|
||||
[m1 #x13333333]
|
||||
[m2 #x0f0f0f0f])
|
||||
(let* ([n ($fx+ ($fxlogand n m0) ($fxlogand ($fxsra n 1) m0))]
|
||||
[n ($fx+ ($fxlogand n m1) ($fxlogand ($fxsra n 2) m1))]
|
||||
[n ($fx+ ($fxlogand n m2) ($fxlogand ($fxsra n 4) m2))])
|
||||
($fxmodulo n 255)))]
|
||||
[else
|
||||
(let ([m0 #x0555555555555555]
|
||||
[m1 #x0333333333333333]
|
||||
[m2 #x0f0f0f0f0f0f0f0f]
|
||||
[m3 #x00ff00ff00ff00ff])
|
||||
(let* ([n ($fx+ ($fxlogand n m0) ($fxlogand ($fxsra n 1) m0))]
|
||||
[n ($fx+ ($fxlogand n m1) ($fxlogand ($fxsra n 2) m1))]
|
||||
[n ($fx+ ($fxlogand n m2) ($fxlogand ($fxsra n 4) m2))]
|
||||
[n ($fx+ ($fxlogand n m3) ($fxlogand ($fxsra n 8) m3))])
|
||||
($fxmodulo n 255)))]))
|
||||
(define ($fxbitcount n)
|
||||
(if ($fx< n 0)
|
||||
(fxlognot (pos-fxbitcount (fxlognot n)))
|
||||
|
|
@ -3510,15 +3522,24 @@
|
|||
[else (die 'bitwise-bit-count "not an exact integer" n)])))
|
||||
|
||||
(define (fxlength x)
|
||||
(define (fxlength32 x)
|
||||
(let ([fl ($fixnum->flonum x)])
|
||||
(let ([sbe ($fxlogor
|
||||
($fxsll ($flonum-u8-ref fl 0) 4)
|
||||
($fxsra ($flonum-u8-ref fl 1) 4))])
|
||||
(cond
|
||||
[($fx= sbe 0) 0]
|
||||
[else ($fx- sbe 1022)]))))
|
||||
(define (fxlength64 x)
|
||||
(if ($fx> x #x7FFFFFFF)
|
||||
($fx+ 31 (fxlength32 ($fxsra x 31)))
|
||||
(fxlength32 x)))
|
||||
(if (fixnum? x)
|
||||
(let ([fl ($fixnum->flonum
|
||||
(if ($fx< x 0) ($fxlognot x) x))])
|
||||
(let ([sbe ($fxlogor
|
||||
($fxsll ($flonum-u8-ref fl 0) 4)
|
||||
($fxsra ($flonum-u8-ref fl 1) 4))])
|
||||
(cond
|
||||
[($fx= sbe 0) 0]
|
||||
[else ($fx- sbe 1022)])))
|
||||
(case (fixnum-width)
|
||||
[(30)
|
||||
(fxlength32 (if ($fx< x 0) ($fxlognot x) x))]
|
||||
[else
|
||||
(fxlength64 (if ($fx< x 0) ($fxlognot x) x))])
|
||||
(die 'fxlength "not a fixnum" x)))
|
||||
|
||||
(define (fxbit-set? x i)
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
1541
|
||||
1542
|
||||
|
|
|
|||
|
|
@ -1070,13 +1070,19 @@
|
|||
|
||||
(define-primop $fixnum->flonum unsafe
|
||||
[(V fx)
|
||||
(with-tmp ([x (prm 'alloc (K (align flonum-size)) (K vector-tag))])
|
||||
(prm 'mset x (K (- vector-tag)) (K flonum-tag))
|
||||
(prm 'fl:from-int
|
||||
(K 0) ; dummy
|
||||
(prm 'sra (T fx) (K fx-shift)))
|
||||
(prm 'fl:store x (K (- disp-flonum-data vector-tag)))
|
||||
x)])
|
||||
(case wordsize
|
||||
[(4)
|
||||
(with-tmp ([x (prm 'alloc (K (align flonum-size)) (K vector-tag))])
|
||||
(prm 'mset x (K (- vector-tag)) (K flonum-tag))
|
||||
(prm 'fl:from-int
|
||||
(K 0) ; dummy
|
||||
(prm 'sra (T fx) (K fx-shift)))
|
||||
(prm 'fl:store x (K (- disp-flonum-data vector-tag)))
|
||||
x)]
|
||||
[else
|
||||
(with-tmp ([f (cogen-value-$make-flonum)])
|
||||
(make-forcall "ikrt_fixnum_to_flonum" (list (T fx) f)))])])
|
||||
|
||||
|
||||
(define (check-flonums ls code)
|
||||
(cond
|
||||
|
|
|
|||
|
|
@ -53,33 +53,34 @@
|
|||
(f 0 536870911000 536870911)
|
||||
(printf "[exact-integer-sqrt] Happy Happy Joy Joy\n"))
|
||||
|
||||
;(test-bitwise-op)
|
||||
;(test-parse-flonums)
|
||||
;(test-case-folding)
|
||||
;(test-reader)
|
||||
;(test-char-syntax)
|
||||
(test-bitwise-op)
|
||||
(test-parse-flonums)
|
||||
(test-case-folding)
|
||||
(test-reader)
|
||||
(test-char-syntax)
|
||||
;(test-bytevectors)
|
||||
;(test-strings)
|
||||
(test-strings)
|
||||
;(test-exact-integer-sqrt)
|
||||
;(test-bignum-to-flonum)
|
||||
;(test-bignum->flonum)
|
||||
;(test-string-to-number)
|
||||
;(test-div-and-mod)
|
||||
;(test-bignums)
|
||||
;(test-bignum-length)
|
||||
;(test-fxcarry)
|
||||
;(test-lists)
|
||||
;(test-hashtables)
|
||||
;(test-input-ports)
|
||||
;(test-bignum-conversion)
|
||||
;(test-fldiv-and-mod)
|
||||
;(test-fldiv0-and-mod0)
|
||||
;(test-fxdiv-and-mod)
|
||||
;(test-fxdiv0-and-mod0)
|
||||
;(test-fxlength)
|
||||
(test-bitwise-bit-count)
|
||||
(test-bignum-to-flonum)
|
||||
;(test-bignum->flonum)
|
||||
(test-string-to-number)
|
||||
(test-div-and-mod)
|
||||
(test-bignums)
|
||||
(test-bignum-length)
|
||||
(test-fxcarry)
|
||||
(test-lists)
|
||||
(test-hashtables)
|
||||
(test-input-ports)
|
||||
(test-bignum-conversion)
|
||||
(test-fldiv-and-mod)
|
||||
(test-fldiv0-and-mod0)
|
||||
(test-fxdiv-and-mod)
|
||||
(test-fxdiv0-and-mod0)
|
||||
(test-fxlength)
|
||||
(test-bitwise-bit-count)
|
||||
;(test-io)
|
||||
;(test-sorting)
|
||||
(test-sorting)
|
||||
;(test-fasl)
|
||||
;(test-numerics)
|
||||
(test-numerics)
|
||||
|
||||
(printf "Happy Happy Joy Joy\n")
|
||||
|
|
|
|||
|
|
@ -16,11 +16,11 @@
|
|||
|
||||
(define (testnum x)
|
||||
(define precision 53)
|
||||
(assert (bignum? x))
|
||||
;(assert (bignum? x))
|
||||
(let ([fl (inexact x)])
|
||||
(let ([n (if (> x 0) x (- x))])
|
||||
(let ([bits (bitwise-length n)])
|
||||
(printf "bits = ~s\n" bits)
|
||||
(printf "bits(~s) = ~s\n" n bits)
|
||||
(cond
|
||||
[(<= bits precision)
|
||||
(unless (= x (exact fl))
|
||||
|
|
|
|||
|
|
@ -200,10 +200,6 @@
|
|||
(test #x-1000000000000001))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(define (test-bitwise-bit-count)
|
||||
(define (test n)
|
||||
(define (pos-count-bits n)
|
||||
|
|
@ -219,13 +215,15 @@
|
|||
[bc1 (count-bits n)])
|
||||
(unless (= bc0 bc1)
|
||||
(error 'test-bitcount "failed/expected/got" n bc1 bc0))))
|
||||
(define (test-fx n)
|
||||
(define (test-fx count n inc)
|
||||
(when (fixnum? n)
|
||||
(when (zero? (fxlogand n #x7FFFFFF))
|
||||
(when (zero? (fxlogand count #xFFFF))
|
||||
(printf "bitwise-bit-count ~s\n" n))
|
||||
(test n)
|
||||
(test-fx (+ n 512))))
|
||||
(test-fx (least-fixnum))
|
||||
(test-fx (+ count 1) (+ n inc) inc)))
|
||||
(if (= (fixnum-width) 30)
|
||||
(test-fx 0 (least-fixnum) #xFF)
|
||||
(test-fx 0 (least-fixnum) #xFF00000000))
|
||||
(test 28472347823493290482390849023840928390482309480923840923840983)
|
||||
(test -847234234903290482390849023840928390482309480923840923840983))
|
||||
|
||||
|
|
|
|||
|
|
@ -98,12 +98,12 @@
|
|||
[c1 (fxlength x)])
|
||||
(unless (= c0 c1)
|
||||
(error 'test-fxlength "failed/expected/got" x c0 c1))))
|
||||
(define (fxtest x)
|
||||
(when (fixnum? x)
|
||||
(when (zero? (bitwise-and x #xFFFFFFF))
|
||||
(printf "fxlength ~s\n" x))
|
||||
(test x)
|
||||
(fxtest (+ x #x100))))
|
||||
(define (test-fx count n inc)
|
||||
(when (fixnum? n)
|
||||
(when (zero? (fxlogand count #xFFFF))
|
||||
(printf "bitwise-bit-count ~s\n" n))
|
||||
(test n)
|
||||
(test-fx (+ count 1) (+ n inc) inc)))
|
||||
(test 0)
|
||||
(test 1)
|
||||
(test 2)
|
||||
|
|
@ -111,6 +111,8 @@
|
|||
(test -1)
|
||||
(test -2)
|
||||
(test -3)
|
||||
(fxtest (least-fixnum)))
|
||||
(if (= (fixnum-width) 30)
|
||||
(test-fx 0 (least-fixnum) #xFF)
|
||||
(test-fx 0 (least-fixnum) #xFF00000000)) )
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -374,6 +374,7 @@ extern void verify_integrity(ikpcb* pcb, char*);
|
|||
|
||||
ikpcb*
|
||||
ik_collect(unsigned long int mem_req, ikpcb* pcb){
|
||||
// fprintf(stderr, "ik_collect ...\n");
|
||||
#ifndef NDEBUG
|
||||
verify_integrity(pcb, "entry");
|
||||
#endif
|
||||
|
|
@ -562,7 +563,7 @@ ik_collect(unsigned long int mem_req, ikpcb* pcb){
|
|||
}
|
||||
|
||||
|
||||
// fprintf(stderr, "ik_collect\n");
|
||||
//fprintf(stderr, "ik_collect done\n");
|
||||
return pcb;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -206,7 +206,7 @@ ikptr ik_unsafe_alloc(ikpcb* pcb, int size);
|
|||
ikptr ik_safe_alloc(ikpcb* pcb, int size);
|
||||
|
||||
#define IK_HEAP_EXT_SIZE (32 * 4096)
|
||||
#define IK_HEAPSIZE (1024 * ((wordsize==4)?1:16) * 4096) /* 4/8 MB */
|
||||
#define IK_HEAPSIZE (1024 * ((wordsize==4)?1:32) * 4096) /* 4/8 MB */
|
||||
|
||||
#define wordsize ((int)(sizeof(ikptr)))
|
||||
#define wordshift ((wordsize == 4)?2:3)
|
||||
|
|
|
|||
|
|
@ -238,9 +238,7 @@ ikrt_fx_log(ikptr x, ikpcb* pcb){
|
|||
|
||||
|
||||
ikptr
|
||||
ikrt_fixnum_to_flonum(ikptr x, ikpcb* pcb){
|
||||
ikptr r = ik_unsafe_alloc(pcb, flonum_size) + vector_tag;
|
||||
ref(r, -vector_tag) = (ikptr)flonum_tag;
|
||||
ikrt_fixnum_to_flonum(ikptr x, ikptr r, ikpcb* pcb){
|
||||
flonum_data(r) = unfix(x);
|
||||
return r;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1825,7 +1825,7 @@ ikrt_bnfx_modulo(ikptr x, ikptr y /*, ikpcb* pcb */){
|
|||
|
||||
|
||||
static int
|
||||
limb_length(unsigned int n){
|
||||
limb_length(unsigned long int n){
|
||||
int i=0;
|
||||
while(n != 0){
|
||||
n = n >> 1;
|
||||
|
|
@ -1844,7 +1844,7 @@ ikrt_bignum_length(ikptr x){
|
|||
int n0 = limb_length(last);
|
||||
if(((unsigned long int) fst) & bignum_sign_mask){
|
||||
/* negative */
|
||||
if (last == (mp_limb_t)(1<<(n0-1))){
|
||||
if (last == (mp_limb_t)(1L<<(n0-1))){
|
||||
/* single bit set in last limb */
|
||||
int i;
|
||||
for(i=0; i<(sn-1); i++){
|
||||
|
|
@ -1966,47 +1966,37 @@ ikrt_bignum_to_flonum64(ikptr bn, ikptr more_bits, ikptr fl){
|
|||
double pos_result;
|
||||
if(limb_count == 1){
|
||||
pos_result = sp[0];
|
||||
} else if (limb_count == 2){
|
||||
mp_limb_t lo = sp[0];
|
||||
mp_limb_t hi = sp[1];
|
||||
pos_result = hi;
|
||||
pos_result = pos_result * 4294967296.0;
|
||||
pos_result = pos_result + lo;
|
||||
} else {
|
||||
mp_limb_t hi = sp[limb_count-1];
|
||||
mp_limb_t mi = sp[limb_count-2];
|
||||
int bc = limb_size(hi);
|
||||
if(bc < 32){
|
||||
mp_limb_t lo = sp[limb_count-3];
|
||||
hi = (hi << (32-bc)) | (mi >> bc);
|
||||
mi = (mi << (32-bc)) | (lo >> bc);
|
||||
if(bc < 64){
|
||||
mp_limb_t mi = sp[limb_count-2];
|
||||
hi = (hi << (64-bc)) | (mi >> bc);
|
||||
}
|
||||
/* now hi has 32 full bits, and mi has 32 full bits */
|
||||
mp_limb_t mask = ((1<<(64-PRECISION)) - 1);
|
||||
if((mi & mask) == ((mask+1)>>1)){
|
||||
/* now hi has 64 full bits */
|
||||
mp_limb_t mask = ((1L<<(64-PRECISION)) - 1);
|
||||
if((hi & mask) == ((mask+1)>>1)){
|
||||
/* exactly at break point */
|
||||
if(((sp[limb_count-3] << (32-bc)) == 0) &&
|
||||
all_zeros(sp, sp+limb_count-4) &&
|
||||
if(((sp[limb_count-2] << (64-bc)) == 0) &&
|
||||
all_zeros(sp, sp+limb_count-3) &&
|
||||
(more_bits == 0)){
|
||||
if(mi & (1<<(64-PRECISION))){
|
||||
if(hi & (1L<<(64-PRECISION))){
|
||||
/* odd number, round to even */
|
||||
mi = mi | mask;
|
||||
hi = hi | mask;
|
||||
}
|
||||
} else {
|
||||
/* round up */
|
||||
mi = mi | mask;
|
||||
hi = hi | mask;
|
||||
}
|
||||
} else if ((mi & mask) > ((mask+1)>>1)){
|
||||
} else if ((hi & mask) > ((mask+1)>>1)){
|
||||
/* also round up */
|
||||
mi = mi | mask;
|
||||
hi = hi | mask;
|
||||
} else {
|
||||
/* keep it to round down */
|
||||
}
|
||||
pos_result = hi;
|
||||
pos_result = pos_result * 4294967296.0;
|
||||
pos_result = pos_result + mi;
|
||||
int bignum_bits = bc + (mp_bits_per_limb * (limb_count-1));
|
||||
int exponent = bignum_bits - (2 * mp_bits_per_limb);
|
||||
int exponent = bignum_bits - mp_bits_per_limb;
|
||||
while(exponent){
|
||||
pos_result *= 2.0;
|
||||
exponent -= 1;
|
||||
|
|
|
|||
Loading…
Reference in New Issue