From 54ffb5dfbe0ea13addb09564566b03036568176a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 16 Nov 2018 10:37:30 -0700 Subject: [PATCH] reliably preserve cp in thread context for S_call_help Also, for completeness, correct the listing of callee-save registers in callable return for x86 & x86_64. original commit: 4cd942be6ab2eb5e02f6d6c5c509db3131bd015f --- LOG | 4 ++++ mats/foreign.ms | 27 +++++++++++++++++++++++---- mats/foreign2.c | 19 +++++++++++++++++++ s/cpnanopass.ss | 12 ++++++++---- s/x86.ss | 2 ++ s/x86_64.ss | 6 +++++- 6 files changed, 61 insertions(+), 9 deletions(-) diff --git a/LOG b/LOG index 52c55e60c0..7bec4b119f 100644 --- a/LOG +++ b/LOG @@ -1021,3 +1021,7 @@ get-mode, and path-absolute more consistent with https://docs.microsoft.com/en-us/windows/desktop/FileIO/naming-a-file 6.ss, 6.ms, io.stex, release_notes.stex +- fix handling of calling code's address for locking around a callable, + where the cp register copy in the thread context could be changed + in the callable prep before S_call_help gets it + cpnanopass.ss, x86_64.ss, x86.ss, foreign2.c, foreign.ms diff --git a/mats/foreign.ms b/mats/foreign.ms index 381ec435eb..3b34840cfd 100644 --- a/mats/foreign.ms +++ b/mats/foreign.ms @@ -2516,6 +2516,29 @@ (let ([v ($with-exit-proc (lambda (k) (Sinvoke2 Fcons k 5)))]) (list v (locked-object? Fcons))))) '((#t #f) (#t #f))) + + ;; Make sure the code pointer for a call into a + ;; foreign procedure is correctly saved for locking + ;; when entering a callback as a callable: + (equal? + (let () + (define v 0) + (define call_many_times (foreign-procedure "call_many_times" (void*) void)) + (define work + (lambda (n) + ;; This loop needs to be non-allocating, but + ;; causes varying numbers of ticks + ;; to be used up. + (let loop ([n (bitwise-and n #xFFFF)]) + (unless (zero? n) + (set! v (add1 v)) + (loop (bitwise-arithmetic-shift-right n 1)))))) + (define handler (foreign-callable work (long) void)) + (lock-object handler) + (call_many_times (foreign-callable-entry-point handler)) + v) + 14995143) + ) (machine-case @@ -3021,10 +3044,6 @@ (let ([m (make-mutex)] [done? #f] [ok? #t]) - (define object->addr - (foreign-procedure "(cs)fxmul" - (scheme-object uptr) - uptr)) (fork-thread (lambda () (let loop ([i 10]) (unless (zero? i) diff --git a/mats/foreign2.c b/mats/foreign2.c index 03b7ea6f95..d69b4898ab 100644 --- a/mats/foreign2.c +++ b/mats/foreign2.c @@ -424,3 +424,22 @@ EXPORT i64 ifoo64a(i64 a, i64 b, i64 c, i64 d, i64 e, i64 f, i64 g) { EXPORT i64 ifoo64b(i32 x, i64 a, i64 b, i64 c, i64 d, i64 e, i64 f, i64 g) { return (i64)x + (a - b) + (c - d) + (e - f) + g; } + +EXPORT void call_many_times(void (*f)(iptr)) +{ + int x; + iptr a = 1, b = 3, c = 5, d = 7; + iptr e = 1, g = 3, h = 5, i = 7; + iptr j = 1, k = 3, l = 5, m = 7; + iptr big = (((iptr)1) << ((8 * sizeof(iptr)) - 2)); + + /* The intent of the loop is to convince the C compiler to store + something in the same register used for CP (so, compile with + optimization). */ + for (x = 0; x < 1000000; x++) { + f(big|(a+e+j)); + a = b; b = c; c = d; d = e; + e = g; g = h; h = i; i = j; + j = k+2; k = l+2; l = m+2; m = m+2; + } +} diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss index 19699e1cb1..310054441b 100644 --- a/s/cpnanopass.ss +++ b/s/cpnanopass.ss @@ -10730,9 +10730,12 @@ ; 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) ; save just the required registers, e.g., %sfp - (out %ac0 %ac1 %cp %xp %yp %ts %td scheme-args extra-regs)) + (in %cp) + (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) @@ -10748,8 +10751,8 @@ (set! ,(ref-reg %ac1) (literal ,(make-info-literal #f 'object 0 0))) (set! ,(ref-reg %ts) (label-ref ,self-label 0)) ; for locking ,(save-scheme-state - (in %ac0 %ac1 %ts) - (out %cp %xp %yp %td scheme-args extra-regs)) + (in %ac0 %ac1 %ts %cp) + (out %xp %yp %td scheme-args extra-regs)) ; Scall-{any,one}-results calls the Scheme implementation of the ; callable, locking this callable wrapper (as communicated in %ts) ; until just before returning @@ -10757,6 +10760,7 @@ ,(restore-scheme-state (in %ac0) (out %ac1 %cp %xp %yp %ts %td scheme-args extra-regs)) + ; assuming no use of %cp from here on that could get saved into `(%tc-ref cp)`: ,(Scheme->C-for-result result-type c-result %ac0) ,(c-return))))))))))) (define handle-do-rest diff --git a/s/x86.ss b/s/x86.ss index 581b1380aa..d64f9de1da 100644 --- a/s/x86.ss +++ b/s/x86.ss @@ -2882,6 +2882,7 @@ locs)) get-result (lambda () + (define callee-save-regs (list %ebx %edi %esi %ebp)) (in-context Tail ((lambda (e) (if adjust-active? @@ -2913,5 +2914,6 @@ ;; after popping the return address (make-info-c-return 4) null-info) + ,callee-save-regs ... ,result-regs ...))))))))))))))) ) diff --git a/s/x86_64.ss b/s/x86_64.ss index 82ca94d9fe..f769f1a6fb 100644 --- a/s/x86_64.ss +++ b/s/x86_64.ss @@ -3410,6 +3410,10 @@ locs)) get-result (lambda () + (define callee-save-regs + (if-feature windows + (list %rbx %rbp %rdi %rsi %r12 %r13 %r14 %r15) + (list %rbx %rbp %r12 %r13 %r14 %r15))) (in-context Tail ((lambda (e) (if adjust-active? @@ -3441,5 +3445,5 @@ (set! ,%rbp ,(%inline pop)) (set! ,%rbx ,(%inline pop)) (set! ,%sp ,(%inline + ,%sp (immediate 136))))) - (asm-c-return ,null-info ,result-regs ...)))))))))))))) + (asm-c-return ,null-info ,callee-save-regs ... ,result-regs ...)))))))))))))) )