diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index f7b5ab87ec..2a38b56752 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -5528,34 +5528,27 @@ Scheme_Object *_scheme_apply_prim_closure(Scheme_Object *rator, #ifdef MZ_USE_JIT -Scheme_Object *_scheme_apply_from_native(Scheme_Object *rator, - int argc, - Scheme_Object **argv) -{ -#define PRIM_CHECK_VALUE 1 -#define PRIM_CHECK_MULTI 1 -#include "schnapp.inc" -} -Scheme_Object *_scheme_apply_multi_from_native(Scheme_Object *rator, - int argc, - Scheme_Object **argv) -{ -#define PRIM_CHECK_VALUE 1 -#define PRIM_CHECK_MULTI 0 -#include "schnapp.inc" -} +# define PRIM_APPLY_NAME _scheme_apply_from_native +# define PRIM_APPLY_NAME_FAST _scheme_apply_from_native_fast +# define PRIM_CHECK_VALUE 1 +# define PRIM_CHECK_MULTI 1 +# include "schnapp.inc" + +# define PRIM_APPLY_NAME _scheme_apply_multi_from_native +# define PRIM_APPLY_NAME_FAST _scheme_apply_multi_from_native_fast +# define PRIM_CHECK_VALUE 1 +# define PRIM_CHECK_MULTI 0 +# include "schnapp.inc" + +# define PRIM_APPLY_NAME _scheme_tail_apply_from_native +# define PRIM_APPLY_NAME_FAST _scheme_tail_apply_from_native_fast +/* It's ok to call primitive and closed primitives directly, + since they implement further tail by trampolining. */ +# define PRIM_CHECK_VALUE 0 +# define PRIM_CHECK_MULTI 0 +# include "schnapp.inc" -Scheme_Object *_scheme_tail_apply_from_native(Scheme_Object *rator, - int argc, - Scheme_Object **argv) -{ - /* It's ok to call primitive and closed primitives directly, - since they implement further tail by trampolining. */ -#define PRIM_CHECK_VALUE 0 -#define PRIM_CHECK_MULTI 0 -#include "schnapp.inc" -} #endif Scheme_Object *scheme_check_one_value(Scheme_Object *v) diff --git a/src/mzscheme/src/numarith.c b/src/mzscheme/src/numarith.c index 1c25d60ba9..078e384f7f 100644 --- a/src/mzscheme/src/numarith.c +++ b/src/mzscheme/src/numarith.c @@ -175,6 +175,13 @@ scheme_sub1 (int argc, Scheme_Object *argv[]) #define FS_MULTIPLY(x,y) scheme_make_float(x * y) #define FS_DIVIDE(x,y) scheme_make_float((float)x / (float)y) +static Scheme_Object *ADD_slow(long a, long b) +{ + Small_Bignum sa, sb; + return scheme_bignum_add(scheme_make_small_bignum(a, &sa), + scheme_make_small_bignum(b, &sb)); +} + static Scheme_Object *ADD(long a, long b) { long r; @@ -187,11 +194,15 @@ static Scheme_Object *ADD(long a, long b) if (b == r - a) return o; - else { - Small_Bignum sa, sb; - return scheme_bignum_add(scheme_make_small_bignum(a, &sa), - scheme_make_small_bignum(b, &sb)); - } + else + return ADD_slow(a, b); +} + +static Scheme_Object *SUBTRACT_slow(long a, long b) +{ + Small_Bignum sa, sb; + return scheme_bignum_subtract(scheme_make_small_bignum(a, &sa), + scheme_make_small_bignum(b, &sb)); } static Scheme_Object *SUBTRACT(long a, long b) @@ -206,11 +217,8 @@ static Scheme_Object *SUBTRACT(long a, long b) if (a == r + b) return o; - else { - Small_Bignum sa, sb; - return scheme_bignum_subtract(scheme_make_small_bignum(a, &sa), - scheme_make_small_bignum(b, &sb)); - } + else + return SUBTRACT_slow(a, b); } static Scheme_Object *MULTIPLY(long a, long b) @@ -235,6 +243,13 @@ static Scheme_Object *MULTIPLY(long a, long b) } } +static Scheme_Object *unary_minus(const Scheme_Object *n) +{ + Scheme_Object *a[1]; + a[0] = (Scheme_Object *)n; + return minus(1, a); +} + GEN_BIN_OP(scheme_bin_plus, "+", ADD, F_ADD, FS_ADD, scheme_bignum_add, scheme_rational_add, scheme_complex_add, GEN_RETURN_N2, GEN_RETURN_N1, NO_NAN_CHECK, NO_NAN_CHECK) GEN_BIN_OP(scheme_bin_minus, "-", SUBTRACT, F_SUBTRACT, FS_SUBTRACT, scheme_bignum_subtract, scheme_rational_subtract, scheme_complex_subtract, GEN_SINGLE_SUBTRACT_N2, GEN_RETURN_N1, NO_NAN_CHECK, NO_NAN_CHECK) GEN_BIN_OP(scheme_bin_mult, "*", MULTIPLY, F_MULTIPLY, FS_MULTIPLY, scheme_bignum_multiply, scheme_rational_multiply, scheme_complex_multiply, GEN_RETURN_0, GEN_RETURN_0, NO_NAN_CHECK, NO_NAN_CHECK) @@ -243,11 +258,25 @@ GEN_BIN_DIV_OP(scheme_bin_div, "/", DIVIDE, F_DIVIDE, FS_DIVIDE, scheme_make_rat GEN_NARY_OP(static, plus, "+", scheme_bin_plus, 0, SCHEME_NUMBERP, "number") GEN_NARY_OP(static, mult, "*", scheme_bin_mult, 1, SCHEME_NUMBERP, "number") +static MZ_INLINE Scheme_Object * +minus_slow (Scheme_Object *ret, int argc, Scheme_Object *argv[]) +{ + int i; + for (i = 1; i < argc; i++) { + Scheme_Object *o = argv[i]; + if (!SCHEME_NUMBERP(o)) { + scheme_wrong_type("-", "number", i, argc, argv); + ESCAPED_BEFORE_HERE; + } + ret = scheme_bin_minus(ret, o); + } + return ret; +} + static Scheme_Object * minus (int argc, Scheme_Object *argv[]) { - Scheme_Object *ret; - int i; + Scheme_Object *ret, *v; ret = argv[0]; if (!SCHEME_NUMBERP(ret)) { @@ -264,15 +293,15 @@ minus (int argc, Scheme_Object *argv[]) } return scheme_bin_minus(zeroi, ret); } - for (i = 1; i < argc; i++) { - Scheme_Object *o = argv[i]; - if (!SCHEME_NUMBERP(o)) { - scheme_wrong_type("-", "number", i, argc, argv); + if (argc == 2) { + v = argv[1]; + if (!SCHEME_NUMBERP(v)) { + scheme_wrong_type("-", "number", 1, argc, argv); ESCAPED_BEFORE_HERE; - } - ret = scheme_bin_minus(ret, o); + } + return scheme_bin_minus(ret, v); } - return ret; + return minus_slow(ret, argc, argv); } static Scheme_Object * diff --git a/src/mzscheme/src/nummacs.h b/src/mzscheme/src/nummacs.h index c87def637b..cbf3d90e36 100644 --- a/src/mzscheme/src/nummacs.h +++ b/src/mzscheme/src/nummacs.h @@ -51,16 +51,14 @@ static int name (Scheme_Object *n1, Scheme_Object *n2) #define GEN_NARY_COMP(name, scheme_name, bin_name, TYPEP, type) \ -static Scheme_Object * \ -name (int argc, Scheme_Object *argv[]) \ +static Scheme_Object *name (int argc, Scheme_Object *argv[]); \ +static MZ_INLINE Scheme_Object * \ +name ## __slow (Scheme_Object *p, int argc, Scheme_Object *argv[]) \ { \ + Scheme_Object *o; \ int i; \ - Scheme_Object *p; \ - p = argv[0]; \ - if (argc == 1) if (!TYPEP(p)) \ - scheme_wrong_type(scheme_name, type, 0, argc, argv); \ for (i = 1; i < argc; i++) {\ - Scheme_Object *o = argv[i]; \ + o = argv[i]; \ if (!TYPEP(o)) { \ scheme_wrong_type(scheme_name, type, i, argc, argv); \ return NULL; \ @@ -75,6 +73,24 @@ name (int argc, Scheme_Object *argv[]) \ p = o; \ } \ return scheme_true; \ +} \ +static MZ_INLINE Scheme_Object *name ## __bin(Scheme_Object *a, Scheme_Object *b) { \ + return (bin_name(a, b) ? scheme_true : scheme_false); \ +} \ +Scheme_Object * \ +name (int argc, Scheme_Object *argv[]) \ +{ \ + Scheme_Object *p, *p2; \ + p = argv[0]; \ + if (!TYPEP(p)) \ + scheme_wrong_type(scheme_name, type, 0, argc, argv); \ + if (argc == 2) { \ + p2 = argv[1]; \ + if (!TYPEP(p2)) \ + scheme_wrong_type(scheme_name, type, 1, argc, argv); \ + return name ## __bin(p, p2); \ + } else \ + return name ## __slow(p, argc, argv); \ } #define GEN_BIN_PROT(name) \ @@ -166,6 +182,10 @@ static MZ_INLINE rettype name ## __dbl_comp(double d1, const Scheme_Object *n1, return cxop((scheme_make_small_complex(n1, &sc)), \ (n2)); \ }) \ +static MZ_INLINE rettype name ## __big_int(const Scheme_Object *n1, const Scheme_Object *n2) { \ + Small_Bignum sb; \ + return bn_op((n1), (scheme_make_small_bignum(SCHEME_INT_VAL(n2), &sb))); \ +} \ FLOATWRAP( \ static MZ_INLINE rettype name ## __big_flt(double d1, const Scheme_Object *n1, const Scheme_Object *n2) { \ Small_Rational sr6; \ @@ -369,9 +389,7 @@ name (const Scheme_Object *n1, const Scheme_Object *n2) \ else if (t1 == scheme_bignum_type) \ { \ if (SCHEME_INTP(n2)) { \ - Small_Bignum sb; \ - return bn_op((n1), \ - (scheme_make_small_bignum(SCHEME_INT_VAL(n2), &sb))); \ + return name ## __big_int(n1, n2); \ } \ t2 = _SCHEME_TYPE(n2); \ FLOATWRAP( \ @@ -466,7 +484,7 @@ name (const Scheme_Object *n1, const Scheme_Object *n2) \ #define GEN_RETURN_1(x) x return scheme_make_integer(1); #define GEN_RETURN_N1(x) x return (Scheme_Object *)n1; #define GEN_RETURN_N2(x) x return (Scheme_Object *)n2; -#define GEN_SINGLE_SUBTRACT_N2(x) x if SCHEME_FLOATP(n2) return minus(1, (Scheme_Object **)&n2); +#define GEN_SINGLE_SUBTRACT_N2(x) x if SCHEME_FLOATP(n2) return unary_minus(n2); #define GEN_SAME_INF(x) (scheme_is_positive(x) ? scheme_inf_object : scheme_minus_inf_object) #define GEN_OPP_INF(x) (!scheme_is_positive(x) ? scheme_inf_object : scheme_minus_inf_object) @@ -563,11 +581,23 @@ name (const Scheme_Object *n1, const Scheme_Object *n2) \ } #define GEN_NARY_OP(stat, name, scheme_name, bin_name, ident, TYPEP, type) \ -stat Scheme_Object * \ +stat Scheme_Object *name (int argc, Scheme_Object *argv[]); \ +static MZ_INLINE Scheme_Object * \ +name ## __slow (Scheme_Object *ret, int argc, Scheme_Object *argv[]) \ +{ \ + int i; \ + for (i = 1 ; imina || (argc > prim->mu.maxa && prim->mina >= 0)) { + scheme_wrong_count(prim->name, prim->mina, prim->mu.maxa, argc, argv); + return NULL; /* Shouldn't get here */ + } + + f = (Scheme_Primitive_Closure_Proc *)prim->prim_val; + v = f(argc, argv, (Scheme_Object *)prim); + +#if PRIM_CHECK_VALUE + if (v == SCHEME_TAIL_CALL_WAITING) + v = scheme_force_value_same_mark(v); +#endif + +#if PRIM_CHECK_MULTI + if (v == SCHEME_MULTIPLE_VALUES) { + scheme_wrong_return_arity(NULL, 1, scheme_multiple_count, scheme_multiple_array, NULL); + return NULL; /* Shouldn't get here */ + } +#endif + + return v; +} + +Scheme_Object *PRIM_APPLY_NAME(Scheme_Object *rator, + int argc, + Scheme_Object **argv) +{ if (!SCHEME_INTP(rator)) { Scheme_Type t; t = _SCHEME_TYPE(rator); if (t == scheme_prim_type) { - GC_CAN_IGNORE Scheme_Object *v; - GC_CAN_IGNORE Scheme_Primitive_Proc *prim; - GC_CAN_IGNORE Scheme_Primitive_Closure_Proc *f; - - prim = (Scheme_Primitive_Proc *)rator; - - if (argc < prim->mina || (argc > prim->mu.maxa && prim->mina >= 0)) { - scheme_wrong_count(prim->name, prim->mina, prim->mu.maxa, argc, argv); - return NULL; /* Shouldn't get here */ - } - - f = (Scheme_Primitive_Closure_Proc *)prim->prim_val; - v = f(argc, argv, (Scheme_Object *)prim); - -#if PRIM_CHECK_VALUE - if (v == SCHEME_TAIL_CALL_WAITING) - v = scheme_force_value_same_mark(v); -#endif - -#if PRIM_CHECK_MULTI - if (v == SCHEME_MULTIPLE_VALUES) { - scheme_wrong_return_arity(NULL, 1, scheme_multiple_count, scheme_multiple_array, NULL); - return NULL; /* Shouldn't get here */ - } -#endif - - return v; + return PRIM_APPLY_NAME_FAST(rator, argc, argv); } } @@ -60,6 +74,9 @@ return _scheme_tail_apply(rator, argc, argv); # endif #endif +} #undef PRIM_CHECK_VALUE #undef PRIM_CHECK_MULTI +#undef PRIM_APPLY_NAME +#undef PRIM_APPLY_NAME_FAST