fix foreign-callable handling of bytevector arguments

This is a follow-up to 276f8da076, where `(%tc-ref cp)` was supposed
to be preserved by moving it into %cp, but intrinisics for bytevector
arguments can kill %cp. Use a temporary to expose things properly to
the register allocator.

original commit: 3a29db06a452e46e69ebcde524b3b9acb435dec3

c/schlib.c

@@ -216,6 +216,8 @@ void S_call_help(tc_in, singlep, lock_ts) ptr tc_in; IBOOL singlep; IBOOL lock_t
      the C stack and we may end up in a garbage collection */
     code = CP(tc);
     if (Sprocedurep(code)) code = CLOSCODE(code);
+    if (!IMMEDIATE(code) && !Scodep(code))
+      S_error_abort("S_call_help: invalid code pointer");
     S_immobilize_object(code);
 
     CP(tc) = AC1(tc);

mats/foreign.ms

@@ -2569,9 +2569,33 @@
      (with-object-kept-live
       handler
       (call_many_times (foreign-callable-entry-point handler)))
+     (unlock-object handler)
      v)
    14995143)
 
+  (equal?
+   (let ()
+     (define v 0)
+     (define call_many_times_bv (foreign-procedure "call_many_times_bv" (void*) void))
+     (define work
+       (lambda (bv)
+         (set! v (+ v (bytevector-u8-ref bv 0)))
+         ;; Varying work, as above:
+         (let loop ([n (bitwise-and (bytevector-u8-ref bv 1) #xFFFF)])
+           (unless (zero? n)
+             (set! v (add1 v))
+             (loop (bitwise-arithmetic-shift-right n 1))))))
+     (define handlers (list (foreign-callable work (u8*) void)
+                            (foreign-callable work (u16*) void)
+                            (foreign-callable work (u32*) void)))
+     (map lock-object handlers)
+     (for-each (lambda (handler)
+                 (call_many_times_bv (foreign-callable-entry-point handler)))
+               handlers)
+     (map unlock-object handlers)
+     v)
+   103500000)
+
   ;; regression test related to saving registers that hold allocated
   ;; callable argument
   (let* ([call-with-many-args (foreign-procedure "call_with_many_args" (void*) boolean)]

mats/foreign2.c

@@ -455,6 +455,18 @@ EXPORT void call_many_times(void (*f)(iptr))
   }
 }
 
+EXPORT void call_many_times_bv(void (*f)(char *s))
+{
+  /* make this sensible as u8*, u16*, and u32* */
+  char buf[8] = { 1, 2, 3, 4, 0, 0, 0, 0 };
+  int x;
+
+  for (x = 0; x < 1000000; x++) {
+    buf[0] = (x & 63) + 1;
+    f(buf);
+  }
+}
+
 typedef void (*many_arg_callback_t)(int i, const char* s1, const char* s2, const char* s3,
                                     const char* s4, int i2, const char* s6, const char* s7, int i3);
 EXPORT void call_with_many_args(many_arg_callback_t callback)

s/cpnanopass.ss

@@ -12171,7 +12171,10 @@
                                    (if (null? frame-x*)
                                        (begin (set! max-fv (fxmax max-fv i)) '())
                                        (let ([i (fx+ i 1)])
-                                         (cons (get-ptr-fv i) (f (cdr frame-x*) i)))))])
+                                         (cons (get-ptr-fv i) (f (cdr frame-x*) i)))))]
+                            [cp-save (meta-cond
+                                      [(real-register? '%cp) (make-tmp 'cp)]
+                                      [else #f])])
                         ; add 2 for the old RA and cchain
                         (set! max-fv (fx+ max-fv 2))
                         (let-values ([(c-init c-args c-result c-return) (asm-foreign-callable info)])
@@ -12181,17 +12184,20 @@
                           ; c-return restores callee-save registers and returns to C
                           (%seq
                             ,(c-init)
-                            ; although we don't actually need %cp in a register, we need
-                            ; to make sure that `(%tc-ref cp)` doesn't change before S_call_help
-                            ; is called, and claiming that %cp is live is the easiest way
                             ,(restore-scheme-state
-                               (in %cp)
+                               (in %cp) ; to save and then restore just before S_call_help
                                (out %ac0 %ac1 %xp %yp %ts %td scheme-args extra-regs))
                             ; need overflow check since we're effectively retroactively turning
                             ; what was a foreign call into a Scheme non-tail call
                             (fcallable-overflow-check)
                             ; leave room for the RA & c-chain
                             (set! ,%sfp ,(%inline + ,%sfp (immediate ,(fx* (constant ptr-bytes) 2))))
+                            ; stash %cp and restore later to make sure it's intact by the time
+                            ; that we get to S_call_help
+                            ,(meta-cond
+                              [(real-register? '%cp) `(set! ,cp-save ,%cp)]
+                              [else `(nop)])
+                            ; convert arguments
                             ,(fold-left (lambda (e x arg-type c-arg) `(seq ,(C->Scheme arg-type c-arg x) ,e))
                                (set-locs fv* frame-x*
                                  (set-locs (map (lambda (reg) (in-context Lvalue (%mref ,%tc ,(reg-tc-disp reg)))) reg*) reg-x*
@@ -12201,6 +12207,9 @@
                             ; needs to be a quote, not an immediate
                             (set! ,(ref-reg %ac1) (literal ,(make-info-literal #f 'object 0 0)))
                             (set! ,(ref-reg %ts) (label-ref ,self-label 0)) ; for locking
+                            ,(meta-cond
+                              [(real-register? '%cp) `(set! ,%cp ,cp-save)]
+                              [else `(nop)])
                             ,(save-scheme-state
                                (in %ac0 %ac1 %ts %cp)
                                (out %xp %yp %td scheme-args extra-regs))