diff --git a/collects/tests/mzscheme/unsafe.ss b/collects/tests/mzscheme/unsafe.ss index c404722667..7304c90968 100644 --- a/collects/tests/mzscheme/unsafe.ss +++ b/collects/tests/mzscheme/unsafe.ss @@ -187,18 +187,13 @@ #:post (lambda (x) (list x (string-ref v 2))) #:literal-ok? #f)) - (let ([flvector (lambda args - (let ([v (make-flvector (length args))]) - (for ([a args] - [i (in-naturals)]) - (flvector-set! v i a)) - v))]) - (test-bin 9.5 'unsafe-flvector-ref (flvector 1.0 9.5 18.7) 1) - (let ([v (flvector 1.0 9.5 18.7)]) - (test-tri (list (void) 27.4) 'unsafe-flvector-set! v 2 27.4 - #:pre (lambda () (flvector-set! v 2 0.0)) - #:post (lambda (x) (list x (flvector-ref v 2))) - #:literal-ok? #f))) + (test-bin 9.5 'unsafe-flvector-ref (flvector 1.0 9.5 18.7) 1) + (test-un 5 'unsafe-flvector-length (flvector 1.1 2.0 3.1 4.5 5.7)) + (let ([v (flvector 1.0 9.5 18.7)]) + (test-tri (list (void) 27.4) 'unsafe-flvector-set! v 2 27.4 + #:pre (lambda () (flvector-set! v 2 0.0)) + #:post (lambda (x) (list x (flvector-ref v 2))) + #:literal-ok? #f)) (test-bin 9.5 'unsafe-f64vector-ref (f64vector 1.0 9.5 18.7) 1) (let ([v (f64vector 1.0 9.5 18.7)]) diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index 3eb280393e..a845e2b62b 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -143,6 +143,7 @@ static void *bad_mcar_code, *bad_mcdr_code; static void *bad_set_mcar_code, *bad_set_mcdr_code; static void *bad_unbox_code; static void *bad_vector_length_code; +static void *bad_flvector_length_code; static void *vector_ref_code, *vector_ref_check_index_code, *vector_set_code, *vector_set_check_index_code; static void *string_ref_code, *string_ref_check_index_code, *string_set_code, *string_set_check_index_code; static void *bytes_ref_code, *bytes_ref_check_index_code, *bytes_set_code, *bytes_set_check_index_code; @@ -5516,8 +5517,21 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in return 1; } else if (IS_NAMED_PRIM(rator, "vector-length") - || IS_NAMED_PRIM(rator, "unsafe-vector-length")) { + || IS_NAMED_PRIM(rator, "unsafe-vector-length") + || IS_NAMED_PRIM(rator, "flvector-length") + || IS_NAMED_PRIM(rator, "unsafe-flvector-length")) { GC_CAN_IGNORE jit_insn *reffail, *ref; + int unsafe = 0, for_fl = 0; + + if (IS_NAMED_PRIM(rator, "unsafe-vector-length")) { + unsafe = 1; + } else if (IS_NAMED_PRIM(rator, "flvector-length")) { + for_fl = 1; + } else if (IS_NAMED_PRIM(rator, "unsafe-flvector-length")) { + unsafe = 1; + for_fl = 1; + } + LOG_IT(("inlined vector-length\n")); @@ -5528,7 +5542,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in mz_runstack_unskipped(jitter, 1); - if (!IS_NAMED_PRIM(rator, "unsafe-vector-length")) { + if (!unsafe) { mz_rs_sync_fail_branch(); __START_TINY_JUMPS__(1); @@ -5536,16 +5550,25 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in __END_TINY_JUMPS__(1); reffail = _jit.x.pc; - (void)jit_calli(bad_vector_length_code); + if (!for_fl) + (void)jit_calli(bad_vector_length_code); + else + (void)jit_calli(bad_flvector_length_code); __START_TINY_JUMPS__(1); mz_patch_branch(ref); jit_ldxi_s(JIT_R1, JIT_R0, &((Scheme_Object *)0x0)->type); - (void)jit_bnei_i(reffail, JIT_R1, scheme_vector_type); + if (!for_fl) + (void)jit_bnei_i(reffail, JIT_R1, scheme_vector_type); + else + (void)jit_bnei_i(reffail, JIT_R1, scheme_flvector_type); __END_TINY_JUMPS__(1); } - (void)jit_ldxi_i(JIT_R0, JIT_R0, &SCHEME_VEC_SIZE(0x0)); + if (!for_fl) + (void)jit_ldxi_i(JIT_R0, JIT_R0, &SCHEME_VEC_SIZE(0x0)); + else + (void)jit_ldxi_l(JIT_R0, JIT_R0, &SCHEME_FLVEC_SIZE(0x0)); jit_lshi_l(JIT_R0, JIT_R0, 1); jit_ori_l(JIT_R0, JIT_R0, 0x1); @@ -8735,6 +8758,16 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) CHECK_LIMIT(); register_sub_func(jitter, bad_vector_length_code, scheme_false); + /* *** bad_flvector_length_code *** */ + /* R0 is argument */ + bad_flvector_length_code = jit_get_ip().ptr; + mz_prolog(JIT_R1); + jit_prepare(1); + jit_pusharg_i(JIT_R0); + (void)mz_finish(ts_scheme_flvector_length); + CHECK_LIMIT(); + register_sub_func(jitter, bad_flvector_length_code, scheme_false); + /* *** call_original_unary_arith_code *** */ /* R0 is arg, R2 is code pointer, V1 is return address */ for (i = 0; i < 3; i++) { diff --git a/src/mzscheme/src/jit_ts.c b/src/mzscheme/src/jit_ts.c index 819c2ad0cf..640e456944 100644 --- a/src/mzscheme/src/jit_ts.c +++ b/src/mzscheme/src/jit_ts.c @@ -60,6 +60,7 @@ define_ts_iS_s(scheme_checked_set_mcar, FSRC_OTHER) define_ts_iS_s(scheme_checked_set_mcdr, FSRC_OTHER) define_ts_s_s(scheme_unbox, FSRC_OTHER) define_ts_s_s(scheme_vector_length, FSRC_OTHER) +define_ts_s_s(scheme_flvector_length, FSRC_OTHER) define_ts_s_s(tail_call_with_values_from_multiple_result, FSRC_OTHER) define_ts_s_v(raise_bad_call_with_values, FSRC_OTHER) define_ts_s_s(call_with_values_from_multiple_result_multi, FSRC_OTHER) @@ -122,6 +123,7 @@ define_ts_siS_v(wrong_argument_count, FSRC_OTHER) # define ts_scheme_checked_set_mcdr scheme_checked_set_mcdr # define ts_scheme_unbox scheme_unbox # define ts_scheme_vector_length scheme_vector_length +# define ts_scheme_flvector_length scheme_flvector_length # define ts_tail_call_with_values_from_multiple_result tail_call_with_values_from_multiple_result # define ts_raise_bad_call_with_values raise_bad_call_with_values # define ts_call_with_values_from_multiple_result_multi call_with_values_from_multiple_result_multi diff --git a/src/mzscheme/src/number.c b/src/mzscheme/src/number.c index fd4b97f4db..5e5f6171f4 100644 --- a/src/mzscheme/src/number.c +++ b/src/mzscheme/src/number.c @@ -100,8 +100,8 @@ static Scheme_Object *int_sqrt_rem (int argc, Scheme_Object *argv[]); static Scheme_Object *flvector (int argc, Scheme_Object *argv[]); static Scheme_Object *flvector_p (int argc, Scheme_Object *argv[]); -static Scheme_Object *make_flvector (int argc, Scheme_Object *argv[]); static Scheme_Object *flvector_length (int argc, Scheme_Object *argv[]); +static Scheme_Object *make_flvector (int argc, Scheme_Object *argv[]); static Scheme_Object *fx_and (int argc, Scheme_Object *argv[]); static Scheme_Object *fx_or (int argc, Scheme_Object *argv[]); @@ -521,11 +521,11 @@ scheme_init_number (Scheme_Env *env) "make-flvector", 1, 2), env); - scheme_add_global_constant("flvector-length", - scheme_make_immed_prim(flvector_length, - "flvector-length", - 1, 1), - env); + + p = scheme_make_immed_prim(flvector_length, "flvector-length", 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; + scheme_add_global_constant("flvector-length", p, env); + p = scheme_make_immed_prim(scheme_checked_flvector_ref, "flvector-ref", 2, 2); @@ -587,7 +587,7 @@ void scheme_init_unsafe_number(Scheme_Env *env) p = scheme_make_immed_prim(unsafe_flvector_length, "unsafe-flvector-length", 1, 1); - /* SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; */ + SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; scheme_add_global_constant("unsafe-flvector-length", p, env); p = scheme_make_immed_prim(unsafe_flvector_ref, "unsafe-flvector-ref", @@ -2929,12 +2929,17 @@ static Scheme_Object *make_flvector (int argc, Scheme_Object *argv[]) return (Scheme_Object *)vec; } +Scheme_Object *scheme_flvector_length(Scheme_Object *vec) +{ + if (!SCHEME_FLVECTORP(vec)) + scheme_wrong_type("flvector-length", "flvector", 0, 1, &vec); + + return scheme_make_integer(SCHEME_FLVEC_SIZE(vec)); +} + static Scheme_Object *flvector_length (int argc, Scheme_Object *argv[]) { - if (!SCHEME_FLVECTORP(argv[0])) - scheme_wrong_type("flvector-length", "flvector", 0, argc, argv); - - return scheme_make_integer(SCHEME_FLVEC_SIZE(argv[0])); + return scheme_flvector_length(argv[0]); } Scheme_Object *scheme_checked_flvector_ref (int argc, Scheme_Object *argv[]) diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 1ca42a86e3..c8fb71f3ac 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -3194,6 +3194,7 @@ Scheme_Object *scheme_checked_syntax_e(int argc, Scheme_Object **argv); Scheme_Object *scheme_vector_length(Scheme_Object *v); Scheme_Object *scheme_checked_flvector_ref(int argc, Scheme_Object **argv); Scheme_Object *scheme_checked_flvector_set(int argc, Scheme_Object **argv); +Scheme_Object *scheme_flvector_length(Scheme_Object *v); void scheme_bad_vec_index(char *name, Scheme_Object *i, const char *what, Scheme_Object *vec,