JIT: fix fast path for property-only chaperones

The recently added fast path for property-only chaperones did not
propagate the original object in the case that the property-only
chaperone wraps a `chaperone-procedure*` chaprerone.

Merge to v6.4

pkgs/racket-test-core/tests/racket/chaperone.rktl

@@ -2409,4 +2409,38 @@
 
 ;; ----------------------------------------
 
+(let ()
+  (define-values (->-c has-->c? get-->-c)
+    (make-impersonator-property '->-c))
+
+  (define-values (->-w has-->w? get-->-w)
+    (make-impersonator-property '->-w))
+
+  (define-values (prop:x x? x-ref)
+    (make-impersonator-property 'x))
+
+  (define (wrap-again function)
+    (chaperone-procedure*
+     function
+     #f
+     ->-w  void
+     ->-c  void))
+
+  (define (do-wrap f)
+    (chaperone-procedure* f
+                          (λ (chap arg)
+                            (test #t has-->w? chap)
+                            (test #t has-->c? chap)
+                            arg
+                            (values (lambda (result) result) arg))))
+
+  (define wrapped-f (wrap-again (do-wrap (lambda (x) (+ x 1)))))
+  (define wrapped2-f (wrap-again (chaperone-procedure (do-wrap (lambda (x) (+ x 1))) #f prop:x 'x)))
+  (define (test-wrapped x) (x 19))
+  (set! test-wrapped test-wrapped)
+  (test-wrapped wrapped-f)
+  (test-wrapped wrapped2-f))
+
+;; ----------------------------------------
+
 (report-errs)

racket/src/racket/src/fun.c

@@ -3535,7 +3535,7 @@ static Scheme_Object *do_chaperone_procedure(const char *name, const char *whati
                                              int is_impersonator, int pass_self,
                                              int argc, Scheme_Object *argv[], int is_unsafe)
 {
-  Scheme_Chaperone *px;
+  Scheme_Chaperone *px, *px2;
   Scheme_Object *val = argv[0], *orig, *naya, *r, *app_mark;
   Scheme_Hash_Tree *props;
 
@@ -3602,7 +3602,9 @@ static Scheme_Object *do_chaperone_procedure(const char *name, const char *whati
      Vector of odd size for redirects means a procedure chaperone,
      vector with even slots means a structure chaperone.
      A size of 5 (instead of 3) indicates that the wrapper
-     procedure accepts a "self" argument
+     procedure accepts a "self" argument. An immutable vector
+     means that it wraps a chaperone that wants the "self" 
+     argument.
 
      If the known-good arity is #f, this means the chaperone
      wrapper defers directly to SCHEME_VEC_ELES(r)[0] and no
@@ -3625,6 +3627,18 @@ static Scheme_Object *do_chaperone_procedure(const char *name, const char *whati
   if (is_unsafe || SCHEME_FALSEP(argv[1]))
     SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_PROC_CHAPERONE_CALL_DIRECT;
 
+  /* If there's a `pass_self` chaperone in px->prev, then we'll need
+     to pass the self proc along. */
+  for (val = px->prev; SCHEME_P_CHAPERONEP(val); val = ((Scheme_Chaperone *)val)->prev) {
+    px2 = (Scheme_Chaperone *)val;
+    if (SCHEME_VECTORP(px2->redirects) && (SCHEME_VEC_SIZE(px2->redirects) & 0x1)) {
+      if ((SCHEME_VEC_SIZE(px2->redirects) > 3)
+          || SCHEME_IMMUTABLEP(px2->redirects))
+        SCHEME_SET_IMMUTABLE(px->redirects);
+      break;
+    }
+  }
+
   return (Scheme_Object *)px;
 }
 
@@ -3884,7 +3898,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
   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)) {
+    if (SCHEME_IMMUTABLEP(px->redirects)) {
       /* communicate `self_proc` to the next layer: */
       scheme_current_thread->self_for_proc_chaperone = self_proc;
     }
@@ -4038,7 +4052,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
     /* No filter for the result, so tail call: */
     if (app_mark)
       scheme_set_cont_mark(SCHEME_CAR(app_mark), SCHEME_CDR(app_mark));
-    if (SCHEME_CHAPERONEP(px->prev)) {
+    if (SCHEME_IMMUTABLEP(px->redirects)) {
       /* commuincate `self_proc` to the next layer: */
       scheme_current_thread->self_for_proc_chaperone = self_proc;
     }
@@ -4080,7 +4094,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
     if (need_pop_mark)
       MZ_CONT_MARK_POS -= 2;
 
-    if (SCHEME_CHAPERONEP(px->prev)) {
+    if (SCHEME_IMMUTABLEP(px->redirects)) {
       /* commuincate `self_proc` to the next layer: */
       scheme_current_thread->self_for_proc_chaperone = self_proc;
     }

racket/src/racket/src/jitcall.c

@@ -66,7 +66,7 @@ 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, *ref3, *refz1, *refz2, *refz3, *refz4, *refz5;
-  GC_CAN_IGNORE jit_insn *refz6, *refz7, *refz8, *refz9, *ref9;
+  GC_CAN_IGNORE jit_insn *refz6, *refz7, *refz8, *refz9, *ref9, *ref10;
 
   ref2 = jit_bnei_i(jit_forward(), JIT_R1, scheme_proc_struct_type);
 
@@ -140,6 +140,19 @@ static jit_insn *generate_proc_struct_retry(mz_jit_state *jitter, int num_rands,
   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);
+  CHECK_LIMIT();
+  /* If the vector is immutable, we need to provide the self proc,
+     if it's not provided already. The self proc is supplied through
+     a side channel in the thread record. */
+  jit_ldxi_s(JIT_R2, JIT_R1, &MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(0x0)));
+  ref9 = jit_bmci_i(jit_forward(), JIT_R2, 0x1);
+  (void)mz_tl_ldi_p(JIT_R2, tl_scheme_current_thread);
+  jit_ldxi_l(JIT_R1, JIT_R2, &((Scheme_Thread *)0x0)->self_for_proc_chaperone);
+  ref10 = jit_bnei_p(jit_forward(), JIT_R1, NULL);
+  jit_stxi_l(&((Scheme_Thread *)0x0)->self_for_proc_chaperone, JIT_R2, JIT_V1);
+  mz_patch_branch(ref10);
+  jit_ldxi_p(JIT_R1, JIT_V1, &((Scheme_Chaperone *)0x0)->redirects);
+  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

racket/src/racket/src/schnapp.inc

@@ -68,7 +68,10 @@ Scheme_Object *PRIM_APPLY_NAME(Scheme_Object *rator,
           || SCHEME_INT_VAL(SCHEME_VEC_ELS(((Scheme_Chaperone *)rator)->redirects)[1]) == argc) {
         /* No redirection proc, i.e, chaperone is just for
 	   properties or produced by unsafe-chaperone-procedure result -- and in the
-           latter case, the arity is right.. */
+           latter case, the arity is right. */
+        GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread;
+        if (SCHEME_IMMUTABLEP(((Scheme_Chaperone *)rator)->redirects) && !p->self_for_proc_chaperone)
+          p->self_for_proc_chaperone = rator;
         rator = SCHEME_VEC_ELS(((Scheme_Chaperone *)rator)->redirects)[0];
         t = _SCHEME_TYPE(rator);
       } else