From 23e62275df5b9c883fd1d6316df3930b55ef8dab Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 28 Jul 2020 15:09:40 +0900 Subject: [PATCH] fixing scheme bytevector for 32bit arch --- Makefile | 1 + bignum.c | 50 ++++++++++++++++++++++++++--- include/chibi/bignum.h | 39 +++++++++++++++++++---- include/chibi/sexp.h | 22 ++++++++++--- lib/chibi/bytevector-test.sld | 4 ++- lib/chibi/bytevector.sld | 4 +-- lib/scheme/bytevector-test.sld | 58 +++++++++++++++------------------- sexp.c | 8 ++--- tests/build/build-opts.txt | 2 ++ 9 files changed, 133 insertions(+), 55 deletions(-) diff --git a/Makefile b/Makefile index 9e333871..be2412ba 100644 --- a/Makefile +++ b/Makefile @@ -247,6 +247,7 @@ test-division: chibi-scheme$(EXE) $(CHIBI) tests/division-tests.scm test-libs: chibi-scheme$(EXE) + @echo "\e[1mloading tests first, it may take a while to see output...\e[0m" $(CHIBI) tests/lib-tests.scm test-r5rs: chibi-scheme$(EXE) diff --git a/bignum.c b/bignum.c index 220baf23..266cd933 100644 --- a/bignum.c +++ b/bignum.c @@ -39,7 +39,7 @@ sexp sexp_make_integer_from_lsint (sexp ctx, sexp_lsint_t x) { sexp res; if (lsint_is_fixnum(x)) { res = sexp_make_fixnum(lsint_to_sint(x)); - } else { + } else if (sexp_lsint_fits_sint(x)) { res = sexp_make_bignum(ctx, 1); if (lsint_lt_0(x)) { sexp_bignum_sign(res) = -1; @@ -48,6 +48,17 @@ sexp sexp_make_integer_from_lsint (sexp ctx, sexp_lsint_t x) { sexp_bignum_sign(res) = 1; sexp_bignum_data(res)[0] = (sexp_uint_t)lsint_to_sint(x); } + } else { + res = sexp_make_bignum(ctx, 2); + if (lsint_lt_0(x)) { + sexp_bignum_sign(res) = -1; + sexp_bignum_data(res)[0] = (sexp_uint_t)-lsint_to_sint(x); + sexp_bignum_data(res)[1] = (sexp_uint_t)~lsint_to_sint_hi(x); + } else { + sexp_bignum_sign(res) = 1; + sexp_bignum_data(res)[0] = (sexp_uint_t)lsint_to_sint(x); + sexp_bignum_data(res)[1] = (sexp_uint_t)lsint_to_sint_hi(x); + } } return res; } @@ -56,22 +67,53 @@ sexp sexp_make_unsigned_integer_from_luint (sexp ctx, sexp_luint_t x) { sexp res; if (luint_is_fixnum(x)) { res = sexp_make_fixnum(luint_to_uint(x)); - } else { + } else if (sexp_luint_fits_uint(x)) { res = sexp_make_bignum(ctx, 1); sexp_bignum_sign(res) = 1; sexp_bignum_data(res)[0] = luint_to_uint(x); + } else { + res = sexp_make_bignum(ctx, 2); + sexp_bignum_sign(res) = 1; + sexp_bignum_data(res)[0] = luint_to_uint(x); + sexp_bignum_data(res)[1] = luint_to_uint_hi(x); } return res; } -#if !SEXP_USE_CUSTOM_LONG_LONGS +#if SEXP_USE_CUSTOM_LONG_LONGS +sexp sexp_make_integer(sexp ctx, long long x) { + return sexp_make_integer_from_lsint(ctx, lsint_from_sint(x)); +} +sexp sexp_make_unsigned_integer(sexp ctx, unsigned long long x) { + return sexp_make_unsigned_integer_from_luint(ctx, luint_from_uint(x)); +} +#else sexp sexp_make_integer (sexp ctx, sexp_lsint_t x) { return sexp_make_integer_from_lsint(ctx, x); } sexp sexp_make_unsigned_integer (sexp ctx, sexp_luint_t x) { return sexp_make_unsigned_integer_from_luint(ctx, x); } -#endif /* !SEXP_USE_CUSTOM_LONG_LONGS */ +#endif + +#if !SEXP_64_BIT +long long sexp_bignum_to_sint(sexp x) { + if (!sexp_bignump(x)) + return 0; + if (sexp_bignum_length(x) > 1) + return sexp_bignum_sign(x) * ( + (((long long)(sexp_bignum_data(x)[1]))<<(8*sizeof(sexp_bignum_data(x)[0]))) + sexp_bignum_data(x)[0]); + return sexp_bignum_sign(x) * sexp_bignum_data(x)[0]; +} + +unsigned long long sexp_bignum_to_uint(sexp x) { + if (!sexp_bignump(x)) + return 0; + if (sexp_bignum_length(x) > 1) + return (((unsigned long long)(sexp_bignum_data(x)[1]))<<(8*sizeof(sexp_bignum_data(x)[0]))) + sexp_bignum_data(x)[0]; + return sexp_bignum_data(x)[0]; +} +#endif #define double_trunc_10s_digit(f) (trunc((f)/10.0)*10.0) #define double_10s_digit(f) ((f)-double_trunc_10s_digit(f)) diff --git a/include/chibi/bignum.h b/include/chibi/bignum.h index fc6581ce..22a2bd9d 100644 --- a/include/chibi/bignum.h +++ b/include/chibi/bignum.h @@ -31,10 +31,14 @@ typedef long long sexp_lsint_t; #if !SEXP_USE_CUSTOM_LONG_LONGS +#define sexp_lsint_fits_sint(x) ((sexp_sint_t)x == x) +#define sexp_luint_fits_uint(x) ((sexp_uint_t)x == x) #define lsint_from_sint(v) ((sexp_lsint_t)v) #define luint_from_uint(v) ((sexp_luint_t)v) #define lsint_to_sint(v) ((sexp_sint_t)v) #define luint_to_uint(v) ((sexp_uint_t)v) +#define lsint_to_sint_hi(v) ((sexp_sint_t) ((v) >> (8*sizeof(sexp_sint_t)))) +#define luint_to_uint_hi(v) ((sexp_uint_t) ((v) >> (8*sizeof(sexp_uint_t)))) #define lsint_negate(v) (-((sexp_lsint_t)v)) #define luint_eq(a, b) (((sexp_luint_t)a)==((sexp_luint_t)b)) #define luint_lt(a, b) (((sexp_luint_t)a)<((sexp_luint_t)b)) @@ -54,6 +58,17 @@ typedef long long sexp_lsint_t; #else +static inline int lsint_lt_0(sexp_lsint_t a) { + return a.hi < 0; +} + +static inline int sexp_lsint_fits_sint(sexp_lsint_t x) { + return x.hi == (((int64_t)x.lo)>>63) && ((sexp_sint_t)x.lo == x.lo); +} +static inline int sexp_luint_fits_uint(sexp_luint_t x) { + return x.hi == 0 && ((sexp_uint_t)x.lo == x.lo); +} + static inline sexp_luint_t luint_from_lsint(sexp_lsint_t v) { sexp_luint_t result; result.hi = v.hi; @@ -83,13 +98,29 @@ static inline sexp_luint_t luint_from_uint(sexp_uint_t v) { } static inline sexp_sint_t lsint_to_sint(sexp_lsint_t v) { - return v.lo; + return lsint_lt_0(v) ? -v.lo : v.lo; } static inline sexp_uint_t luint_to_uint(sexp_luint_t v) { return v.lo; } +static inline sexp_sint_t lsint_to_sint_hi(sexp_lsint_t v) { +#if SEXP_64_BIT + return v.hi; +#else + return v.lo >> 32; +#endif +} + +static inline sexp_uint_t luint_to_uint_hi(sexp_luint_t v) { +#if SEXP_64_BIT + return v.hi; +#else + return v.lo >> 32; +#endif +} + static inline sexp_lsint_t lsint_negate(sexp_lsint_t v) { sexp_luint_t a; a.hi = ~v.hi; @@ -115,7 +146,7 @@ static inline sexp_lsint_t lsint_negate(sexp_lsint_t v) { uint64_t sumHiHi = aHiHi + carry; uint64_t resultHiHi = sumHiHi & 0xFFFFFFFF; - //carry = sumHiHi >> 32; + /* carry = sumHiHi >> 32; */ sexp_lsint_t result; result.hi = (resultHiHi << 32) | resultHiLo; @@ -136,10 +167,6 @@ static inline int luint_lt(sexp_luint_t a, sexp_luint_t b) { return a.lo < b.lo; } -static inline int lsint_lt_0(sexp_lsint_t a) { - return a.hi < 0; -} - static inline sexp_luint_t luint_shl(sexp_luint_t v, size_t shift) { if (shift == 0) return v; diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 68b37edf..c5ba9d83 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -961,8 +961,8 @@ SEXP_API int sexp_idp(sexp x); SEXP_API sexp sexp_make_integer_from_lsint(sexp ctx, sexp_lsint_t x); SEXP_API sexp sexp_make_unsigned_integer_from_luint(sexp ctx, sexp_luint_t x); #if SEXP_USE_CUSTOM_LONG_LONGS -#define sexp_make_integer(ctx, x) sexp_make_fixnum(x) -#define sexp_make_unsigned_integer(ctx, x) sexp_make_fixnum(x) +SEXP_API sexp sexp_make_integer(sexp ctx, long long x); +SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, unsigned long long x); #else SEXP_API sexp sexp_make_integer(sexp ctx, sexp_lsint_t x); SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); @@ -1046,12 +1046,24 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); sexp_negate_exact(x) #if SEXP_USE_FLONUMS || SEXP_USE_BIGNUMS -#define sexp_uint_value(x) ((sexp_uint_t)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignump(x) ? sexp_bignum_data(x)[0] : 0)) -#define sexp_sint_value(x) ((sexp_sint_t)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignump(x) ? sexp_bignum_sign(x)*sexp_bignum_data(x)[0] : 0)) + +#if SEXP_64_BIT +#define sexp_bignum_to_sint(x) (sexp_bignum_sign(x)*sexp_bignum_data(x)[0]) +#define sexp_bignum_to_uint(x) (sexp_bignum_data(x)[0]) #else +SEXP_API long long sexp_bignum_to_sint(sexp x); +SEXP_API unsigned long long sexp_bignum_to_uint(sexp x); +#endif + +#define sexp_uint_value(x) ((unsigned long long)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignump(x) ? sexp_bignum_to_uint(x) : 0)) +#define sexp_sint_value(x) ((long long)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignump(x) ? sexp_bignum_to_sint(x) : 0)) + +#else + #define sexp_uint_value(x) ((sexp_uint_t)sexp_unbox_fixnum(x)) #define sexp_sint_value(x) ((sexp_sint_t)sexp_unbox_fixnum(x)) -#endif + +#endif /* SEXP_USE_FLONUMS || SEXP_USE_BIGNUMS */ #define sexp_shift_epoch(x) ((x)-SEXP_EPOCH_OFFSET) #define sexp_unshift_epoch(x) ((x)+SEXP_EPOCH_OFFSET) diff --git a/lib/chibi/bytevector-test.sld b/lib/chibi/bytevector-test.sld index eb8cb0e3..b4b11f5e 100644 --- a/lib/chibi/bytevector-test.sld +++ b/lib/chibi/bytevector-test.sld @@ -62,7 +62,9 @@ ((null? ls)) (let ((bv (make-bytevector 8 0))) (bytevector-ieee-double-native-set! bv 0 (car ls)) - (test (bytevector-copy f64-le i (+ i 8)) (values bv))))) + ;;(test (bytevector-copy f64-le i (+ i 8)) (values bv)) + (test (car ls) + (bytevector-ieee-double-native-ref bv 0))))) (test-group "ber integers" (do ((ls '(0 1 128 16383 32767 diff --git a/lib/chibi/bytevector.sld b/lib/chibi/bytevector.sld index 8bb1f017..815a190b 100644 --- a/lib/chibi/bytevector.sld +++ b/lib/chibi/bytevector.sld @@ -35,7 +35,7 @@ (else (import (srfi 60)))) (include "bytevector.scm") (cond-expand - ;;(chibi - ;; (include-shared "ieee-754-native")) + (chibi + (import (except (scheme bytevector) bytevector-copy!))) (else (include "ieee-754.scm")))) diff --git a/lib/scheme/bytevector-test.sld b/lib/scheme/bytevector-test.sld index 6f3cff7b..c26417e7 100644 --- a/lib/scheme/bytevector-test.sld +++ b/lib/scheme/bytevector-test.sld @@ -280,41 +280,33 @@ (test-begin "2.7 Operations on 64-bit Integers") - (test-assert "bytevector-u64-ref" - (let ((b (u8-list->bytevector - '(255 255 255 255 255 255 255 255 - 255 255 255 255 255 255 255 253)))) - (and (equal? (bytevector-u64-ref b 8 (endianness little)) - #xfdffffffffffffff) - (equal? (bytevector-u64-ref b 8 (endianness big)) - #xfffffffffffffffd)))) + (let ((b (u8-list->bytevector + '(255 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 253)))) + (test #xfdffffffffffffff + (bytevector-u64-ref b 8 (endianness little))) + (test #xfffffffffffffffd + (bytevector-u64-ref b 8 (endianness big))) + (test -144115188075855873 + (bytevector-s64-ref b 8 (endianness little))) + (test -3 + (bytevector-s64-ref b 8 (endianness big)))) - (test-assert "bytevector-s64-ref" - (let ((b (u8-list->bytevector - '(255 255 255 255 255 255 255 255 - 255 255 255 255 255 255 255 253)))) - (and (equal? (bytevector-s64-ref b 8 (endianness little)) - -144115188075855873) - (equal? (bytevector-s64-ref b 8 (endianness big)) - -3)))) + (let ((b (make-bytevector 8)) + (big 9333333333333333333)) + (bytevector-u64-set! b 0 big (endianness little)) + (test big + (bytevector-u64-ref b 0 (endianness little))) + (test (- big (expt 2 64)) + (bytevector-s64-ref b 0 (endianness little)))) - (test-assert "bytevector-{u64,s64}-ref" - (let ((b (make-bytevector 8)) - (big 9333333333333333333)) - (bytevector-u64-set! b 0 big (endianness little)) - (and (equal? (bytevector-u64-ref b 0 (endianness little)) - big) - (equal? (bytevector-s64-ref b 0 (endianness little)) - (- big (expt 2 64)))))) - - (test-assert "bytevector-{u64,s64}-native-{ref,set!}" - (let ((b (make-bytevector 8)) - (big 9333333333333333333)) - (bytevector-u64-native-set! b 0 big) - (and (equal? (bytevector-u64-native-ref b 0) - big) - (equal? (bytevector-s64-native-ref b 0) - (- big (expt 2 64)))))) + (let ((b (make-bytevector 8)) + (big 9333333333333333333)) + (bytevector-u64-native-set! b 0 big) + (test big + (bytevector-u64-native-ref b 0)) + (test (- big (expt 2 64)) + (bytevector-s64-native-ref b 0))) (test-assert "ref/set! with zero" (let ((b (make-bytevector 8))) diff --git a/sexp.c b/sexp.c index b17e808b..8940e6e8 100644 --- a/sexp.c +++ b/sexp.c @@ -3058,13 +3058,13 @@ sexp sexp_list_to_uvector_op(sexp ctx, sexp self, sexp_sint_t n, sexp etype, sex case SEXP_U16: ((unsigned short*)sexp_uvector_data(res))[i] = sexp_unbox_fixnum(sexp_car(ls)); break; case SEXP_S32: - ((signed int*)sexp_uvector_data(res))[i] = sexp_sint_value(sexp_car(ls)); break; + ((int32_t*)sexp_uvector_data(res))[i] = sexp_sint_value(sexp_car(ls)); break; case SEXP_U32: - ((unsigned int*)sexp_uvector_data(res))[i] = sexp_uint_value(sexp_car(ls)); break; + ((uint32_t*)sexp_uvector_data(res))[i] = sexp_uint_value(sexp_car(ls)); break; case SEXP_S64: - ((sexp_sint_t*)sexp_uvector_data(res))[i] = sexp_sint_value(sexp_car(ls)); break; + ((int64_t*)sexp_uvector_data(res))[i] = sexp_sint_value(sexp_car(ls)); break; case SEXP_U64: - ((sexp_uint_t*)sexp_uvector_data(res))[i] = sexp_uint_value(sexp_car(ls)); break; + ((uint64_t*)sexp_uvector_data(res))[i] = sexp_uint_value(sexp_car(ls)); break; #if SEXP_USE_FLONUMS case SEXP_F32: ((float*)sexp_uvector_data(res))[i] = sexp_to_double(ctx, sexp_car(ls)); break; diff --git a/tests/build/build-opts.txt b/tests/build/build-opts.txt index bddbd6a6..04e99e52 100644 --- a/tests/build/build-opts.txt +++ b/tests/build/build-opts.txt @@ -35,5 +35,7 @@ CFLAGS=-DSEXP_USE_STATIC_LIBS_NO_INCLUDE=0;CPPFLAGS=-DSEXP_USE_STATIC_LIBS=1 CPPFLAGS=-DSEXP_USE_MUTABLE_STRINGS=0 CPPFLAGS=-DSEXP_USE_STRING_INDEX_TABLE=1 CPPFLAGS=-DSEXP_USE_STRICT_TOPLEVEL_BINDINGS=1 +CPPFLAGS=-DSEXP_USE_FIXED_CHUNK_SIZE_HEAPS=1 CPPFLAGS=-DSEXP_USE_NO_FEATURES=1 CFLAGS=-std=c89 +CFLAGS=-m32;LDFLAGS=-m32