suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cs: ensure that arguments to foreign functions are retained

Browse Source 
Make a call to a foreign function behave as in traditional Racket: the
arguments are considered reachable un their unwrapped forms until the
foreign function returns.
This commit is contained in:
Matthew Flatt 2019-01-01 16:17:25 -07:00
parent 709f327e4e
commit 9731394e2a
3 changed files with 114 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
pkgs/racket-test-core/tests/racket/foreign-test.c
View File

@ -324,3 +324,14 @@ X int check_multiple_of_ten(int v) {
return -1; return -1;
} }
} }
int sum_after_callback(int *a, int n, void (*cb)()) {
int i, s = 0;
cb();
for (i = 0; i < n; i++)
s += a[i];
return s;
}

22
pkgs/racket-test-core/tests/racket/foreign-test.rktl
View File

@ -616,7 +616,7 @@
cast q _stuff-pointer _intptr)) cast q _stuff-pointer _intptr))
;; test 'interior allocation mode ;; test 'interior allocation mode
(let () (when (eq? 'racket (system-type 'vm))
;; Example by Ron Garcia ;; Example by Ron Garcia
(define-struct data (a b)) (define-struct data (a b))
(define (cbox s) (define (cbox s)
@ -629,6 +629,26 @@
(collect-garbage) (collect-garbage)
(test 1 data-a (cunbox cb1))) (test 1 data-a (cunbox cb1)))
;; Make sure calling a foreign function retains the function arguments
;; until the foreign function returns, even if it invokes a callback
(let ()
(define sum_after_callback
(get-ffi-obj 'sum_after_callback test-lib (_fun _pointer _int (_fun -> _void) -> _int)))
(define N 1000)
(test 499500
'sum-after-callback
(let ([n (malloc 'atomic-interior _int N)])
(for ([i (in-range N)])
(ptr-set! n _int i i))
(sum_after_callback n N (lambda ()
(collect-garbage)
(collect-garbage)
(collect-garbage)
(for ([i 100])
(let ([m (malloc _int N)])
(for ([i (in-range N)])
(ptr-set! m _int i 0)))))))))
(let () (let ()
(struct foo (ptr) (struct foo (ptr)
#:property prop:cpointer 0) #:property prop:cpointer 0)

82
racket/src/cs/rumble/foreign.ss
View File

@ -1456,6 +1456,16 @@
;; For sanity checking of callbacks during a blocking callout: ;; For sanity checking of callbacks during a blocking callout:
(define-virtual-register currently-blocking? #f) (define-virtual-register currently-blocking? #f)
(define-syntax-rule (retain v ... e)
;; Make sure that the `v ...` stay live until `e` produces a result,
;; so uses of the FFI can rely on passing an argument to a foreign
;; function as retaining the argument until the function returns.
(let ([result e])
;; This comparsion will never be true, but the
;; compiler and GC don't know that:
(when (eq? v none2) (raise none2)) ...
result))
(define (ffi-call/callable call? in-types out-type abi save-errno blocking? atomic? async-apply) (define (ffi-call/callable call? in-types out-type abi save-errno blocking? atomic? async-apply)
(let* ([conv (case abi (let* ([conv (case abi
[(stdcall) '__stdcall] [(stdcall) '__stdcall]
@ -1570,49 +1580,61 @@
(case-lambda (case-lambda
[() [()
(c->s out-type (with-interrupts-disabled (proc)))] (c->s out-type (with-interrupts-disabled (proc)))]
[(a) [(orig-a)
(let ([a (unwrap a (car in-types))]) (let ([a (unwrap orig-a (car in-types))])
(c->s out-type (with-interrupts-disabled (proc (unpack a (car in-types))))))] (c->s out-type (retain
[(a b) orig-a
(let ([a (unwrap a (car in-types))] (with-interrupts-disabled (proc (unpack a (car in-types)))))))]
[b (unwrap b (cadr in-types))]) [(orig-a orig-b)
(c->s out-type (with-interrupts-disabled (let ([a (unwrap orig-a (car in-types))]
(proc (unpack a (car in-types)) (unpack b (cadr in-types))))))] [b (unwrap orig-b (cadr in-types))])
[(a b c) (c->s out-type (retain
(let ([a (unwrap a (car in-types))] orig-a orig-b
[b (unwrap b (cadr in-types))] (with-interrupts-disabled
[c (unwrap c (caddr in-types))]) (proc (unpack a (car in-types)) (unpack b (cadr in-types)))))))]
[(orig-a orig-b orig-c)
(let ([a (unwrap orig-a (car in-types))]
[b (unwrap orig-b (cadr in-types))]
[c (unwrap orig-c (caddr in-types))])
(c->s out-type (with-interrupts-disabled (c->s out-type (with-interrupts-disabled
(retain
orig-a orig-b orig-c
(proc (unpack a (car in-types)) (proc (unpack a (car in-types))
(unpack b (cadr in-types)) (unpack b (cadr in-types))
(unpack c (caddr in-types))))))] (unpack c (caddr in-types)))))))]
[(a b c d) [(orig-a orig-b orig-c orig-d)
(let ([a (unwrap a (car in-types))] (let ([a (unwrap orig-a (car in-types))]
[b (unwrap b (cadr in-types))] [b (unwrap orig-b (cadr in-types))]
[c (unwrap c (caddr in-types))] [c (unwrap orig-c (caddr in-types))]
[d (unwrap d (cadddr in-types))]) [d (unwrap orig-d (cadddr in-types))])
(c->s out-type (with-interrupts-disabled (c->s out-type (retain
orig-a orig-b orig-c orig-d
(with-interrupts-disabled
(proc (unpack a (car in-types)) (proc (unpack a (car in-types))
(unpack b (cadr in-types)) (unpack b (cadr in-types))
(unpack c (caddr in-types)) (unpack c (caddr in-types))
(unpack d (cadddr in-types))))))] (unpack d (cadddr in-types)))))))]
[args [orig-args
(let ([args (map (lambda (a t) (unwrap a t)) args in-types)]) (let ([args (map (lambda (a t) (unwrap a t)) orig-args in-types)])
(c->s out-type (with-interrupts-disabled (c->s out-type (with-interrupts-disabled
(#%apply proc (map (lambda (a t) (unpack a t)) args in-types)))))])] (retain
orig-args
(#%apply proc (map (lambda (a t) (unpack a t)) args in-types))))))])]
[else [else
(lambda args (lambda orig-args
(let ([args (map (lambda (a t) (unwrap a t)) args in-types)]) (let ([args (map (lambda (a t) (unwrap a t)) orig-args in-types)])
(c->s out-type (with-interrupts-disabled (c->s out-type (with-interrupts-disabled
(retain
orig-args
(#%apply (gen-proc (cpointer-address proc-p)) (#%apply (gen-proc (cpointer-address proc-p))
(map (lambda (a t) (unpack a t)) args in-types))))))]) (map (lambda (a t) (unpack a t)) args in-types)))))))])
(fxsll 1 (length in-types)) (fxsll 1 (length in-types))
(cpointer->name proc-p))))] (cpointer->name proc-p))))]
[else [else
(lambda (to-wrap) (lambda (to-wrap)
(let* ([proc-p (unwrap-cpointer 'ffi-call to-wrap)]) (let* ([proc-p (unwrap-cpointer 'ffi-call to-wrap)])
(do-procedure-reduce-arity-mask (do-procedure-reduce-arity-mask
(lambda args (lambda orig-args
(let* ([args (map (lambda (orig-arg in-type) (let* ([args (map (lambda (orig-arg in-type)
(let ([arg (s->c in-type orig-arg)]) (let ([arg (s->c in-type orig-arg)])
(if (and (cpointer? arg) (if (and (cpointer? arg)
@ -1623,12 +1645,14 @@
(disallow-nonatomic-pointer 'argument orig-arg proc-p)) (disallow-nonatomic-pointer 'argument orig-arg proc-p))
p) p)
arg))) arg)))
args in-types)] orig-args in-types)]
[r (let ([ret-ptr (and ret-id [r (let ([ret-ptr (and ret-id
;; result is a struct type; need to allocate space for it ;; result is a struct type; need to allocate space for it
(make-bytevector ret-size))]) (make-bytevector ret-size))])
(with-interrupts-disabled (with-interrupts-disabled
(when blocking? (currently-blocking? #t)) (when blocking? (currently-blocking? #t))
(retain
orig-args
(let ([r (#%apply (gen-proc (cpointer-address proc-p)) (let ([r (#%apply (gen-proc (cpointer-address proc-p))
(append (append
(if ret-ptr (if ret-ptr
@ -1652,7 +1676,7 @@
(make-cpointer ret-ptr #f)] (make-cpointer ret-ptr #f)]
[(eq? (ctype-our-rep out-type) 'gcpointer) [(eq? (ctype-our-rep out-type) 'gcpointer)
(addr->gcpointer-memory r)] (addr->gcpointer-memory r)]
[else r]))))]) [else r])))))])
(c->s out-type r))) (c->s out-type r)))
(fxsll 1 (length in-types)) (fxsll 1 (length in-types))
(cpointer->name proc-p))))])] (cpointer->name proc-p))))])]