From 42cb80bc70e1fb97dabd1e0a2dff5d93257b1f40 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 10 Jun 2020 18:55:33 -0600 Subject: [PATCH] make `fl->fx` truncate Change `fl->fx` to truncate as it converts, which is typically done anyway by a machine instruction to convert from floating-point to integer values. This makes `fl->fx` different from `inexact->exact` or `fl->exact-integer`, but it brings BC and CS in line. --- pkgs/base/info.rkt | 2 +- .../scribblings/reference/extflonums.scrbl | 9 ++- .../scribblings/reference/fixnums.scrbl | 15 +++- .../scribblings/reference/unsafe.scrbl | 15 ++-- .../tests/racket/extflonum.rktl | 55 +++++++++++++ .../racket-test-core/tests/racket/fixnum.rktl | 75 +++++++++++++++++ .../tests/racket/jitinline.rktl | 14 ++++ racket/src/cs/bootstrap/scheme-lang.rkt | 2 + racket/src/racket/src/jit.h | 7 +- racket/src/racket/src/jitarith.c | 64 +++++++++++++-- racket/src/racket/src/jitfpu.h | 6 ++ racket/src/racket/src/jitinline.c | 16 ++-- racket/src/racket/src/lightning/i386/asm.h | 3 + .../src/racket/src/lightning/i386/fp-extfpu.h | 76 ++++++++++++----- racket/src/racket/src/lightning/i386/fp-sse.h | 6 +- racket/src/racket/src/lightning/i386/fp.h | 7 +- racket/src/racket/src/lightning/ppc/fp.h | 1 + racket/src/racket/src/longdouble/longdouble.c | 1 + racket/src/racket/src/longdouble/longdouble.h | 2 +- racket/src/racket/src/number.c | 81 +++++++------------ racket/src/racket/src/numstr.c | 52 ++++++++++++ racket/src/racket/src/schpriv.h | 5 ++ racket/src/racket/src/schvers.h | 2 +- 23 files changed, 409 insertions(+), 107 deletions(-) diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index 81eee47c19..192b49e851 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -12,7 +12,7 @@ (define collection 'multi) -(define version "7.7.0.7") +(define version "7.7.0.8") (define deps `("racket-lib" ["racket" #:version ,version])) diff --git a/pkgs/racket-doc/scribblings/reference/extflonums.scrbl b/pkgs/racket-doc/scribblings/reference/extflonums.scrbl index 3194fdf169..3706c4c021 100644 --- a/pkgs/racket-doc/scribblings/reference/extflonums.scrbl +++ b/pkgs/racket-doc/scribblings/reference/extflonums.scrbl @@ -110,13 +110,16 @@ Like @racket[flsin], @racket[flcos], @racket[fltan], @racket[flasin], @defproc[(extfl->exact-integer [a extflonum?]) exact-integer?] @defproc[(real->extfl [a real?]) extflonum?] @defproc[(extfl->exact [a extflonum?]) (and/c real? exact?)] +@defproc[(extfl->fl [a extflonum?]) fixnum?] @defproc[(extfl->inexact [a extflonum?]) flonum?] )]{ -The first four are like @racket[->fl], @racket[fl->exact], -@racket[fl->real], @racket[inexact->exact], but for @tech{extflonums}. +The first five are like @racket[->fl], @racket[fl->exact-integer], +@racket[real->fl], @racket[inexact->exact], and @racket[fl->fx], but for @tech{extflonums}. The @racket[extfl->inexact] function converts a @tech{extflonum} to -its closest @tech{flonum} approximation.} +its closest @tech{flonum} approximation. + +@history[#:changed "7.7.0.8" @elem{Changed @racket[extfl->fx] to truncate.}]} @; ------------------------------------------------------------------------ diff --git a/pkgs/racket-doc/scribblings/reference/fixnums.scrbl b/pkgs/racket-doc/scribblings/reference/fixnums.scrbl index bb24f32565..2ea03c8d7b 100644 --- a/pkgs/racket-doc/scribblings/reference/fixnums.scrbl +++ b/pkgs/racket-doc/scribblings/reference/fixnums.scrbl @@ -96,10 +96,21 @@ Safe versions of @racket[unsafe-fx=], @racket[unsafe-fx<], @deftogether[( @defproc[(fx->fl [a fixnum?]) flonum?] -@defproc[(fl->fx [a flonum?]) fixnum?] +@defproc[(fl->fx [fl flonum?]) fixnum?] )]{ -Safe versions of @racket[unsafe-fx->fl] and @racket[unsafe-fl->fx].} +Conversion between @tech{fixnums} and @tech{flonums} with truncation +in the case of converting a @tech{flonum} to a @tech{fixnum}. + +The @racket[fx->fl] function is the same as @racket[exact->inexact] or +@racket[->fl] constrained to a fixnum argument. + +The @racket[fl->fx] function is the same as @racket[truncate] followed +by @racket[inexact->exact] or @racket[fl->exact-integer] constrained +to returning a fixnum. If the truncated flonum does not fit into a +fixnum, the @exnraise[exn:fail:contract]. + +@history[#:changed "7.7.0.8" @elem{Changed @racket[fl->fx] to truncate.}]} @defproc[(fixnum-for-every-system? [v any/c]) boolean?]{ diff --git a/pkgs/racket-doc/scribblings/reference/unsafe.scrbl b/pkgs/racket-doc/scribblings/reference/unsafe.scrbl index 4170e5268b..c4234cdd47 100644 --- a/pkgs/racket-doc/scribblings/reference/unsafe.scrbl +++ b/pkgs/racket-doc/scribblings/reference/unsafe.scrbl @@ -196,10 +196,10 @@ For @tech{flonums}: Unchecked versions of @racket[make-flrectangular], @defproc[(unsafe-fx->fl [a fixnum?]) flonum?] @defproc[(unsafe-fl->fx [a flonum?]) fixnum?] )]{ -Unchecked conversion of a fixnum to an integer flonum and vice versa. -These are similar to the safe bindings @racket[->fl] and @racket[fl->exact-integer], -but further constrained to consume or produce a fixnum. -} +Unchecked versions of @racket[fx->fl] and @racket[fl->fx]. + +@history[#:changed "7.7.0.8" @elem{Changed @racket[unsafe-fl->fx] to truncate.}]} + @defproc[(unsafe-flrandom [rand-gen pseudo-random-generator?]) (and flonum? (>/c 0) (extfl [a fixnum?]) extflonum?] @defproc[(unsafe-extfl->fx [a extflonum?]) fixnum?] )]{ -Unchecked conversion of a @tech{fixnum} to an integer @tech{extflonum} and vice versa. -These are similar to the safe bindings @racket[->extfl] and @racket[extfl->exact-integer], -but further constrained to consume or produce a fixnum. -} +Unchecked (potentially) versions of @racket[fx->extfl] and @racket[extfl->fx]. + +@history[#:changed "7.7.0.8" @elem{Changed @racket[unsafe-fl->fx] to truncate.}]} @deftogether[( @defproc[(unsafe-extflvector-length [v extflvector?]) fixnum?] diff --git a/pkgs/racket-test-core/tests/racket/extflonum.rktl b/pkgs/racket-test-core/tests/racket/extflonum.rktl index 838c277c42..c12f89a761 100644 --- a/pkgs/racket-test-core/tests/racket/extflonum.rktl +++ b/pkgs/racket-test-core/tests/racket/extflonum.rktl @@ -418,6 +418,61 @@ ;; ---------------------------------------- + (test 2 extfl->fx 2.0t0) + (test 2 extfl->fx 2.2t0) + (test -2 extfl->fx -2.0t0) + (test -2 extfl->fx -2.2t0) + + (test 0 extfl->fx 0.0t0) + (test 0 extfl->fx -0.0t0) + + (err/rt-test (extfl->fx +inf.t)) + (err/rt-test (extfl->fx -inf.t)) + (err/rt-test (extfl->fx +nan.t)) + + (if (fixnum? 536870911) + (begin + (test 536870911 extfl->fx 536870911.0t0) + (test 536870911 extfl->fx 536870911.5t0)) + (begin + (err/rt-test (extfl->fx 536870911.0t0)) + (err/rt-test (extfl->fx 536870911.5t0)))) + (if (fixnum? -536870912) + (begin + (test -536870912 extfl->fx -536870912.0t0) + (test -536870912 extfl->fx -536870912.5t0)) + (begin + (err/rt-test (extfl->fx -536870912.0t0)) + (err/rt-test (extfl->fx -536870912.5t0)))) + + (if (fixnum? 1073741823) + (begin + (test 1073741823 extfl->fx 1073741823.0t0) + (test 1073741823 extfl->fx 1073741823.5t0)) + (begin + (err/rt-test (extfl->fx 1073741823.0t0)) + (err/rt-test (extfl->fx 1073741823.5t0)))) + (if (fixnum? -1073741824) + (begin + (test -1073741824 extfl->fx -1073741824.0t0) + (test -1073741824 extfl->fx -1073741824.5t0)) + (begin + (err/rt-test (extfl->fx -1073741824.0t0)) + (err/rt-test (extfl->fx -1073741824.5t0)))) + + (if (fixnum? 4611686018427387903) + (test 4611686018427387903 extfl->fx 4611686018427387903.0t0) + (err/rt-test (extfl->fx 4611686018427387903.0t0))) + (if (fixnum? -4611686018427387904) + (test -4611686018427387904 extfl->fx -4611686018427387904.0t0) + (err/rt-test (extfl->fx -4611686018427387904.0t0))) + + ;; Too big for all current fixnum ranges: + (err/rt-test (extfl->fx 4611686018427387904.0t0)) + (err/rt-test (extfl->fx -4611686018427387905.0t0)) + + + ) (report-errs) diff --git a/pkgs/racket-test-core/tests/racket/fixnum.rktl b/pkgs/racket-test-core/tests/racket/fixnum.rktl index df2f6c0638..d27cb8eaa7 100644 --- a/pkgs/racket-test-core/tests/racket/fixnum.rktl +++ b/pkgs/racket-test-core/tests/racket/fixnum.rktl @@ -269,4 +269,79 @@ ;; ---------------------------------------- +(test 2.0 fx->fl 2) +(test -2.0 fx->fl -2) + +(test 2 fl->fx 2.0) +(test 2 fl->fx 2.2) +(test -2 fl->fx -2.0) +(test -2 fl->fx -2.2) + +(test 0 fl->fx 0.0) +(test 0 fl->fx -0.0) + +(err/rt-test (fl->fx +inf.0)) +(err/rt-test (fl->fx -inf.0)) +(err/rt-test (fl->fx +nan.0)) + +(if (fixnum? 536870911) + (begin + (test 536870911 fl->fx 536870911.0) + (test 536870911 fl->fx 536870911.5)) + (begin + (err/rt-test (fl->fx 536870911.0)) + (err/rt-test (fl->fx 536870911.5)))) +(if (fixnum? -536870912) + (begin + (test -536870912 fl->fx -536870912.0) + (test -536870912 fl->fx -536870912.5)) + (begin + (err/rt-test (fl->fx -536870912.0)) + (err/rt-test (fl->fx -536870912.5)))) + +(if (fixnum? 1073741823) + (begin + (test 1073741823 fl->fx 1073741823.0) + (test 1073741823 fl->fx 1073741823.5)) + (begin + (err/rt-test (fl->fx 1073741823.0)) + (err/rt-test (fl->fx 1073741823.5)))) +(if (fixnum? -1073741824) + (begin + (test -1073741824 fl->fx -1073741824.0) + (test -1073741824 fl->fx -1073741824.5)) + (begin + (err/rt-test (fl->fx -1073741824.0)) + (err/rt-test (fl->fx -1073741824.5)))) + +(if (fixnum? 1152921504606846975) + (test 1152921504606846848 fl->fx 1152921504606846800.0) + (err/rt-test (fl->fx 1152921504606846800.0))) +(if (fixnum? -1152921504606846976) + (test -1152921504606846976 fl->fx -1152921504606847000.0) + (err/rt-test (fl->fx -1152921504606847000.0))) + +(if (fixnum? 1152921504606846976) + (test 1152921504606846976 fl->fx 1152921504606847000.0) + (err/rt-test (fl->fx 1152921504606847000.0))) +(if (fixnum? -1152921504606847232) + (test -1152921504606847232 fl->fx -1152921504606847200.0) + (err/rt-test (fl->fx -1152921504606847200.0))) + +(if (fixnum? 4611686018427387903) + ;; Note: 4611686018427387903 won't round-trip + ;; if it's the biggest fixnum + (test 4611686018427387392 fl->fx 4.6116860184273874e+18) + (err/rt-test (fl->fx 4.6116860184273874e+18))) +(if (fixnum? -4611686018427387904) + ;; Ditto (about round-trip) + (test -4611686018427387904 fl->fx -4.611686018427388e+18) + (err/rt-test (fl->fx -4.611686018427388e+18))) + +;; Too big for all current fixnum ranges: +(err/rt-test (fl->fx 4.611686018427388e+18)) +(err/rt-test (fl->fx -4.611686018427389e+18)) + +;; ---------------------------------------- + (report-errs) diff --git a/pkgs/racket-test-core/tests/racket/jitinline.rktl b/pkgs/racket-test-core/tests/racket/jitinline.rktl index ad6989cb2e..5305ab7f8e 100644 --- a/pkgs/racket-test-core/tests/racket/jitinline.rktl +++ b/pkgs/racket-test-core/tests/racket/jitinline.rktl @@ -547,7 +547,14 @@ (un-exact -1 'fl->exact-integer -1.0) (un-exact (inexact->exact 5e200) 'fl->exact-integer 5e200) (un-exact 11 'fl->fx 11.0 #t) + (un-exact 11 'fl->fx 11.5 #t) (un-exact -11 'fl->fx -11.0) + (un-exact -11 'fl->fx -11.5) + (check-error-message 'fl->fx (eval `(lambda (x) (fl->fx x))) #:bad-value (exact->inexact (expt 2 100))) + (check-error-message 'fl->fx (eval `(lambda (x) (fl->fx x))) #:bad-value (exact->inexact (- (expt 2 100)))) + (check-error-message 'fl->fx (eval `(lambda (x) (fl->fx x))) #:bad-value +inf.0) + (check-error-message 'fl->fx (eval `(lambda (x) (fl->fx x))) #:bad-value -inf.0) + (check-error-message 'fl->fx (eval `(lambda (x) (fl->fx x))) #:bad-value +nan.0) (un 4 '+ 4) (bin 11 '+ 4 7) @@ -910,7 +917,14 @@ (un-exact -1 'extfl->exact-integer -1.0t0) (un-exact (inexact->exact 5e200) 'extfl->exact-integer (real->extfl 5e200)) (un-exact 11 'extfl->fx 11.0t0 #t) + (un-exact 11 'extfl->fx 11.5t0 #t) (un-exact -11 'extfl->fx -11.0t0) + (un-exact -11 'extfl->fx -11.5t0) + (check-error-message 'extfl->fx (eval `(lambda (x) (extfl->fx x))) #:bad-value (->extfl (expt 2 100))) + (check-error-message 'extfl->fx (eval `(lambda (x) (extfl->fx x))) #:bad-value (->extfl (- (expt 2 100)))) + (check-error-message 'extfl->fx (eval `(lambda (x) (extfl->fx x))) #:bad-value +inf.t) + (check-error-message 'extfl->fx (eval `(lambda (x) (extfl->fx x))) #:bad-value -inf.t) + (check-error-message 'extfl->fx (eval `(lambda (x) (extfl->fx x))) #:bad-value +nan.t) (bin-exact -0.75t0 'extfl- 1.5t0 2.25t0 #t) diff --git a/racket/src/cs/bootstrap/scheme-lang.rkt b/racket/src/cs/bootstrap/scheme-lang.rkt index e03e2c2404..932ff97c75 100644 --- a/racket/src/cs/bootstrap/scheme-lang.rkt +++ b/racket/src/cs/bootstrap/scheme-lang.rkt @@ -3,6 +3,7 @@ racket/match) (prefix-in r: racket/include) racket/fixnum + racket/flonum racket/vector racket/splicing racket/pretty @@ -140,6 +141,7 @@ [bitwise-and logand] [bitwise-bit-set? fxbit-set?] [integer-length bitwise-length] + [->fl fixnum->flonum] [+ cfl+] [- cfl-] [* cfl*] diff --git a/racket/src/racket/src/jit.h b/racket/src/racket/src/jit.h index aac5241a6b..8b348b109a 100644 --- a/racket/src/racket/src/jit.h +++ b/racket/src/racket/src/jit.h @@ -1231,6 +1231,7 @@ static void emit_indentation(mz_jit_state *jitter) #define jit_bantieqr_d_fppop(d, s1, s2) jit_bantieqr_d(d, s1, s2) #define jit_extr_l_d_fppush(rd, rs) jit_extr_l_d(rd, rs) #define jit_roundr_d_l_fppop(rd, rs) jit_roundr_d_l(rd, rs) +#define jit_truncr_d_l_fppop(rd, rs) jit_truncr_d_l(rd, rs) #define jit_movr_d_rel(rd, rs) jit_movr_d(rd, rs) #define jit_movr_d_fppush(rd, rs) jit_movr_d(rd, rs) #define R0_FP_ADJUST(x) /* empty */ @@ -1668,10 +1669,12 @@ Scheme_Object *scheme_jit_continuation_apply_install(Apply_LWC_Args *args); /* flfloor, flceiling, flround, fltruncate, flsin, flcos, fltan, */ /* flasin, flacos, flatan, flexp, fllog */ #define ARITH_FLUNOP 14 -/* inexact->exact, unsafe-fl->fx, fl->exact-integer, fl->fx */ +/* inexact->exact, fl->exact-integer */ #define ARITH_INEX_EX 15 +/* fl->fx, unsafe-fl->fx, extfl->fx, unsafe-extfl->fx */ +#define ARITH_INEX_TRUNC_EX 16 /* flexpt */ -#define ARITH_EXPT 16 +#define ARITH_EXPT 17 /* Comparison codes. Used in jitarith.c and jitinline.c. */ diff --git a/racket/src/racket/src/jitarith.c b/racket/src/racket/src/jitarith.c index 79f1a372dc..d1990497c5 100644 --- a/racket/src/racket/src/jitarith.c +++ b/racket/src/racket/src/jitarith.c @@ -451,7 +451,8 @@ static int can_fast_double(int arith, int cmp, int two_args) || (arith == ARITH_EX_INEX) || (arith == ARITH_SQRT) || (arith == ARITH_FLUNOP) - || (arith == ARITH_INEX_EX)) + || (arith == ARITH_INEX_EX) + || (arith == ARITH_INEX_TRUNC_EX)) return 1; #endif #ifdef INLINE_FP_COMP @@ -596,7 +597,7 @@ static int generate_float_point_arith(mz_jit_state *jitter, Scheme_Object *rator If unboxed in push/pop mode, first arg is pushed before second. If unboxed in direct mode, first arg is in JIT_FPR0+depth and second is in JIT_FPR1+depth (which is backward). - Unboxed implies unsafe unless arith == ARITH_INEX_EX. */ + Unboxed implies unsafe unless arith == ARITH_INEX_EX or arith == ARITH_INEX_TRUNC_EX. */ { #if defined(INLINE_FP_OPS) || defined(INLINE_FP_COMP) GC_CAN_IGNORE jit_insn *ref8, *ref9, *ref10, *refd, *refdt, *refs = NULL, *refs2 = NULL; @@ -660,6 +661,8 @@ static int generate_float_point_arith(mz_jit_state *jitter, Scheme_Object *rator /* exact->inexact needs no extra number */ } else if (arith == ARITH_INEX_EX) { /* inexact->exact needs no extra number */ + } else if (arith == ARITH_INEX_TRUNC_EX) { + /* fl->fx needs no extra number */ } else { #ifdef MZ_LONG_DOUBLE long_double d; @@ -825,6 +828,52 @@ static int generate_float_point_arith(mz_jit_state *jitter, Scheme_Object *rator jit_fixnum_l(dest, JIT_R1); no_alloc = 1; break; + case ARITH_INEX_TRUNC_EX: /* fl->fx */ + if (!unsafe_fl) { +#ifdef DIRECT_FPR_ACCESS + if (unboxed && USES_DIRECT_FPR_ACCESS) { + JIT_ASSERT(jitter->unbox_depth == 0); + jit_FPSEL_movr_xd_fppush(extfl, JIT_FPR2, fpr0); /* for slow path */ + } +#endif +#if !defined(DIRECT_FPR_ACCESS) || defined(MZ_LONG_DOUBLE) + if (!USES_DIRECT_FPR_ACCESS) { + jit_FPSEL_movr_xd_fppush(extfl, fpr0, fpr0); /* copy for comparison */ + } +#endif +#ifdef MZ_LONG_DOUBLE + if (extfl) { + mz_fpu_movi_ld_fppush(fpr1, scheme_extfl_too_positive_for_fixnum, JIT_R1); + } else +#endif + { + mz_movi_d_fppush(fpr1, scheme_double_too_positive_for_fixnum, JIT_R1); + } + __START_TINY_JUMPS__(1); + refs = jit_FPSEL_bantigtr_xd_fppop(extfl, jit_forward(), fpr1, fpr0); + __END_TINY_JUMPS__(1); + +#if !defined(DIRECT_FPR_ACCESS) || defined(MZ_LONG_DOUBLE) + if (!USES_DIRECT_FPR_ACCESS) { + jit_FPSEL_movr_xd_fppush(extfl, fpr0, fpr0); /* copy for comparison */ + } +#endif +#ifdef MZ_LONG_DOUBLE + if (extfl) { + mz_fpu_movi_ld_fppush(fpr1, scheme_extfl_too_negative_for_fixnum, JIT_R1); + } else +#endif + { + mz_movi_d_fppush(fpr1, scheme_double_too_negative_for_fixnum, JIT_R1); + } + __START_TINY_JUMPS__(1); + refs2 = jit_FPSEL_bantiltr_xd_fppop(extfl, jit_forward(), fpr1, fpr0); + __END_TINY_JUMPS__(1); + } + jit_FPSEL_truncr_xd_l_fppop(extfl, JIT_R1, fpr0); + jit_fixnum_l(dest, JIT_R1); + no_alloc = 1; + break; case ARITH_SQRT: jit_FPSEL_sqrt_xd_fppop(extfl, fpr0, fpr0); break; @@ -1166,7 +1215,7 @@ int scheme_generate_arith_for(mz_jit_state *jitter, Scheme_Object *rator, Scheme int args_unboxed = (((arith != ARITH_MIN) && (arith != ARITH_MAX)) || rand); int flonum_depth, fl_reversed = 0, can_direct1, can_direct2; - if (inlined_flonum1 && inlined_flonum2 && (arith != ARITH_INEX_EX)) + if (inlined_flonum1 && inlined_flonum2 && (arith != ARITH_INEX_EX) && (arith != ARITH_INEX_TRUNC_EX)) /* safe can be implemented as unsafe */ unsafe_fl = 1; @@ -1278,19 +1327,20 @@ int scheme_generate_arith_for(mz_jit_state *jitter, Scheme_Object *rator, Scheme if (!jitter->unbox && jitter->unbox_depth && rand) scheme_signal_error("internal error: broken unbox depth"); if (for_branch - || (arith == ARITH_INEX_EX)) /* has slow path */ + || (arith == ARITH_INEX_EX) /* has slow path */ + || (arith == ARITH_INEX_TRUNC_EX)) /* could have slow path */ mz_rs_sync(); /* needed if arguments were unboxed */ generate_float_point_arith(jitter, rator, arith, cmp, reversed, !!rand2, 0, &refd, &refdt, for_branch, branch_short, - (arith == ARITH_INEX_EX) ? (unsafe_fl > 0) : 1, + ((arith == ARITH_INEX_EX) || (arith == ARITH_INEX_TRUNC_EX)) ? (unsafe_fl > 0) : 1, args_unboxed, jitter->unbox, dest, extfl); CHECK_LIMIT(); ref3 = NULL; ref = NULL; ref4 = NULL; - if ((arith == ARITH_INEX_EX) && (unsafe_fl < 1)) { + if (((arith == ARITH_INEX_EX) || (arith == ARITH_INEX_TRUNC_EX)) && (unsafe_fl < 1)) { /* need a slow path */ if (args_unboxed) { MZ_FPUSEL_STMT(extfl, @@ -1618,7 +1668,7 @@ int scheme_generate_arith_for(mz_jit_state *jitter, Scheme_Object *rator, Scheme if (arith == ARITH_DIV) { GC_CAN_IGNORE jit_insn *refx, *refz; __START_INNER_TINY__(branch_short); - /* watch out for negation of most negative fixnum, + /* watch out for negation of most negrand, NULL, 1, ARITH_INEX_EX, 0, 0, NULL, 1, 0, 0, NULL, dest); return 1; } else if (IS_NAMED_PRIM(rator, "unsafe-fl->fx")) { - scheme_generate_arith(jitter, rator, app->rand, NULL, 1, ARITH_INEX_EX, 0, 0, NULL, 1, 0, 1, NULL, dest); + scheme_generate_arith(jitter, rator, app->rand, NULL, 1, ARITH_INEX_TRUNC_EX, 0, 0, NULL, 1, 0, 1, NULL, dest); return 1; - } else if (IS_NAMED_PRIM(rator, "fl->exact-integer") - || IS_NAMED_PRIM(rator, "fl->fx")) { + } else if (IS_NAMED_PRIM(rator, "fl->exact-integer")) { scheme_generate_arith(jitter, rator, app->rand, NULL, 1, ARITH_INEX_EX, 0, 0, NULL, 1, 0, -1, NULL, dest); return 1; + } else if (IS_NAMED_PRIM(rator, "fl->fx")) { + scheme_generate_arith(jitter, rator, app->rand, NULL, 1, ARITH_INEX_TRUNC_EX, 0, 0, NULL, 1, 0, -1, NULL, dest); + return 1; #ifdef MZ_LONG_DOUBLE } else if (IS_NAMED_PRIM(rator, "unsafe-extflabs")) { scheme_generate_extflonum_arith(jitter, rator, app->rand, NULL, 1, ARITH_ABS, 0, 0, NULL, 1, 0, 1, NULL, dest); @@ -2287,12 +2289,14 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in scheme_generate_extflonum_arith(jitter, rator, app->rand, NULL, 1, ARITH_INEX_EX, 0, 0, NULL, 1, 0, 0, NULL, dest); return 1; } else if (IS_NAMED_PRIM(rator, "unsafe-extfl->fx")) { - scheme_generate_extflonum_arith(jitter, rator, app->rand, NULL, 1, ARITH_INEX_EX, 0, 0, NULL, 1, 0, 1, NULL, dest); + scheme_generate_extflonum_arith(jitter, rator, app->rand, NULL, 1, ARITH_INEX_TRUNC_EX, 0, 0, NULL, 1, 0, 1, NULL, dest); return 1; - } else if (IS_NAMED_PRIM(rator, "extfl->exact-integer") - || IS_NAMED_PRIM(rator, "extfl->fx")) { + } else if (IS_NAMED_PRIM(rator, "extfl->exact-integer")) { scheme_generate_extflonum_arith(jitter, rator, app->rand, NULL, 1, ARITH_INEX_EX, 0, 0, NULL, 1, 0, -1, NULL, dest); return 1; + } else if (IS_NAMED_PRIM(rator, "extfl->fx")) { + scheme_generate_extflonum_arith(jitter, rator, app->rand, NULL, 1, ARITH_INEX_TRUNC_EX, 0, 0, NULL, 1, 0, -1, NULL, dest); + return 1; #endif } else if (IS_NAMED_PRIM(rator, "bitwise-not")) { scheme_generate_arith(jitter, rator, app->rand, NULL, 1, ARITH_NOT, 0, 9, NULL, 1, 0, 0, NULL, dest); diff --git a/racket/src/racket/src/lightning/i386/asm.h b/racket/src/racket/src/lightning/i386/asm.h index 0e942823bd..942e21bd02 100644 --- a/racket/src/racket/src/lightning/i386/asm.h +++ b/racket/src/racket/src/lightning/i386/asm.h @@ -1185,6 +1185,7 @@ typedef _uc jit_insn; #define FISTWm(D,B,I,S) ESCmi(D,B,I,S,072) /* fist m16int */ #define FSTPSm(D,B,I,S) ESCmi(D,B,I,S,013) /* fstp m32real */ #define FISTPLm(D,B,I,S) ESCmi(D,B,I,S,033) /* fistp m32int */ +#define FISTTPLm(D,B,I,S) ESCmi(D,B,I,S,031) /* fisttp m32int */ #define FSTPLm(D,B,I,S) ESCmi(D,B,I,S,053) /* fstp m64real */ #define FISTPWm(D,B,I,S) ESCmi(D,B,I,S,073) /* fistp m16int */ #define FLDTm(D,B,I,S) ESCmi(D,B,I,S,035) /* fld m80real */ @@ -1192,8 +1193,10 @@ typedef _uc jit_insn; #define FSTPTm(D,B,I,S) ESCmi(D,B,I,S,037) /* fstp m80real */ #ifdef JIT_X86_64 # define FISTPQm(D,B,I,S) ESCmi(D,B,I,S,077) /* fistp m64int */ +# define FISTTPQm(D,B,I,S) ESCmi(D,B,I,S,051) /* fisttp m64int */ #else # define FISTPQm(D,B,I,S) FISTPLm(D,B,I,S) +# define FISTTPQm(D,B,I,S) FISTTPLm(D,B,I,S) #endif #define FADDrr(RS,RD) ESCrri(RS,RD,000) diff --git a/racket/src/racket/src/lightning/i386/fp-extfpu.h b/racket/src/racket/src/lightning/i386/fp-extfpu.h index c6c0b59c53..070d050691 100644 --- a/racket/src/racket/src/lightning/i386/fp-extfpu.h +++ b/racket/src/racket/src/lightning/i386/fp-extfpu.h @@ -298,16 +298,36 @@ union jit_fpu_double_imm { #define jit_fpu_extr_d_f(r1, r2) jit_fpu_movr_d(r1, r2) #define jit_fpu_extr_f_d(r1, r2) jit_fpu_movr_d(r1, r2) -/* Assume round to near mode */ +/* the easy one */ +#define jit_fpu_roundr_d_i(rd, rs) \ + (PUSHLr(_EAX), \ + jit_fpu_fxch ((rs), FISTPLm(0, _ESP, 0, 0)), \ + POPLr((rd))) + +#define jit_fpu_roundr_ld_i(rd, rs) jit_fpu_roundr_d_i(rd, rs) + +#define jit_fpu_roundr_d_l(rd, rs) \ + (PUSHQr(_EAX), \ + jit_fpu_fxch ((rs), FISTPQm(0, _ESP, 0, 0)), \ + POPQr((rd))) + +#define jit_fpu_roundr_ld_l(rd, rs) jit_fpu_roundr_d_l(rd, rs) + +#define jit_fpu_roundr_d_l_fppop(rd, rs) \ + (PUSHQr(_EAX), \ + FISTPQm(0, _ESP, 0, 0), \ + POPQr((rd))) + +#define jit_fpu_roundr_ld_l_fppop(rd, rs) jit_fpu_roundr_d_l_fppop(rd, rs) + +/* Other rounding modes assume round to near mode */ + #define jit_fpu_floorr_d_i(rd, rs) \ (FLDr (rs), jit_fpu_floor2((rd), ((rd) == _EDX ? _EAX : _EDX))) #define jit_fpu_ceilr_d_i(rd, rs) \ (FLDr (rs), jit_fpu_ceil2((rd), ((rd) == _EDX ? _EAX : _EDX))) -#define jit_fpu_truncr_d_i(rd, rs) \ - (FLDr (rs), jit_fpu_trunc2((rd), ((rd) == _EDX ? _EAX : _EDX))) - #define jit_fpu_calc_diff(ofs) \ FISTLm(ofs, _ESP, 0, 0), \ FILDLm(ofs, _ESP, 0, 0), \ @@ -337,11 +357,16 @@ union jit_fpu_double_imm { ADCLir(0, rd), \ POPLr(aux)) +#ifndef JIT_X86_64 + +/* 32-bit mode: FSTT is part of SSE3, so not necessarily available, + so use the same strategy as floor and ceiling */ + /* a mingling of the two above */ -#define jit_fpu_trunc2(rd, aux) \ +#define jit_fpu_trunc2(rd, aux, store) \ (PUSHLr(aux), \ SUBLir(12, _ESP), \ - FSTSm(0, _ESP, 0, 0), \ + store(0, _ESP, 0, 0), \ jit_fpu_calc_diff(4), \ POPLr(aux), \ POPLr(rd), \ @@ -357,27 +382,40 @@ union jit_fpu_double_imm { ADCLir(0, rd), /* 3 */ \ POPLr(aux)) -/* the easy one */ -#define jit_fpu_roundr_d_i(rd, rs) \ - (PUSHLr(_EAX), \ - jit_fpu_fxch ((rs), FISTPLm(0, _ESP, 0, 0)), \ - POPLr((rd))) +#define jit_fpu_truncr_d_i(rd, rs) \ + (FLDr (rs), jit_fpu_trunc2((rd), ((rd) == _EDX ? _EAX : _EDX), FSTSm)) -#define jit_fpu_roundr_ld_i(rd, rs) jit_fpu_roundr_d_i(rd, rs) +#define jit_fpu_truncr_d_i_fppop(rd, rs) \ + (FLDr (rs), jit_fpu_trunc2((rd), ((rd) == _EDX ? _EAX : _EDX), FSTPSm)) -#define jit_fpu_roundr_d_l(rd, rs) \ +#define jit_fpu_truncr_ld_i(rd, rs) jit_fpu_truncr_d_i(rd, rs) +#define jit_fpu_truncr_ld_i_fppop(rd, rs) jit_fpu_truncr_d_i_fppop(rd, rs) + +#define jit_fpu_truncr_d_l(rd, rs) jit_fpu_truncr_d_i(rd, rs) +#define jit_fpu_truncr_d_l_fppop(rd, rs) jit_fpu_truncr_d_i_fppop(rd, rs) + +#define jit_fpu_truncr_ld_l(rd, rs) jit_fpu_truncr_d_l(rd, rs) +#define jit_fpu_truncr_ld_l_fppop(rd, rs) jit_fpu_truncr_d_l_fppop(rd, rs) + +#else + +/* 64-bit mode, so SSE3 must be available: use FSTT */ + +#define jit_fpu_truncr_d_l(rd, rs) \ (PUSHQr(_EAX), \ - jit_fpu_fxch ((rs), FISTPQm(0, _ESP, 0, 0)), \ + jit_fpu_fxch ((rs), FISTTPQm(0, _ESP, 0, 0)), \ POPQr((rd))) -#define jit_fpu_roundr_ld_l(rd, rs) jit_fpu_roundr_d_l(rd, rs) +#define jit_fpu_truncr_ld_l(rd, rs) jit_fpu_truncr_d_l(rd, rs) -#define jit_fpu_roundr_d_l_fppop(rd, rs) \ +#define jit_fpu_truncr_d_l_fppop(rd, rs) \ (PUSHQr(_EAX), \ - FISTPQm(0, _ESP, 0, 0), \ + FISTTPQm(0, _ESP, 0, 0), \ POPQr((rd))) -#define jit_fpu_roundr_ld_l_fppop(rd, rs) jit_fpu_roundr_d_l_fppop(rd, rs) +#define jit_fpu_truncr_ld_l_fppop(rd, rs) jit_fpu_truncr_d_l_fppop(rd, rs) + +#endif #define jit_fpu_fp_test(d, s1, s2, n, _and, res) \ (((s1) == 0 ? FUCOMr((s2)) : (FLDr((s1)), FUCOMPr((s2) + 1))), \ @@ -506,7 +544,7 @@ union jit_fpu_double_imm { /* #define jit_fpu_bantiger_d_fppop(d, s1, s2) jit_fpu_fp_btest_fppop((d), 9, 0, 0, JCm) */ #define jit_fpu_bantiger_d_fppop(d, s1, s2) jit_fpu_fp_btest_fppop_2((d), JBm) #define jit_fpu_bantiger_ld_fppop(d, s1, s2) jit_fpu_bantiger_d_fppop(d, s1, s2) -#define jit_fpu_bler_d_fppop(d, s1, s2) (FXCHr(1), jit_fpu_bger_d_fppop(d, s1, s2)) +#define jit_fpu_bler_d_fppop(d, s1, s2) jit_fpu_fp_btest_fppop((d), 9, 0, 0, JNAm) #define jit_fpu_bler_ld_fppop(d, s1, s2) jit_fpu_bler_d_fppop(d, s1, s2) #define jit_fpu_bantiler_d_fppop(d, s1, s2) (FXCHr(1), jit_fpu_bantiger_d_fppop(d, s1, s2)) #define jit_fpu_bantiler_ld_fppop(d, s1, s2) jit_fpu_bantiler_d_fppop(d, s1, s2) diff --git a/racket/src/racket/src/lightning/i386/fp-sse.h b/racket/src/racket/src/lightning/i386/fp-sse.h index 8cd3d7e031..5efc4201fe 100644 --- a/racket/src/racket/src/lightning/i386/fp-sse.h +++ b/racket/src/racket/src/lightning/i386/fp-sse.h @@ -170,8 +170,8 @@ jit_addi_l(JIT_SP, JIT_SP, sizeof(int) << 1)) #endif -/* Racket uses jit_roundr_l only for inexact->exact of fixnums, - so a truncate is good enough. */ +/* Racket has used jit_roundr_l only for inexact->exact of fixnums, + where a truncate was good enough. */ #define jit_roundr_d_i(r0, f0) jit_truncr_d_i(r0, f0) #define jit_roundr_d_l(r0, f0) jit_truncr_d_l(r0, f0) @@ -183,7 +183,7 @@ #endif #define jit_bltr_d(label, f0, f1) (UCOMISDrr(f0, f1), JAEm(label,0,0,0), (_jit.x.pc)) -#define jit_bler_d(label, f0, f1) (UCOMISDrr(f0, f1), JBEm(label,0,0,0), (_jit.x.pc)) +#define jit_bler_d(label, f0, f1) (UCOMISDrr(f1, f0), JBEm(label,0,0,0), (_jit.x.pc)) #define jit_bgtr_d(label, f0, f1) (UCOMISDrr(f1, f0), JAm(label,0,0,0), (_jit.x.pc)) #define jit_bger_d(label, f0, f1) (UCOMISDrr(f1, f0), JAEm(label,0,0,0), (_jit.x.pc)) #define jit_beqr_d(label, f0, f1) \ diff --git a/racket/src/racket/src/lightning/i386/fp.h b/racket/src/racket/src/lightning/i386/fp.h index d0a8228e9f..1b7f56f6d9 100644 --- a/racket/src/racket/src/lightning/i386/fp.h +++ b/racket/src/racket/src/lightning/i386/fp.h @@ -134,13 +134,18 @@ # define jit_stxr_ld_fppop(d1, d2, rs) jit_fpu_stxr_ld_fppop(d1, d2, rs) # define jit_floorr_d_i(rd, rs) jit_fpu_floorr_d_i(rd, rs) # define jit_ceilr_d_i(rd, rs) jit_fpu_ceilr_d_i(rd, rs) -# define jit_truncr_d_i(rd, rs) jit_fpu_truncr_d_i(rd, rs) # define jit_roundr_d_i(rd, rs) jit_fpu_roundr_d_i(rd, rs) # define jit_roundr_ld_i(rd, rs) jit_fpu_roundr_ld_i(rd, rs) # define jit_roundr_d_l(rd, rs) jit_fpu_roundr_d_l(rd, rs) # define jit_roundr_ld_l(rd, rs) jit_fpu_roundr_ld_l(rd, rs) # define jit_roundr_d_l_fppop(rd, rs) jit_fpu_roundr_d_l_fppop(rd, rs) # define jit_roundr_ld_l_fppop(rd, rs) jit_fpu_roundr_ld_l_fppop(rd, rs) +# define jit_truncr_d_i(rd, rs) jit_fpu_truncr_d_i(rd, rs) +# define jit_truncr_ld_i(rd, rs) jit_fpu_truncr_ld_i(rd, rs) +# define jit_truncr_d_l(rd, rs) jit_fpu_truncr_d_l(rd, rs) +# define jit_truncr_ld_l(rd, rs) jit_fpu_truncr_ld_l(rd, rs) +# define jit_truncr_d_l_fppop(rd, rs) jit_fpu_truncr_d_l_fppop(rd, rs) +# define jit_truncr_ld_l_fppop(rd, rs) jit_fpu_truncr_ld_l_fppop(rd, rs) # define jit_gtr_d(d, s1, s2) jit_fpu_gtr_d(d, s1, s2) # define jit_ger_d(d, s1, s2) jit_fpu_ger_d(d, s1, s2) # define jit_unler_d(d, s1, s2) jit_fpu_unler_d(d, s1, s2) diff --git a/racket/src/racket/src/lightning/ppc/fp.h b/racket/src/racket/src/lightning/ppc/fp.h index 57ffacc1da..5a5289b49e 100644 --- a/racket/src/racket/src/lightning/ppc/fp.h +++ b/racket/src/racket/src/lightning/ppc/fp.h @@ -221,6 +221,7 @@ MOVEIri(JIT_AUX,-4), \ STFIWXrrr(7,JIT_SP,JIT_AUX), \ LWZrm((rd),-4,JIT_SP)) +#define jit_truncr_d_l(rd,rs) jit_truncr_d_i(rd,rs) /* Uses JIT_FPR5 as scratch: */ #define jit_extr_i_d(rd, rs) (jit_movi_l(JIT_AUX, 0x43300000), \ diff --git a/racket/src/racket/src/longdouble/longdouble.c b/racket/src/racket/src/longdouble/longdouble.c index e525793d2f..4a48e06ba0 100644 --- a/racket/src/racket/src/longdouble/longdouble.c +++ b/racket/src/racket/src/longdouble/longdouble.c @@ -196,6 +196,7 @@ float float_from_long_double(long_double a) { return (float)a.val; } + intptr_t int_from_long_double(long_double a) { return (intptr_t)a.val; diff --git a/racket/src/racket/src/longdouble/longdouble.h b/racket/src/racket/src/longdouble/longdouble.h index 0eef08767b..97335f6507 100644 --- a/racket/src/racket/src/longdouble/longdouble.h +++ b/racket/src/racket/src/longdouble/longdouble.h @@ -150,7 +150,7 @@ XFORM_NONGCING int long_double_available(); # define double_from_long_double(a) (a) # define float_from_long_double(a) (a) -# define int_from_long_double(a) ((int)(a)) +# define int_from_long_double(a) ((intptr_t)(a)) # define uintptr_from_long_double(a) ((uintptr_t)(a)) # define long_double_plus(a,b) ((a)+(b)) diff --git a/racket/src/racket/src/number.c b/racket/src/racket/src/number.c index d5ed8577df..bf6aa79abe 100644 --- a/racket/src/racket/src/number.c +++ b/racket/src/racket/src/number.c @@ -4065,19 +4065,16 @@ scheme_exact_to_inexact (int argc, Scheme_Object *argv[]) } XFORM_NONGCING static int double_fits_fixnum(double d) -/* returns TRUE if the number definitely fits in an intptr_t - and might fit in a fixnum */ +/* returns TRUE if the number is an integer that fits in a fixnum */ { - int exp; - - if (MZ_IS_NAN(d) - || MZ_IS_POS_INFINITY(d) - || MZ_IS_NEG_INFINITY(d)) +#ifdef NAN_EQUALS_ANYTHING + if (MZ_IS_NAN(d)) return 0; +#endif - (void)frexp(d, &exp); - - return (exp < (8 * sizeof(intptr_t)) - 1); + return ((d < scheme_double_too_positive_for_fixnum) + && (d > scheme_double_too_negative_for_fixnum) + && ((double)((intptr_t)d) == d)); } Scheme_Object * @@ -4091,36 +4088,20 @@ scheme_inexact_to_exact (int argc, Scheme_Object *argv[]) t = _SCHEME_TYPE(o); if (t == scheme_double_type) { double d = SCHEME_DBL_VAL(o); - Scheme_Object *i; /* Try simple case: */ - i = (double_fits_fixnum(d) - ? scheme_make_integer((intptr_t)d) - : scheme_make_integer(0)); - if ((double)SCHEME_INT_VAL(i) == d) { -#ifdef NAN_EQUALS_ANYTHING - if (!MZ_IS_NAN(d)) -#endif - return i; - } + if (double_fits_fixnum(d)) + return scheme_make_integer((intptr_t)d); return scheme_rational_from_double(d); } #ifdef MZ_USE_SINGLE_FLOATS if (t == scheme_float_type) { float d = SCHEME_FLT_VAL(o); - Scheme_Object *i; /* Try simple case: */ - i = (double_fits_fixnum(d) - ? scheme_make_integer((intptr_t)d) - : scheme_make_integer(0)); - if ((double)SCHEME_INT_VAL(i) == d) { -# ifdef NAN_EQUALS_ANYTHING - if (!MZ_IS_NAN(d)) -# endif - return i; - } + if (double_fits_fixnum(d)) + return scheme_make_integer((intptr_t)d); return scheme_rational_from_float(d); } @@ -4179,6 +4160,7 @@ extfl_to_exact (int argc, Scheme_Object *argv[]) #ifdef MZ_LONG_DOUBLE Scheme_Object *o = argv[0], *i; long_double d; + intptr_t v; CHECK_MZ_LONG_DOUBLE_UNSUPPORTED("extfl->exact"); @@ -4188,7 +4170,8 @@ extfl_to_exact (int argc, Scheme_Object *argv[]) d = SCHEME_LONG_DBL_VAL(o); /* Try simple case: */ - i = scheme_make_integer((intptr_t)int_from_long_double(d)); + v = int_from_long_double(d); + i = scheme_make_integer(v); if (long_double_eqv_i(int_from_long_double(d), d)) { # ifdef NAN_EQUALS_ANYTHING if (!MZ_IS_LONG_NAN(d)) @@ -5309,21 +5292,15 @@ static Scheme_Object *fx_to_fl (int argc, Scheme_Object *argv[]) static Scheme_Object *fl_to_fx (int argc, Scheme_Object *argv[]) { double d; - intptr_t v; - Scheme_Object *o; - if (!SCHEME_DBLP(argv[0]) - || !scheme_is_integer(argv[0])) - scheme_wrong_contract("fl->fx", "(and/c flonum? integer?)", 0, argc, argv); + if (!SCHEME_DBLP(argv[0])) + scheme_wrong_contract("fl->fx", "flonum?", 0, argc, argv); d = SCHEME_DBL_VAL(argv[0]); - if (double_fits_fixnum(d)) { - v = (intptr_t)d; - if ((double)v == d) { - o = scheme_make_integer_value(v); - if (SCHEME_INTP(o)) - return o; - } + if ((d < scheme_double_too_positive_for_fixnum) + && (d > scheme_double_too_negative_for_fixnum)) { + intptr_t v = (intptr_t)d; + return scheme_make_integer(v); } scheme_contract_error("fl->fx", "no fixnum representation", @@ -5383,20 +5360,18 @@ static Scheme_Object *extfl_to_fx (int argc, Scheme_Object *argv[]) { #ifdef MZ_LONG_DOUBLE long_double d; - intptr_t v; - Scheme_Object *o; WHEN_LONG_DOUBLE_UNSUPPORTED(unsupported("extfl->fx")); if (!SCHEME_LONG_DBLP(argv[0])) - scheme_wrong_contract("extfl->fx", "(and/c extflonum?)", 0, argc, argv); + scheme_wrong_contract("extfl->fx", "extflonum?", 0, argc, argv); d = SCHEME_LONG_DBL_VAL(argv[0]); - v = (intptr_t)int_from_long_double(d); - if (long_double_eqv_i(v, d)) { - o = scheme_make_integer_value(v); - if (SCHEME_INTP(o)) - return o; + if (long_double_less(d, scheme_extfl_too_positive_for_fixnum) + && long_double_greater(d, scheme_extfl_too_negative_for_fixnum)) { + intptr_t v; + v = int_from_long_double(d); + return scheme_make_integer(v); } scheme_contract_error("extfl->fx", "no fixnum representation", @@ -5525,7 +5500,7 @@ static Scheme_Object *unsafe_fx_to_fl (int argc, Scheme_Object *argv[]) static Scheme_Object *unsafe_fl_to_fx (int argc, Scheme_Object *argv[]) { intptr_t v; - if (scheme_current_thread->constant_folding) return scheme_inexact_to_exact(argc, argv); + if (scheme_current_thread->constant_folding) return fl_to_fx(argc, argv); v = (intptr_t)(SCHEME_DBL_VAL(argv[0])); return scheme_make_integer(v); } @@ -5589,7 +5564,7 @@ static Scheme_Object *unsafe_extfl_to_fx (int argc, Scheme_Object *argv[]) { #ifdef MZ_LONG_DOUBLE intptr_t v; - if (scheme_current_thread->constant_folding) return extfl_to_exact(argc, argv); + if (scheme_current_thread->constant_folding) return extfl_to_fx(argc, argv); v = (intptr_t)int_from_long_double(SCHEME_LONG_DBL_VAL(argv[0])); return scheme_make_integer(v); #else diff --git a/racket/src/racket/src/numstr.c b/racket/src/racket/src/numstr.c index c5ad62e1e2..bf174e0df1 100644 --- a/racket/src/racket/src/numstr.c +++ b/racket/src/racket/src/numstr.c @@ -39,6 +39,8 @@ static Scheme_Object *sch_check_pack(int argc, Scheme_Object *argv[]); static char *number_to_allocated_string(int radix, Scheme_Object *obj, int alloc); +static void init_double_fixnum_extremes(void); + READ_ONLY static char *infinity_str = "+inf.0"; READ_ONLY static char *minus_infinity_str = "-inf.0"; READ_ONLY static char *not_a_number_str = "+nan.0"; @@ -61,6 +63,11 @@ READ_ONLY static char *single_other_not_a_number_str = "-nan.f"; SHARED_OK static Scheme_Object *num_limits[3]; #endif +READ_ONLY double scheme_double_too_positive_for_fixnum, scheme_double_too_negative_for_fixnum; +#ifdef MZ_LONG_DOUBLE +READ_ONLY long_double scheme_extfl_too_positive_for_fixnum, scheme_extfl_too_negative_for_fixnum; +#endif + #ifdef SCHEME_BIG_ENDIAN # define MZ_IS_BIG_ENDIAN 1 #else @@ -190,6 +197,8 @@ void scheme_init_numstr(Scheme_Startup_Env *env) num_limits[MZ_S8LO] = v; } #endif + + init_double_fixnum_extremes(); } void scheme_init_extfl_numstr(Scheme_Startup_Env *env) @@ -3008,3 +3017,46 @@ static Scheme_Object *pseudo_random_generator_p(int argc, Scheme_Object **argv) : scheme_false); } +/* Just to make sure there are no C compiler number issues, we + record floting-point values just outside of the fixnum + range as little-endian byte sequences: */ + +#ifdef SIXTY_FOUR_BIT_INTEGERS + +#if MZ_IS_BIG_ENDIAN +# define double_too_positive_for_fixnum_bytes "C\320\0\0\0\0\0\0" /* 4.611686018427388e+18 */ +# define double_too_negative_for_fixnum_bytes "\303\320\0\0\0\0\0\1" /* -4.611686018427389e+18 */ +#else +# define double_too_positive_for_fixnum_bytes "\0\0\0\0\0\0\320C" /* 4.611686018427388e+18 */ +# define double_too_negative_for_fixnum_bytes "\1\0\0\0\0\0\320\303" /* -4.611686018427389e+18 */ +#endif + +/* always little-endian: */ +#define extfl_too_positive_for_fixnum_bytes "\0\0\0\0\0\0\0\200=@" /* 4611686018427387904.0t0 */ +#define extfl_too_negative_for_fixnum_bytes "\2\0\0\0\0\0\0\200=\300" /* -4611686018427387905.0t0 */ + +#else + +#if MZ_IS_BIG_ENDIAN +# define double_too_positive_for_fixnum_bytes "A\320\0\0\0\0\0\0" /* 1073741824.0 */ +# define double_too_negative_for_fixnum_bytes "\301\320\0\0\0@\0\0" /* -1073741825.0 */ +#else +# define double_too_positive_for_fixnum_bytes "\0\0\0\0\0\0\320A" /* 1073741824.0 */ +# define double_too_negative_for_fixnum_bytes "\0\0@\0\0\0\320\301" /* -1073741825.0 */ +#endif + +/* always little-endian: */ +#define extfl_too_positive_for_fixnum_bytes "\0\0\0\0\0\0\0\200\35@" /* 1073741824.0 */ +#define extfl_too_negative_for_fixnum_bytes "\0\0\0\0\2\0\0\200\35\300" /* -1073741825.0 */ + +#endif + +static void init_double_fixnum_extremes(void) +{ + memcpy(&scheme_double_too_positive_for_fixnum, double_too_positive_for_fixnum_bytes, sizeof(double)); + memcpy(&scheme_double_too_negative_for_fixnum, double_too_negative_for_fixnum_bytes, sizeof(double)); +#ifdef MZ_LONG_DOUBLE + memcpy(&scheme_extfl_too_positive_for_fixnum, extfl_too_positive_for_fixnum_bytes, 10); + memcpy(&scheme_extfl_too_negative_for_fixnum, extfl_too_negative_for_fixnum_bytes, 10); +#endif +} diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index 679edfd309..a1dac95679 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -2155,6 +2155,11 @@ intptr_t scheme_get_semaphore_init(const char *who, int n, Scheme_Object **p); void scheme_configure_floating_point(void); +extern double scheme_double_too_positive_for_fixnum, scheme_double_too_negative_for_fixnum; +#ifdef MZ_LONG_DOUBLE +extern long_double scheme_extfl_too_positive_for_fixnum, scheme_extfl_too_negative_for_fixnum; +#endif + /****** Bignums *******/ #ifdef USE_LONG_LONG_FOR_BIGDIG diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index cf9aadaaee..7fda5da519 100644 --- a/racket/src/racket/src/schvers.h +++ b/racket/src/racket/src/schvers.h @@ -16,7 +16,7 @@ #define MZSCHEME_VERSION_X 7 #define MZSCHEME_VERSION_Y 7 #define MZSCHEME_VERSION_Z 0 -#define MZSCHEME_VERSION_W 7 +#define MZSCHEME_VERSION_W 8 /* A level of indirection makes `#` work as needed: */ #define AS_a_STR_HELPER(x) #x