faster paths for chaperone application

src/racket/src/eval.c

@@ -2763,6 +2763,8 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
       
       DO_CHECK_FOR_BREAK(p, );
 
+      /* See also _apply_native(), which effectively copies this code. */
+
       data = ((Scheme_Native_Closure *)obj)->code;
 
       /* Enlarge the runstack? This max_let_depth is in bytes instead of words. */
@@ -2781,7 +2783,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
 
       tmpv = obj;
       obj = NULL; /* save for space, since tmpv is ignored by the GC */
-      v = data->code(tmpv, num_rands, rands);
+      v = data->start_code(tmpv, num_rands, rands);
 
       if (v == SCHEME_TAIL_CALL_WAITING) {
         /* [TC-SFS]; see schnapp.inc */
@@ -2885,7 +2887,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
             /* Chaperone is for function arguments */
             VACATE_TAIL_BUFFER_USE_RUNSTACK();
             UPDATE_THREAD_RSPTR();
-            v = scheme_apply_chaperone(scheme_make_raw_pair(obj, orig_obj), num_rands, rands, NULL);
+            v = scheme_apply_chaperone(scheme_make_raw_pair(obj, orig_obj), num_rands, rands, NULL, 0);
             
             if (SAME_OBJ(v, SCHEME_TAIL_CALL_WAITING)) {
               /* Need to stay in this loop, because a tail-call result must
@@ -2914,7 +2916,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
         /* Chaperone is for function arguments */
         VACATE_TAIL_BUFFER_USE_RUNSTACK();
         UPDATE_THREAD_RSPTR();
-        v = scheme_apply_chaperone(obj, num_rands, rands, NULL);
+        v = scheme_apply_chaperone(obj, num_rands, rands, NULL, 0);
       }
     } else if (type == scheme_closed_prim_type) {
       GC_CAN_IGNORE Scheme_Closed_Primitive_Proc *prim;

src/racket/src/fun.c

@@ -3023,7 +3023,7 @@ static Scheme_Object *do_chaperone_procedure(const char *name, const char *whati
                                              int is_impersonator, int argc, Scheme_Object *argv[])
 {
   Scheme_Chaperone *px;
-  Scheme_Object *val = argv[0], *orig, *naya;
+  Scheme_Object *val = argv[0], *orig, *naya, *r;
   Scheme_Hash_Tree *props;
 
   if (SCHEME_CHAPERONEP(val))
@@ -3052,7 +3052,9 @@ static Scheme_Object *do_chaperone_procedure(const char *name, const char *whati
   px->val = val;
   px->prev = argv[0];
   px->props = props;
-  px->redirects = argv[1];
+  /* put procedure with known-good arity (to speed checking) in a mutable pair: */
+  r = scheme_make_mutable_pair(argv[1], scheme_make_integer(-1));
+  px->redirects = r;
 
   if (is_impersonator)
     SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR;
@@ -3081,10 +3083,10 @@ static Scheme_Object *apply_chaperone_k(void)
   p->ku.k.p2 = NULL;
   p->ku.k.p3 = NULL;
 
-  return scheme_apply_chaperone(o, p->ku.k.i1, argv, auto_val);
+  return scheme_apply_chaperone(o, p->ku.k.i1, argv, auto_val, p->ku.k.i2);
 }
 
-static Scheme_Object *do_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object **argv, Scheme_Object *auto_val)
+static Scheme_Object *do_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object **argv, Scheme_Object *auto_val, int checks)
 {
 #ifdef DO_STACK_CHECK
   {
@@ -3098,25 +3100,56 @@ static Scheme_Object *do_apply_chaperone(Scheme_Object *o, int argc, Scheme_Obje
       p->ku.k.p2 = (void *)argv2;
       p->ku.k.p3 = (void *)auto_val;
       p->ku.k.i1 = argc;
+      p->ku.k.i2 = checks;
       return scheme_handle_stack_overflow(apply_chaperone_k);
     }
   }
 #endif
 
-  return scheme_apply_chaperone(o, argc, argv, auto_val);
+  return scheme_apply_chaperone(o, argc, argv, auto_val, checks);
 }
 
-Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object **argv, Scheme_Object *auto_val)
+
+static Scheme_Object *_apply_native(Scheme_Object *obj, int num_rands, Scheme_Object **rands)
+{
+  Scheme_Native_Closure_Data *data;
+  GC_MAYBE_IGNORE_INTERIOR MZ_MARK_STACK_TYPE old_cont_mark_stack;
+
+  data = ((Scheme_Native_Closure *)obj)->code;
+
+  if ((uintptr_t)data->max_let_depth > ((uintptr_t)scheme_current_runstack - (uintptr_t)scheme_current_runstack_start)) {
+    return _scheme_apply_multi(obj, num_rands, rands);
+  }
+
+  MZ_CONT_MARK_POS += 2;
+  old_cont_mark_stack = MZ_CONT_MARK_STACK;
+
+  obj = data->start_code(obj, num_rands, rands);
+
+  if (obj == SCHEME_TAIL_CALL_WAITING)
+    return force_values(obj, 1);
+
+  MZ_CONT_MARK_STACK = old_cont_mark_stack;
+  MZ_CONT_MARK_POS -= 2;
+
+  return obj;
+}
+
+/* must be at least 3: */
+#define MAX_QUICK_CHAP_ARGV 5
+
+Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object **argv, Scheme_Object *auto_val, int checks)
+/* checks & 0x2 => no tail; checks == 0x3 => no tail or multiple;  */
 {
   const char *what;
   Scheme_Chaperone *px;
-  Scheme_Object *v, *a[1], *a2[3], **argv2, *post, *result_v, *orig_obj, *app_mark;
+  Scheme_Object *v, *a[1], *a2[MAX_QUICK_CHAP_ARGV], **argv2, *post, *result_v, *orig_obj, *app_mark;
   int c, i, need_restore = 0;
-  int need_pop_mark = 0;
+  int need_pop_mark;
   Scheme_Cont_Frame_Data cframe;
 
   if (argv == MZ_RUNSTACK) {
-    /* Pushing onto the runstack ensures that px->redirects won't
+    /* Pushing onto the runstack ensures that `(mcar px->redirects)' won't
        modify argv. */
     if (MZ_RUNSTACK > MZ_RUNSTACK_START) {
       --MZ_RUNSTACK;
@@ -3131,7 +3164,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
   }
 
   if (SCHEME_RPAIRP(o)) {
-    /* An applicable struct, where a layout of struct chaperones
+    /* An applicable struct, where a layer of struct chaperones
        has been removed from the object to apply, but we will
        eventually need to extract the procedure from the original
        object. */
@@ -3148,17 +3181,28 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
     what = "impersonator";
 
   /* Ensure that the original procedure accepts `argc' arguments: */
-  a[0] = px->prev;
+  if (argc != SCHEME_INT_VAL(SCHEME_CDR(px->redirects))) {
-  if (!scheme_check_proc_arity(NULL, argc, 0, 0, a)) {
+    a[0] = px->prev;
-    /* Apply the original procedure, in case the chaperone would accept
+    if (!scheme_check_proc_arity(NULL, argc, 0, 0, a)) {
-       `argc' arguments (in addition to the original procedure's arity)
+      /* Apply the original procedure, in case the chaperone would accept
-       in case the methodness of the original procedure is different
+         `argc' arguments (in addition to the original procedure's arity)
-       from the chaperone, or in case the procedures have different names. */
+         in case the methodness of the original procedure is different
-    (void)_scheme_apply_multi(px->prev, argc, argv);
+         from the chaperone, or in case the procedures have different names. */
-    scheme_signal_error("internal error: unexpected success applying chaperoned/proxied procedure");
+      (void)_scheme_apply_multi(px->prev, argc, argv);
-    return NULL;
+      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_CDR(px->redirects) = scheme_make_integer(argc);
   }
 
+  if (checks) {
+    scheme_push_continuation_frame(&cframe);
+    need_pop_mark = 1;
+  } else
+    need_pop_mark = 0;
+
   if (px->props) {
     app_mark = scheme_hash_tree_get(px->props, scheme_app_mark_impersonator_property);
     /* app_mark should be (cons mark val) */
@@ -3170,22 +3214,35 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
   if (app_mark) {
     v = scheme_extract_one_cc_mark(NULL, SCHEME_CAR(app_mark));
     if (v) {
-      scheme_push_continuation_frame(&cframe);
+      if (!checks)
+        scheme_push_continuation_frame(&cframe);
       scheme_set_cont_mark(SCHEME_CAR(app_mark), v);
-      MZ_CONT_MARK_POS -= 2;
+      if (!checks) {
-      need_pop_mark = 1;
+        MZ_CONT_MARK_POS -= 2;
-    } else
+        need_pop_mark = 1;
-      need_pop_mark = 0;
+      }
-  } else
+    } 
-    need_pop_mark = 0;
+  }
 
-  v = _scheme_apply_multi(px->redirects, argc, argv);
+  v = SCHEME_CAR(px->redirects);
+  if (SAME_TYPE(SCHEME_TYPE(v), scheme_native_closure_type))
+    v = _apply_native(v, argc, argv);
+  else
+    v = _scheme_apply_multi(v, argc, argv);
   if (v == SCHEME_MULTIPLE_VALUES) {
     GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread;
-    if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
-      p->values_buffer = NULL;
     c = p->ku.multiple.count;
     argv2 = p->ku.multiple.array;
+    if (SAME_OBJ(p->ku.multiple.array, p->values_buffer)) {
+      if (c <= MAX_QUICK_CHAP_ARGV) {
+        for (i = 0; i < c; i++) {
+          a2[i] = argv2[i];
+        }
+        argv2 = a2;
+      } else {
+        p->values_buffer = NULL;
+      }
+    }
   } else {
     c = 1;
     a2[0] = v;
@@ -3193,7 +3250,8 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
   }
 
   if (need_pop_mark) {
-    MZ_CONT_MARK_POS += 2;
+    if (!checks)
+      MZ_CONT_MARK_POS += 2;
     scheme_pop_continuation_frame(&cframe);
   }
   
@@ -3205,16 +3263,17 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
       post = NULL;
     if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) {
       for (i = 0; i < argc; i++) {
-        if (!scheme_chaperone_of(argv2[i], argv[i])) {
+        if (!SAME_OBJ(argv2[i], argv[i])
+            && !scheme_chaperone_of(argv2[i], argv[i])) {
           if (argc == 1)
             scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                              "procedure chaperone: %V: result: %V is not a chaperone of argument: %V",
-                             px->redirects,
+                             SCHEME_CAR(px->redirects),
                              argv2[i], argv[i]);
           else
             scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                              "procedure chaperone: %V: %d%s result: %V is not a chaperone of argument: %V",
-                             px->redirects,
+                             SCHEME_CAR(px->redirects),
                              i, scheme_number_suffix(i),
                              argv2[i], argv[i]);
         }
@@ -3224,7 +3283,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
     scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY,
                      "procedure %s: %V: returned %d values, expected %d or %d",
                      what,
-                     px->redirects,
+                     SCHEME_CAR(px->redirects),
                      c, argc, argc + 1);
     return NULL;
   }
@@ -3245,7 +3304,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
       scheme_set_cont_mark(SCHEME_CAR(app_mark), SCHEME_CDR(app_mark));
     if (auto_val) {
       if (SCHEME_CHAPERONEP(px->prev))
-        return do_apply_chaperone(px->prev, c, argv2, auto_val);
+        return do_apply_chaperone(px->prev, c, argv2, auto_val, 0);
       else
         return argv2[0];
     } else {
@@ -3254,7 +3313,20 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
         orig_obj = scheme_make_raw_pair(px->prev, orig_obj);
       else
         orig_obj = px->prev;
-      return scheme_tail_apply(orig_obj, c, argv2);
+      if (checks) {
+        /* cannot return a tail call */
+        MZ_CONT_MARK_POS -= 2;
+        if (checks & 0x1) {
+          v = _scheme_apply(orig_obj, c, argv2);
+        } else if (SAME_TYPE(SCHEME_TYPE(orig_obj), scheme_native_closure_type)) {
+          v = _apply_native(orig_obj, c, argv2);
+        } else {
+          v = _scheme_apply_multi(orig_obj, c, argv2);
+        }
+        MZ_CONT_MARK_POS += 2;
+        return v;
+      } else
+        return scheme_tail_apply(orig_obj, c, argv2);
     }
   } else {
     /* First element is a filter for the result(s) */
@@ -3262,7 +3334,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
       scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                        "procedure %s: %V: expected <procedure> as first result, produced: %V",
                        what,
-                       px->redirects,
+                       SCHEME_CAR(px->redirects),
                        post);
 
     if (app_mark) {
@@ -3275,7 +3347,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
 
     if (auto_val) {
       if (SCHEME_CHAPERONEP(px->prev))
-        result_v = do_apply_chaperone(px->prev, argc, argv2, auto_val);
+        result_v = do_apply_chaperone(px->prev, argc, argv2, auto_val, 0);
       else
         result_v = argv2[0];
       v = auto_val;
@@ -3285,16 +3357,25 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
         orig_obj = scheme_make_raw_pair(px->prev, orig_obj);
       else
         orig_obj = px->prev;
-      v = _scheme_apply_multi(orig_obj, argc, argv2);
+      if (SAME_TYPE(SCHEME_TYPE(orig_obj), scheme_native_closure_type))
+        v = _apply_native(orig_obj, argc, argv2);
+      else
+        v = _scheme_apply_multi(orig_obj, argc, argv2);
       result_v = NULL;
     }
 
     if (v == SCHEME_MULTIPLE_VALUES) {
       GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread;
-      if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
+      if (checks & 0x1) {
-        p->values_buffer = NULL;
+        scheme_wrong_return_arity(NULL, 1, p->ku.multiple.count, 
-      c = p->ku.multiple.count;
+                                  p->ku.multiple.array,
-      argv = p->ku.multiple.array;
+                                  NULL);
+      } else {
+        if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
+          p->values_buffer = NULL;
+        c = p->ku.multiple.count;
+        argv = p->ku.multiple.array;
+      }
     } else {
       c = 1;
       a[0] = v;
@@ -3328,7 +3409,8 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
     if (c == argc) {
       if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) {
         for (i = 0; i < argc; i++) {
-          if (!scheme_chaperone_of(argv2[i], argv[i])) {
+          if (!SAME_OBJ(argv2[i], argv[i])
+              && !scheme_chaperone_of(argv2[i], argv[i])) {
             if (argc == 1)
               scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                                "procedure-result chaperone: %V: result: %V is not a chaperone of original result: %V",

src/racket/src/future.c

@@ -1179,7 +1179,7 @@ static Scheme_Object *make_future(Scheme_Object *lambda)
    
   /* JIT the code if not already JITted */
   if (ncd) {
-    if (ncd->code == scheme_on_demand_jit_code)
+    if (ncd->start_code == scheme_on_demand_jit_code)
       scheme_on_demand_generate_lambda(nc, 0, NULL, 0);
   
     if (ncd->max_let_depth > FUTURE_RUNSTACK_SIZE * sizeof(void*)) {
@@ -1187,7 +1187,7 @@ static Scheme_Object *make_future(Scheme_Object *lambda)
       ft->status = PENDING_OVERSIZE;
     }
 
-    ft->code = (void*)ncd->code;
+    ft->code = (void*)ncd->start_code;
   } else
     ft->status = PENDING_OVERSIZE;
 
@@ -1220,7 +1220,7 @@ Scheme_Object *scheme_future(int argc, Scheme_Object *argv[])
     Scheme_Object *proc = argv[0];
     if (SAME_TYPE(SCHEME_TYPE(proc), scheme_native_closure_type)
         && scheme_native_arity_check(proc, 0)
-        && (((Scheme_Native_Closure *)proc)->code->code != scheme_on_demand_jit_code)
+        && (((Scheme_Native_Closure *)proc)->code->start_code != scheme_on_demand_jit_code)
         && (((Scheme_Native_Closure *)proc)->code->max_let_depth < FUTURE_RUNSTACK_SIZE * sizeof(void*))) {
       /* try to alocate a future in the future thread */
       future_t *ft;
@@ -1232,7 +1232,7 @@ Scheme_Object *scheme_future(int argc, Scheme_Object *argv[])
         ft->orig_lambda = proc;
         ft->status = PENDING;
         ft->cust = scheme_current_thread->current_ft->cust;
-        ft->code = ((Scheme_Native_Closure *)proc)->code->code;
+        ft->code = ((Scheme_Native_Closure *)proc)->code->start_code;
 
         mzrt_mutex_lock(fs->future_mutex);
         ft->id = ++fs->next_futureid;

src/racket/src/jit.c

@@ -3039,7 +3039,7 @@ static int generate_function_getarg(mz_jit_state *jitter, int has_rest, int num_
 
 typedef struct {
   Scheme_Closure_Data *data;
-  void *arity_code, *code, *tail_code, *code_end, **patch_depth;
+  void *arity_code, *start_code, *tail_code, *code_end, **patch_depth;
   int max_extra, max_depth, max_tail_depth;
   Scheme_Native_Closure *nc;
   int argc, argv_delta;
@@ -3050,11 +3050,11 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
 {
   Generate_Closure_Data *gdata = (Generate_Closure_Data *)_data;
   Scheme_Closure_Data *data = gdata->data;
-  void *code, *tail_code, *code_end, *arity_code;
+  void *start_code, *tail_code, *code_end, *arity_code;
   int i, r, cnt, has_rest, is_method, num_params, to_args, argc, argv_delta;
   Scheme_Object **argv;
 
-  code = jit_get_ip().ptr;
+  start_code = jit_get_ip().ptr;
 
   jitter->nc = gdata->nc;
 
@@ -3062,7 +3062,7 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
   argv = gdata->argv;
   argv_delta = gdata->argv_delta;
 
-  generate_function_prolog(jitter, code, 
+  generate_function_prolog(jitter, start_code, 
 			   /* max_extra_pushed may be wrong the first time around,
 			      but it will be right the last time around */
 			   WORDS_TO_BYTES(data->max_let_depth + jitter->max_extra_pushed));
@@ -3075,7 +3075,7 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
   CHECK_LIMIT();
 
   /* A tail call with arity checking can start here.
-     (This is a little reundant checking when `code' is the
+     (This is a little reundant checking when `start_code' is the
      entry point, but that's the slow path anyway.) */
   
   has_rest = ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) ? 1 : 0);
@@ -3370,7 +3370,7 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
 
   if (jitter->retain_start) {
     gdata->arity_code = arity_code;
-    gdata->code = code;
+    gdata->start_code = start_code;
     gdata->tail_code = tail_code;
     gdata->max_extra = jitter->max_extra_pushed;
     gdata->max_depth = jitter->max_depth;
@@ -3387,7 +3387,7 @@ static void on_demand_generate_lambda(Scheme_Native_Closure *nc, int argc, Schem
   Scheme_Native_Closure_Data *ndata = nc->code;
   Scheme_Closure_Data *data;
   Generate_Closure_Data gdata;
-  void *code, *tail_code, *arity_code;
+  void *start_code, *tail_code, *arity_code;
   int max_depth;
 
   data = ndata->u2.orig_code;
@@ -3402,7 +3402,7 @@ static void on_demand_generate_lambda(Scheme_Native_Closure *nc, int argc, Schem
   scheme_delay_load_closure(data);
 
   /* So, check again whether we still need to generate: */
-  if (ndata->code != scheme_on_demand_jit_code)
+  if (ndata->start_code != scheme_on_demand_jit_code)
     return;
 
   ndata->arity_code = sjc.in_progress_on_demand_jit_arity_code; /* => in progress */
@@ -3420,14 +3420,14 @@ static void on_demand_generate_lambda(Scheme_Native_Closure *nc, int argc, Schem
     SCHEME_NATIVE_CLOSURE_DATA_FLAGS(ndata) |= NATIVE_IS_SINGLE_RESULT;
 
   arity_code = gdata.arity_code;
-  code = gdata.code;
+  start_code = gdata.start_code;
   tail_code = gdata.tail_code;
   
   if (data->name) {
-    scheme_jit_add_symbol((uintptr_t)code, (uintptr_t)gdata.code_end - 1, data->name, 1);
+    scheme_jit_add_symbol((uintptr_t)start_code, (uintptr_t)gdata.code_end - 1, data->name, 1);
   } else {
 #ifdef MZ_USE_DWARF_LIBUNWIND
-    scheme_jit_add_symbol((uintptr_t)code, (uintptr_t)gdata.code_end - 1, scheme_null, 1);
+    scheme_jit_add_symbol((uintptr_t)start_code, (uintptr_t)gdata.code_end - 1, scheme_null, 1);
 #endif
   }
   
@@ -3456,7 +3456,7 @@ static void on_demand_generate_lambda(Scheme_Native_Closure *nc, int argc, Schem
     jit_patch_movi(((jit_insn *)(*pd)), (void *)(intptr_t)max_depth);
   }
 
-  ndata->code = code;
+  ndata->start_code = start_code;
   ndata->u.tail_code = tail_code;
   ndata->arity_code = arity_code;
   ndata->u2.name = data->name;
@@ -3477,7 +3477,7 @@ Scheme_Object **scheme_on_demand_with_args(Scheme_Object **in_argv, Scheme_Objec
   c = in_argv[0];
   argc = in_argv[1];
 
-  if (((Scheme_Native_Closure *)c)->code->code == scheme_on_demand_jit_code)
+  if (((Scheme_Native_Closure *)c)->code->start_code == scheme_on_demand_jit_code)
     scheme_on_demand_generate_lambda((Scheme_Native_Closure *)c, SCHEME_INT_VAL(argc), argv, argv_delta);
 
   return argv;
@@ -3514,7 +3514,7 @@ static Scheme_Native_Closure_Data *create_native_lambda(Scheme_Closure_Data *dat
     ndata->iso.so.type = scheme_rt_native_code_plus_case;
 #endif
   }
-  ndata->code = scheme_on_demand_jit_code;
+  ndata->start_code = scheme_on_demand_jit_code;
   ndata->u.tail_code = sjc.on_demand_jit_arity_code;
   ndata->arity_code = sjc.on_demand_jit_arity_code;
   ndata->u2.orig_code = data;
@@ -3726,17 +3726,17 @@ typedef struct {
 static int do_generate_case_lambda_dispatch(mz_jit_state *jitter, void *_data)
 {
   Generate_Case_Dispatch_Data *data = (Generate_Case_Dispatch_Data *)_data;
-  void *code, *arity_code;
+  void *start_code, *arity_code;
 
-  code = jit_get_ip().ptr;
+  start_code = jit_get_ip().ptr;
   
-  generate_function_prolog(jitter, code, data->ndata->max_let_depth);
+  generate_function_prolog(jitter, start_code, data->ndata->max_let_depth);
   CHECK_LIMIT();
   
   if (generate_case_lambda_dispatch(jitter, data->c, data->ndata, 1)) {
     arity_code = jit_get_ip().ptr;
     if (generate_case_lambda_dispatch(jitter, data->c, data->ndata, 0)) {
-      data->ndata->code = code;
+      data->ndata->start_code = start_code;
       data->ndata->arity_code = arity_code;
       
       return 1;
@@ -3791,7 +3791,7 @@ static void generate_case_lambda(Scheme_Case_Lambda *c, Scheme_Native_Closure_Da
 XFORM_NONGCING static int lambda_has_been_jitted(Scheme_Native_Closure_Data *ndata)
 /* called by scheme_native_arity_check(), which is not XFORMed */
 {
-  return (ndata->code != scheme_on_demand_jit_code);
+  return (ndata->start_code != scheme_on_demand_jit_code);
 }
 
 int scheme_native_arity_check(Scheme_Object *closure, int argc)

src/racket/src/jitcall.c

@@ -1454,12 +1454,12 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
                of the call. */
             Scheme_Native_Closure *nc;
             nc = (Scheme_Native_Closure *)scheme_jit_closure((Scheme_Object *)data, NULL);
-            if (nc->code->code == scheme_on_demand_jit_code) {
+            if (nc->code->start_code == scheme_on_demand_jit_code) {
               if (nc->code->arity_code != sjc.in_progress_on_demand_jit_arity_code) {
                 scheme_on_demand_generate_lambda(nc, 0, NULL, 0);
               }
             }
-            if (nc->code->code != scheme_on_demand_jit_code) {
+            if (nc->code->start_code != scheme_on_demand_jit_code) {
               if (nc->code->max_let_depth > jitter->max_tail_depth)
                 jitter->max_tail_depth = nc->code->max_let_depth;
 

src/racket/src/jitcommon.c

@@ -2596,8 +2596,8 @@ static int common10(mz_jit_state *jitter, void *_data)
     jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Native_Closure *)0x0)->code);
     jit_ldxi_i(JIT_R2, JIT_V1, &((Scheme_Native_Closure_Data *)0x0)->closure_size);
     (void)jit_blti_i(refslow, JIT_R2, 0); /* case lambda */
-    jit_ldxi_p(JIT_R2, JIT_V1, &((Scheme_Native_Closure_Data *)0x0)->code);
+    jit_ldxi_p(JIT_R2, JIT_V1, &((Scheme_Native_Closure_Data *)0x0)->start_code);
-    jit_movi_p(JIT_V1, scheme_on_demand_jit_code); /* movi_p doesn't depends on actual address, which might change size */
+    jit_movi_p(JIT_V1, scheme_on_demand_jit_code); /* movi_p doesn't depend on actual address, which might change size */
     ref_nc = jit_beqr_p(jit_forward(), JIT_R2, JIT_V1); /* not yet JITted? */
     jit_rshi_l(JIT_V1, JIT_R1, 1);
     jit_addi_l(JIT_V1, JIT_V1, 1);

src/racket/src/schnapp.inc

@@ -62,6 +62,9 @@ Scheme_Object *PRIM_APPLY_NAME(Scheme_Object *rator,
 
     if (t == scheme_prim_type) {
       return PRIM_APPLY_NAME_FAST(rator, argc, argv);
+    } if ((t == scheme_proc_chaperone_type)
+          && (SCHEME_MPAIRP(((Scheme_Chaperone *)rator)->redirects))) {
+      return scheme_apply_chaperone(rator, argc, argv, NULL, PRIM_CHECK_MULTI | (PRIM_CHECK_VALUE << 1));
     }
   }
 

src/racket/src/schpriv.h

@@ -858,7 +858,8 @@ typedef struct Scheme_Chaperone {
 Scheme_Object *scheme_chaperone_vector_ref(Scheme_Object *o, int i);
 void scheme_chaperone_vector_set(Scheme_Object *o, int i, Scheme_Object *v);
 
-Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object **argv, Scheme_Object *auto_val);
+Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object **argv, 
+                                      Scheme_Object *auto_val, int checks);
 
 Scheme_Hash_Tree *scheme_parse_chaperone_props(const char *who, int start_at, int argc, Scheme_Object **argv);
 
@@ -2320,8 +2321,8 @@ typedef struct {
 typedef struct Scheme_Native_Closure_Data {
   Scheme_Inclhash_Object iso; /* type tag only set when needed, but
                                  flags always needed */
-  Scheme_Closed_Prim *code; /* When not yet JITted, this is = to
+  Scheme_Closed_Prim *start_code; /* When not yet JITted, this is = to
-                               scheme_on_demand_jit_code */  
+                                     scheme_on_demand_jit_code */  
   union {
     void *tail_code;                       /* For non-case-lambda */
     mzshort *arities;                      /* For case-lambda */

src/racket/src/thread.c

@@ -6852,7 +6852,7 @@ static Scheme_Object *extend_parameterization(int argc, Scheme_Object *argv[])
       key = argv[i + 1];
       if (SCHEME_CHAPERONEP(param)) {
         a[0] = key;
-        key = scheme_apply_chaperone(param, 1, a, scheme_void);
+        key = scheme_apply_chaperone(param, 1, a, scheme_void, 0);
         param = SCHEME_CHAPERONE_VAL(param);
       }
       a[0] = key;