diff --git a/c/schlib.c b/c/schlib.c index 4a73c560b4..772e95487b 100644 --- a/c/schlib.c +++ b/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); diff --git a/mats/foreign.ms b/mats/foreign.ms index 1222f164fd..ad5fb5170f 100644 --- a/mats/foreign.ms +++ b/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)] diff --git a/mats/foreign2.c b/mats/foreign2.c index 99064fdebb..56b2f5b2db 100644 --- a/mats/foreign2.c +++ b/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) diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss index 770f465096..d6181689e8 100644 --- a/s/cpnanopass.ss +++ b/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))