diff --git a/pkgs/racket-test-core/tests/racket/chaperone.rktl b/pkgs/racket-test-core/tests/racket/chaperone.rktl index bc48c2d1d4..3973f417c6 100644 --- a/pkgs/racket-test-core/tests/racket/chaperone.rktl +++ b/pkgs/racket-test-core/tests/racket/chaperone.rktl @@ -2380,6 +2380,12 @@ (struct s (f) #:property prop:procedure 0) (test #t s? (unsafe-chaperone-procedure (s add1) (λ (x) x))))) +;; Check name in arity error message: +(let () + (define (pf x) x) + (define cf (unsafe-chaperone-procedure pf (lambda (x) x))) + (err/rt-test (cf) (λ (x) (regexp-match #rx"^pf:" (exn-message x))))) + ;; ---------------------------------------- (let () diff --git a/racket/src/racket/src/fun.c b/racket/src/racket/src/fun.c index 38ee0f09c1..5df7ce4863 100644 --- a/racket/src/racket/src/fun.c +++ b/racket/src/racket/src/fun.c @@ -3604,15 +3604,9 @@ static Scheme_Object *do_chaperone_procedure(const char *name, const char *whati A size of 5 (instead of 3) indicates that the wrapper procedure accepts a "self" argument - If the known-good arity is a boolean, this means the chaperone - wrapper defers directly to SCHEME_VEC_ELES(r)[0], instead of - following the actual chaperone procedure. - - If the boolean is #f, that means the interposition proc was #f - originally and SCHEME_VEC_ELES(r)[0] is the original procedure. - - If the boolean is #t, that means that this chaperone was created - via unsafe-{chaperone,impersonate}-procedure. + If the known-good arity is #f, this means the chaperone + wrapper defers directly to SCHEME_VEC_ELES(r)[0] and no + arity check is needed. */ r = scheme_make_vector((pass_self ? 5 : 3), scheme_make_integer(-1)); @@ -3620,8 +3614,6 @@ static Scheme_Object *do_chaperone_procedure(const char *name, const char *whati SCHEME_VEC_ELS(r)[0] = argv[0]; else SCHEME_VEC_ELS(r)[0] = argv[1]; - if (is_unsafe) - SCHEME_VEC_ELS(r)[1] = scheme_true; if (SCHEME_FALSEP(argv[1])) SCHEME_VEC_ELS(r)[1] = scheme_false; SCHEME_VEC_ELS(r)[2] = app_mark; @@ -3630,6 +3622,8 @@ static Scheme_Object *do_chaperone_procedure(const char *name, const char *whati if (is_impersonator) SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR; + if (is_unsafe || SCHEME_FALSEP(argv[1])) + SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_PROC_CHAPERONE_CALL_DIRECT; return (Scheme_Object *)px; } @@ -3869,7 +3863,25 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object self_proc = o; } - if (SCHEME_BOOLP(SCHEME_VEC_ELS(px->redirects)[1])) { + /* Ensure that the original procedure accepts `argc' arguments: */ + if (!SCHEME_FALSEP(SCHEME_VEC_ELS(px->redirects)[1]) /* check not needed for props-only mode */ + && (argc != SCHEME_INT_VAL(SCHEME_VEC_ELS(px->redirects)[1]))) { + a[0] = px->prev; + if (!scheme_check_proc_arity(NULL, argc, 0, 0, a)) { + /* Apply the original procedure, in case the chaperone would accept + `argc' arguments (in addition to the original procedure's arity) + in case the methodness of the original procedure is different + from the chaperone, or in case the procedures have different names. */ + (void)_scheme_apply_multi(px->prev, argc, argv); + scheme_signal_error("internal error: unexpected success applying chaperoned/proxied procedure"); + return NULL; + } + /* record that argc is ok, on the grounds that the function is likely + to be applied to argc arguments again */ + SCHEME_VEC_ELS(px->redirects)[1] = scheme_make_integer(argc); + } + + if (SCHEME_CHAPERONE_FLAGS(px) & SCHEME_PROC_CHAPERONE_CALL_DIRECT) { simple_call = SCHEME_VEC_ELS(px->redirects)[0]; /* no redirection procedure */ if (SCHEME_CHAPERONEP(simple_call)) { @@ -3907,23 +3919,6 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object } } - /* Ensure that the original procedure accepts `argc' arguments: */ - if (argc != SCHEME_INT_VAL(SCHEME_VEC_ELS(px->redirects)[1])) { - a[0] = px->prev; - if (!scheme_check_proc_arity(NULL, argc, 0, 0, a)) { - /* Apply the original procedure, in case the chaperone would accept - `argc' arguments (in addition to the original procedure's arity) - in case the methodness of the original procedure is different - from the chaperone, or in case the procedures have different names. */ - (void)_scheme_apply_multi(px->prev, argc, argv); - scheme_signal_error("internal error: unexpected success applying chaperoned/proxied procedure"); - return NULL; - } - /* record that argc is ok, on the grounds that the function is likely - to be applied to argc arguments again */ - SCHEME_VEC_ELS(px->redirects)[1] = scheme_make_integer(argc); - } - app_mark = SCHEME_VEC_ELS(px->redirects)[2]; if (SCHEME_FALSEP(app_mark)) app_mark = NULL; diff --git a/racket/src/racket/src/jitcall.c b/racket/src/racket/src/jitcall.c index 1d51cc9790..a6b3df4b7c 100644 --- a/racket/src/racket/src/jitcall.c +++ b/racket/src/racket/src/jitcall.c @@ -65,13 +65,24 @@ static Scheme_Object *clear_runstack(Scheme_Object **rs, intptr_t amt, Scheme_Ob static jit_insn *generate_proc_struct_retry(mz_jit_state *jitter, int num_rands, GC_CAN_IGNORE jit_insn *refagain) { - GC_CAN_IGNORE jit_insn *ref2, *refz1, *refz2, *refz3, *refz4, *refz5; - GC_CAN_IGNORE jit_insn *refz6, *refz7, *refz8; + GC_CAN_IGNORE jit_insn *ref2, *ref3, *refz1, *refz2, *refz3, *refz4, *refz5; + GC_CAN_IGNORE jit_insn *refz6, *refz7, *refz8, *refz9, *ref9; ref2 = jit_bnei_i(jit_forward(), JIT_R1, scheme_proc_struct_type); + + /* This is an applicable struct. But if it's for reducing arity, + then we can't just apply the struct's procedure. */ jit_ldxi_p(JIT_R1, JIT_V1, &((Scheme_Structure *)0x0)->stype); jit_ldi_p(JIT_R2, &scheme_reduced_procedure_struct); - refz3 = jit_beqr_p(jit_forward(), JIT_R1, JIT_R2); + ref3 = jit_bner_p(jit_forward(), JIT_R1, JIT_R2); + + /* Matches reduced arity in a simple way? */ + jit_ldxi_p(JIT_R2, JIT_V1, &((Scheme_Structure *)0x0)->slots[1]); + refz3 = jit_bnei_p(jit_forward(), JIT_R2, scheme_make_integer(num_rands)); + + mz_patch_branch(ref3); + /* It's an applicable struct that is not an arity reduce or the + arity matches. We can extract the procedure if it's in a field: */ jit_ldxi_p(JIT_R1, JIT_R1, &((Scheme_Struct_Type *)0x0)->proc_attr); refz1 = jit_bmci_i(jit_forward(), JIT_R1, 0x1); CHECK_LIMIT(); @@ -81,6 +92,7 @@ static jit_insn *generate_proc_struct_retry(mz_jit_state *jitter, int num_rands, jit_lshi_ul(JIT_R1, JIT_R1, JIT_LOG_WORD_SIZE); jit_addi_p(JIT_R1, JIT_R1, &((Scheme_Structure *)0x0)->slots); jit_ldxr_p(JIT_R1, JIT_V1, JIT_R1); + CHECK_LIMIT(); /* JIT_R1 now has the wrapped procedure */ refz4 = jit_bmsi_i(jit_forward(), JIT_R1, 0x1); @@ -118,16 +130,23 @@ static jit_insn *generate_proc_struct_retry(mz_jit_state *jitter, int num_rands, refz6 = mz_bnei_t(jit_forward(), JIT_R1, scheme_vector_type, JIT_R2); (void)jit_ldxi_l(JIT_R2, JIT_R1, &SCHEME_VEC_SIZE(0x0)); refz7 = jit_bmci_i(jit_forward(), JIT_R2, 0x1); - /* if &(SCHEME_VEC_ELS(0x0)[1]) is a boolean, we have the fast - path; it can only otherwise be a fixnum, so just check that */ - (void)jit_ldxi_l(JIT_R2, JIT_R1, &(SCHEME_VEC_ELS(0x0)[1])); - refz8 = jit_bmsi_ul(jit_forward(), JIT_R2, 0x1); + /* Flag is set for a property-only or unsafe chaperone: */ + jit_ldxi_s(JIT_R2, JIT_V1, &SCHEME_CHAPERONE_FLAGS(((Scheme_Chaperone *)0x0))); + refz8 = jit_bmci_ul(jit_forward(), JIT_R2, SCHEME_PROC_CHAPERONE_CALL_DIRECT); + /* In the case of an unsafe chaperone, we can only make a direct + call if the arity-check will succeed, otherwise the error message + will use the wrong name. */ + jit_ldxi_p(JIT_R2, JIT_R1, &(SCHEME_VEC_ELS(0x0)[1])); + ref9 = jit_beqi_p(jit_forward(), JIT_R2, scheme_false); + refz9 = jit_bnei_p(jit_forward(), JIT_R2, scheme_make_integer(num_rands)); + mz_patch_branch(ref9); /* Position [0] in SCHEME_VEC_ELS contains either the unwrapped function (if chaperone-procedure got #f for the proc argument) or the unsafe-chaperone replacement-proc argument; either way, just call it */ jit_ldxi_p(JIT_V1, JIT_R1, &(SCHEME_VEC_ELS(0x0)[0])); (void)jit_jmpi(refagain); + CHECK_LIMIT(); mz_patch_branch(refz1); mz_patch_branch(refz2); @@ -137,6 +156,7 @@ static jit_insn *generate_proc_struct_retry(mz_jit_state *jitter, int num_rands, mz_patch_branch(refz6); mz_patch_branch(refz7); mz_patch_branch(refz8); + mz_patch_branch(refz9); return ref2; } diff --git a/racket/src/racket/src/schnapp.inc b/racket/src/racket/src/schnapp.inc index 28cabfdc34..0c78e42f22 100644 --- a/racket/src/racket/src/schnapp.inc +++ b/racket/src/racket/src/schnapp.inc @@ -62,10 +62,13 @@ Scheme_Object *PRIM_APPLY_NAME(Scheme_Object *rator, if ((t == scheme_proc_chaperone_type) && SCHEME_VECTORP(((Scheme_Chaperone *)rator)->redirects) - && (SCHEME_VEC_SIZE(((Scheme_Chaperone *)rator)->redirects) & 0x1)) { - if (SCHEME_BOOLP(SCHEME_VEC_ELS(((Scheme_Chaperone *)rator)->redirects)[1])) { + && (SCHEME_VEC_SIZE(((Scheme_Chaperone *)rator)->redirects) & 0x1) + && (SCHEME_CHAPERONE_FLAGS((Scheme_Chaperone *)rator) == SCHEME_PROC_CHAPERONE_CALL_DIRECT)) { + if (SCHEME_FALSEP(SCHEME_VEC_ELS(((Scheme_Chaperone *)rator)->redirects)[1]) + || SCHEME_INT_VAL(SCHEME_VEC_ELS(((Scheme_Chaperone *)rator)->redirects)[1]) == argc) { /* No redirection proc, i.e, chaperone is just for - properties or unsafe-chaperone-procedure result */ + properties or produced by unsafe-chaperone-procedure result -- and in the + latter case, the arity is right.. */ rator = SCHEME_VEC_ELS(((Scheme_Chaperone *)rator)->redirects)[0]; t = _SCHEME_TYPE(rator); } else diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index c0ff51c153..a567e89c9f 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -1063,6 +1063,7 @@ typedef struct Scheme_Chaperone { #define SCHEME_CHAPERONE_FLAGS(c) MZ_OPT_HASH_KEY(&(c)->iso) #define SCHEME_CHAPERONE_IS_IMPERSONATOR 0x1 +#define SCHEME_PROC_CHAPERONE_CALL_DIRECT 0x2 #define SCHEME_CHAPERONE_VAL(obj) (((Scheme_Chaperone *)obj)->val)