diff --git a/LOG b/LOG index 33ed3570d0..a39dd03101 100644 --- a/LOG +++ b/LOG @@ -1087,3 +1087,6 @@ 5_4.ss, 5_4.ms - added enable-arithmetic-left-associative cp0.ss, compile.ss, primdata.ss, front.ss, cp0.ms, system.stex +- fix allocation of string/bytevector for a foreign-callable argument + or foreign-call return + cpnanopass.ss, foreign.ms, foreign2.c diff --git a/mats/foreign.ms b/mats/foreign.ms index 3b34840cfd..7dc06569ab 100644 --- a/mats/foreign.ms +++ b/mats/foreign.ms @@ -2539,6 +2539,29 @@ v) 14995143) + ;; regression test related to saving registers that hold allocated + ;; callable argument + (let* ([call-with-many-args (foreign-procedure "call_with_many_args" (void*) boolean)] + [result #f] + [cb (foreign-callable + (lambda (i s1 s2 s3 s4 i2 s6 s7 i3) + (set! result + (and (eqv? i 0) + (equal? (string->utf8 "this") s1) + (equal? (string->utf8 "is") s2) + (equal? (string->utf8 "working") s3) + (equal? (string->utf8 "just") s4) + (eqv? i2 1) + (equal? (string->utf8 "fine") s6) + (equal? (string->utf8 "or does it?") s7) + (eqv? i3 2)))) + (int u8* u8* u8* u8* int u8* u8* int) + void)]) + (lock-object cb) + (call-with-many-args (foreign-callable-entry-point cb)) + (unlock-object cb) + result) + ) (machine-case diff --git a/mats/foreign2.c b/mats/foreign2.c index d69b4898ab..3e12cf1fff 100644 --- a/mats/foreign2.c +++ b/mats/foreign2.c @@ -443,3 +443,10 @@ EXPORT void call_many_times(void (*f)(iptr)) j = k+2; k = l+2; l = m+2; m = m+2; } } + +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) +{ + callback(0, "this", "is", "working", "just", 1, "fine", "or does it?", 2); +} diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss index 4e24456dff..a28c525b79 100644 --- a/s/cpnanopass.ss +++ b/s/cpnanopass.ss @@ -905,9 +905,9 @@ (constant-case ptr-bits [(32) (declare-intrinsic dofretuns64 dofretuns64 (%ts %td %xp) (%ac0 %ac1) (%ac0))] [(64) (declare-intrinsic dofretuns64 dofretuns64 (%ts %td %xp) (%ac0) (%ac0))]) - (declare-intrinsic dofretu8* dofretu8* (%ac0 %ts %td %cp) (%ac0) (%xp)) - (declare-intrinsic dofretu16* dofretu16* (%ac0 %ts %td %cp) (%ac0) (%xp)) - (declare-intrinsic dofretu32* dofretu32* (%ac0 %ts %td %cp) (%ac0) (%xp)) + (declare-intrinsic dofretu8* dofretu8* (%ac0 %ts %td %cp %ac1) (%ac0) (%xp)) + (declare-intrinsic dofretu16* dofretu16* (%ac0 %ts %td %cp %ac1) (%ac0) (%xp)) + (declare-intrinsic dofretu32* dofretu32* (%ac0 %ts %td %cp %ac1) (%ac0) (%xp)) (declare-intrinsic get-room get-room () (%xp) (%xp)) (declare-intrinsic scan-remembered-set scan-remembered-set () () ()) (declare-intrinsic reify-cc reify-cc (%xp %ac0 %ts) () (%td)) @@ -12457,7 +12457,6 @@ (set! ,%xp (literal ,(make-info-literal #f 'object #vu8() 0))) (asm-return ,return-live* ...)) ,(%seq - ; TODO: avoid use of ac1 by insisting that get-room preserve ts & td (set! ,(ref-reg %ac1) ,%td) (set! ,%td ,(%inline + ,%td (immediate