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

cs: faster path for simple foreign calls

Browse Source
This commit is contained in:
Matthew Flatt 2018-12-07 09:53:49 -07:00
parent 45046f4c5d
commit 0f413d38c5
2 changed files with 128 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
pkgs/racket-doc/scribblings/foreign/unexported.scrbl
View File

@ -14,7 +14,7 @@ the Racket built-in @racketmodname['#%foreign] module. The
@racketmodname['#%foreign] module is not intended for direct use, but @racketmodname['#%foreign] module is not intended for direct use, but
it exports the following procedures (among others). it exports the following procedures (among others).
@defproc[(ffi-obj [objname (or/c string? bytes? symbol?)] @defproc[(ffi-obj [objname bytes?]
[lib (or/c ffi-lib? path-string? #f)]) [lib (or/c ffi-lib? path-string? #f)])
ffi-obj?]{ ffi-obj?]{
@ -25,7 +25,7 @@ then @racket[ffi-lib] is used to create a library object.}
@defproc*[([(ffi-obj? [x any/c]) boolean?] @defproc*[([(ffi-obj? [x any/c]) boolean?]
[(ffi-obj-lib [obj ffi-obj?]) ffi-lib?] [(ffi-obj-lib [obj ffi-obj?]) ffi-lib?]
[(ffi-obj-name [obj ffi-obj?]) string?])]{ [(ffi-obj-name [obj ffi-obj?]) bytes?])]{
A predicate for objects returned by @racket[ffi-obj], and accessor A predicate for objects returned by @racket[ffi-obj], and accessor
functions that return its corresponding library object and name. functions that return its corresponding library object and name.

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

@ -121,6 +121,11 @@
(and (authentic-cpointer? p) (and (authentic-cpointer? p)
(#%vector? (cpointer-memory p)))) (#%vector? (cpointer-memory p))))
;; Works on unwrapped cpointers:
(define (cpointer->name proc-p)
(and (ffi-obj? proc-p)
(string->symbol (utf8->string (cpointer/ffi-obj-name proc-p)))))
;; ---------------------------------------- ;; ----------------------------------------
;; Hack: use `s_fxmul` as an identity function ;; Hack: use `s_fxmul` as an identity function
@ -167,6 +172,12 @@
(raise-arguments-error 'internal-error "bad case extracting a cpointer address" (raise-arguments-error 'internal-error "bad case extracting a cpointer address"
"value" p)])) "value" p)]))
(define (cpointer-needs-lock? p)
(cond
[(bytes? p) #t]
[(authentic-cpointer? p) (not (integer? (cpointer-memory p)))]
[else #f]))
;; Like `cpointer-address`, but allows a raw foreign ;; Like `cpointer-address`, but allows a raw foreign
;; address to pass through: ;; address to pass through:
(define (cpointer*-address p) ; call with GC disabled (define (cpointer*-address p) ; call with GC disabled
@ -1531,50 +1542,120 @@
[async-callback-queue (and (procedure? async-apply) (current-async-callback-queue))]) [async-callback-queue (and (procedure? async-apply) (current-async-callback-queue))])
(cond (cond
[call? [call?
(lambda (to-wrap) (cond
(let* ([proc-p (unwrap-cpointer 'ffi-call to-wrap)]) [(and (not ret-id)
(lambda args (not blocking?)
(let* ([args (map (lambda (orig-arg in-type) (not save-errno)
(let ([arg (s->c in-type orig-arg)]) (#%andmap (lambda (in-type)
(if (and (cpointer? arg) (case (ctype-host-rep in-type)
(not (eq? 'scheme-object (ctype-host-rep in-type)))) [(scheme-object struct union) #f]
(let ([p (unwrap-cpointer 'ffi-call arg)]) [else #t]))
(when (and (cpointer-nonatomic? p) in-types))
(not (cpointer/cell? p))) (lambda (to-wrap)
(disallow-nonatomic-pointer 'argument orig-arg proc-p)) (let* ([proc-p (unwrap-cpointer 'ffi-call to-wrap)]
p) [proc (and (not (cpointer-needs-lock? proc-p))
arg))) (gen-proc (cpointer-address proc-p)))]
args in-types)] [unwrap (lambda (arg in-type)
[r (let ([ret-ptr (and ret-id (let ([c (s->c in-type arg)])
;; result is a struct type; need to allocate space for it (if (cpointer? c)
(make-bytevector ret-size))]) (unwrap-cpointer 'ffi-call c)
(with-interrupts-disabled c)))]
(when blocking? (currently-blocking? #t)) [unpack (lambda (arg in-type)
(let ([r (#%apply (gen-proc (cpointer-address proc-p)) (case (array-rep-to-pointer-rep (ctype-host-rep in-type))
(append [(void*) (cpointer-address arg)]
(if ret-ptr [else arg]))])
(list (ret-maker (memory-address ret-ptr))) (do-procedure-reduce-arity-mask
'()) (cond
(map (lambda (arg in-type maker) [proc
(let ([host-rep (array-rep-to-pointer-rep (case-lambda
(ctype-host-rep in-type))]) [()
(case host-rep (c->s out-type (with-interrupts-disabled (proc)))]
[(void*) (cpointer-address arg)] [(a)
[(struct union) (let ([a (unwrap a (car in-types))])
(maker (cpointer-address arg))] (c->s out-type (with-interrupts-disabled (proc (unpack a (car in-types))))))]
[else arg]))) [(a b)
args in-types arg-makers)))]) (let ([a (unwrap a (car in-types))]
(when blocking? (currently-blocking? #f)) [b (unwrap b (cadr in-types))])
(case save-errno (c->s out-type (with-interrupts-disabled
[(posix) (thread-cell-set! errno-cell (get-errno))] (proc (unpack a (car in-types)) (unpack b (cadr in-types))))))]
[(windows) (thread-cell-set! errno-cell (get-last-error))]) [(a b c)
(cond (let ([a (unwrap a (car in-types))]
[ret-ptr [b (unwrap b (cadr in-types))]
(make-cpointer ret-ptr #f)] [c (unwrap c (caddr in-types))])
[(eq? (ctype-our-rep out-type) 'gcpointer) (c->s out-type (with-interrupts-disabled
(addr->gcpointer-memory r)] (proc (unpack a (car in-types))
[else r]))))]) (unpack b (cadr in-types))
(c->s out-type r)))))] (unpack c (caddr in-types))))))]
[(a b c d)
(let ([a (unwrap a (car in-types))]
[b (unwrap b (cadr in-types))]
[c (unwrap c (caddr in-types))]
[d (unwrap d (cadddr in-types))])
(c->s out-type (with-interrupts-disabled
(proc (unpack a (car in-types))
(unpack b (cadr in-types))
(unpack c (caddr in-types))
(unpack d (cadddr in-types))))))]
[args
(let ([args (map (lambda (a t) (unwrap a t)) args in-types)])
(c->s out-type (with-interrupts-disabled
(#%apply proc (map (lambda (a t) (unpack a t)) args in-types)))))])]
[else
(lambda args
(let ([args (map (lambda (a t) (unwrap a t)) args in-types)])
(c->s out-type (with-interrupts-disabled
(#%apply (gen-proc (cpointer-address proc-p))
(map (lambda (a t) (unpack a t)) args in-types))))))])
(fxsll 1 (length in-types))
(cpointer->name proc-p))))]
[else
(lambda (to-wrap)
(let* ([proc-p (unwrap-cpointer 'ffi-call to-wrap)])
(do-procedure-reduce-arity-mask
(lambda args
(let* ([args (map (lambda (orig-arg in-type)
(let ([arg (s->c in-type orig-arg)])
(if (and (cpointer? arg)
(not (eq? 'scheme-object (ctype-host-rep in-type))))
(let ([p (unwrap-cpointer 'ffi-call arg)])
(when (and (cpointer-nonatomic? p)
(not (cpointer/cell? p)))
(disallow-nonatomic-pointer 'argument orig-arg proc-p))
p)
arg)))
args in-types)]
[r (let ([ret-ptr (and ret-id
;; result is a struct type; need to allocate space for it
(make-bytevector ret-size))])
(with-interrupts-disabled
(when blocking? (currently-blocking? #t))
(let ([r (#%apply (gen-proc (cpointer-address proc-p))
(append
(if ret-ptr
(list (ret-maker (memory-address ret-ptr)))
'())
(map (lambda (arg in-type maker)
(let ([host-rep (array-rep-to-pointer-rep
(ctype-host-rep in-type))])
(case host-rep
[(void*) (cpointer-address arg)]
[(struct union)
(maker (cpointer-address arg))]
[else arg])))
args in-types arg-makers)))])
(when blocking? (currently-blocking? #f))
(case save-errno
[(posix) (thread-cell-set! errno-cell (get-errno))]
[(windows) (thread-cell-set! errno-cell (get-last-error))])
(cond
[ret-ptr
(make-cpointer ret-ptr #f)]
[(eq? (ctype-our-rep out-type) 'gcpointer)
(addr->gcpointer-memory r)]
[else r]))))])
(c->s out-type r)))
(fxsll 1 (length in-types))
(cpointer->name proc-p))))])]
[else ; callable [else ; callable
(lambda (to-wrap) (lambda (to-wrap)
(gen-proc (lambda args ; if ret-id, includes an extra initial argument to receive the result (gen-proc (lambda args ; if ret-id, includes an extra initial argument to receive the result
@ -1634,8 +1715,7 @@
(define (disallow-nonatomic-pointer what arg proc-p) (define (disallow-nonatomic-pointer what arg proc-p)
(raise-arguments-error 'foreign-call "cannot pass non-atomic pointer to a function" (raise-arguments-error 'foreign-call "cannot pass non-atomic pointer to a function"
"pointer" arg "pointer" arg
"function" (or (and (ffi-obj? proc-p) "function" (or (cpointer->name proc-p)
(cpointer/ffi-obj-name proc-p))
'unknown))) 'unknown)))
;; Rely on the fact that a virtual register defaults to 0 to detect a ;; Rely on the fact that a virtual register defaults to 0 to detect a