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

ffi/objc: add with-blocking-tell

Browse Source 
Add a way to declare an Objective-C method call as blocking in the
sense of the `#:blocking?` argument to `_cprocedure`.

Usingf `with-blocking-tell` should allow the Cocoa backend for
`racket/gui` to wait for events in the main place without blocking
other places.
This commit is contained in:
Matthew Flatt 2018-09-09 11:33:50 -06:00
parent 9776e4cd8e
commit 138e6c11c0
2 changed files with 82 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
pkgs/racket-doc/scribblings/foreign/objc.scrbl
View File

@ -323,6 +323,16 @@ retained as long as the block remains in use.
@history[#:added "6.3"]} @history[#:added "6.3"]}
@defform[(with-blocking-tell form ...+)]{
Causes any @racket[tell], @racket[tellv], or @racket[super-tell]
expression syntactically within the @racket[form]s to be blocking in
the sense of the @racket[#:blocking?] argument to
@racket[_cprocedure]. Otherwise, @racket[(with-blocking-tell form
...+)] is equivalent to @racket[(let () form ...+)].
@history[#:added "7.0.0.19"]}
@; ---------------------------------------------------------------------- @; ----------------------------------------------------------------------
@section{Raw Runtime Functions} @section{Raw Runtime Functions}
@ -419,7 +429,25 @@ Like @racket[objc_msgSend/typed], but for a super call.}
Constructor and FFI C type use for super calls.} Constructor and FFI C type use for super calls.}
@table-of-contents[] @deftogether[(
@defproc[((objc_msgSend/typed/blocking [types (vector/c result-ctype arg-ctype ...)])
[obj _id]
[sel _SEL]
[arg any/c])
any/c]
@defproc[((objc_msgSendSuper/typed/blocking [types (vector/c result-ctype arg-ctype ...)])
[super _objc_super]
[sel _SEL]
[arg any/c])
any/c]
)]{
The same as @racket[objc_msgSend/typed] and
@racket[objc_msgSendSuper/typed], but specifying that the send should
be blocking in the sense of the @racket[#:blocking?] argument to
@racket[_cprocedure].
@history[#:added "7.0.0.19"]}
@; ---------------------------------------------------------------------- @; ----------------------------------------------------------------------

69
racket/collects/ffi/unsafe/objc.rkt
View File

@ -290,7 +290,7 @@
(define-syntax-rule (as-atomic e) (define-syntax-rule (as-atomic e)
(begin (start-atomic) (begin0 e (end-atomic)))) (begin (start-atomic) (begin0 e (end-atomic))))
(define (lookup-send types msgSends msgSend msgSend_fpret msgSend_stret first-arg-type) (define (lookup-send blocking? types msgSends msgSend msgSend_fpret msgSend_stret first-arg-type)
;; First type in `types' vector is the result type ;; First type in `types' vector is the result type
(or (as-atomic (hash-ref msgSends types #f)) (or (as-atomic (hash-ref msgSends types #f))
(let ([ret-layout (ctype->layout (vector-ref types 0))]) (let ([ret-layout (ctype->layout (vector-ref types 0))])
@ -299,6 +299,7 @@
;; Structure return type: ;; Structure return type:
(let* ([pre-m (function-ptr msgSend_stret (let* ([pre-m (function-ptr msgSend_stret
(_cprocedure (_cprocedure
#:blocking? blocking?
(list* _pointer first-arg-type _SEL (cdr (vector->list types))) (list* _pointer first-arg-type _SEL (cdr (vector->list types)))
_void))] _void))]
[m (lambda args [m (lambda args
@ -313,6 +314,7 @@
msgSend_fpret msgSend_fpret
msgSend) msgSend)
(_cprocedure (_cprocedure
#:blocking? blocking?
(list* first-arg-type _SEL (cdr (vector->list types))) (list* first-arg-type _SEL (cdr (vector->list types)))
(vector-ref types 0)))]) (vector-ref types 0)))])
(as-atomic (hash-set! msgSends types m)) (as-atomic (hash-set! msgSends types m))
@ -320,14 +322,33 @@
(define msgSends (make-weak-hash)) (define msgSends (make-weak-hash))
(define (objc_msgSend/typed types) (define (objc_msgSend/typed types)
(lookup-send types msgSends objc_msgSend objc_msgSend_fpret objc_msgSend_stret _id)) (lookup-send #f types msgSends objc_msgSend objc_msgSend_fpret objc_msgSend_stret _id))
(provide objc_msgSend/typed) (provide objc_msgSend/typed)
(define msgSendSupers (make-weak-hash)) (define msgSendSupers (make-weak-hash))
(define (objc_msgSendSuper/typed types) (define (objc_msgSendSuper/typed types)
(lookup-send types msgSendSupers objc_msgSendSuper objc_msgSendSuper_fpret objc_msgSendSuper_stret _pointer)) (lookup-send #f types msgSendSupers objc_msgSendSuper objc_msgSendSuper_fpret objc_msgSendSuper_stret _pointer))
(provide objc_msgSendSuper/typed) (provide objc_msgSendSuper/typed)
(define msgSends/blocking (make-weak-hash))
(define (objc_msgSend/typed/blocking types)
(lookup-send #t types msgSends/blocking objc_msgSend objc_msgSend_fpret objc_msgSend_stret _id))
(provide objc_msgSend/typed/blocking)
(define msgSendSupers/blocking (make-weak-hash))
(define (objc_msgSendSuper/typed/blocking types)
(lookup-send #t types msgSendSupers/blocking objc_msgSendSuper objc_msgSendSuper_fpret objc_msgSendSuper_stret _pointer))
(provide objc_msgSendSuper/typed/blocking)
(define-syntax-parameter objc_msgSend/typed* (make-rename-transformer #'objc_msgSend/typed))
(define-syntax-parameter objc_msgSendSuper/typed* (make-rename-transformer #'objc_msgSendSuper/typed))
(define-syntax-rule (with-blocking-tell e0 e ...)
(syntax-parameterize ([objc_msgSend/typed* (make-rename-transformer #'objc_msgSend/typed/blocking)]
[objc_msgSendSuper/typed* (make-rename-transformer #'objc_msgSendSuper/typed/blocking)])
e0 e ...))
(provide with-blocking-tell)
;; ---------------------------------------- ;; ----------------------------------------
(provide import-class) (provide import-class)
@ -529,23 +550,26 @@
"method identifier missing" "method identifier missing"
stx)] stx)]
[(_ #:type t target method) [(_ #:type t target method)
(and (not (keyword? (syntax-e #'target)))
(identifier? #'method))
(let ([m #'method]) (let ([m #'method])
(check-method-name m stx) (check-method-name m stx)
(quasisyntax/loc stx (quasisyntax/loc stx
((objc_msgSend/typed (type-vector 'method t)) target #,(register-selector (syntax-e m)))))] ((objc_msgSend/typed* (type-vector 'method t)) target #,(register-selector (syntax-e m)))))]
[(_ target method) [(_ target method)
(not (keyword? (syntax-e #'target))) (and (not (keyword? (syntax-e #'target)))
(identifier? #'method))
(let ([m #'method]) (let ([m #'method])
(check-method-name m stx) (check-method-name m stx)
(quasisyntax/loc stx (quasisyntax/loc stx
((objc_msgSend/typed (type-vector 'method _id)) target #,(register-selector (syntax-e m)))))] ((objc_msgSend/typed* (type-vector 'method _id)) target #,(register-selector (syntax-e m)))))]
[(_ #:type result-type target method/arg ...) [(_ #:type result-type target method/arg ...)
(build-send stx #'result-type (build-send stx #'result-type
#'objc_msgSend/typed #'(target) #'objc_msgSend/typed* #'(target)
#'(method/arg ...))] #'(method/arg ...))]
[(_ target method/arg ...) [(_ target method/arg ...)
(build-send stx #'_id (build-send stx #'_id
#'objc_msgSend/typed #'(target) #'objc_msgSend/typed* #'(target)
#'(method/arg ...))])) #'(method/arg ...))]))
(define-syntax-rule (tellv a ...) (define-syntax-rule (tellv a ...)
@ -876,10 +900,16 @@
[(kind result-type (id arg ...) body0 body ...) [(kind result-type (id arg ...) body0 body ...)
(loop stx (loop stx
(with-syntax ([async (with-syntax ([async
(if (eq? (syntax-e #'id) 'dealloc) (cond
;; so that objects can be destroyed in foreign threads: [(eq? (syntax-e #'id) 'dealloc)
#'apply-directly ;; so that objects can be destroyed in foreign threads:
#'#f)]) #'apply-directly]
[(eq? (system-type 'vm) 'chez-scheme)
;; to cooperate with blocking callouts, we need a non-#f
;; `async-apply`
#'complain-apply-foreign-thread]
[else
#'#f])])
(syntax/loc m (syntax/loc m
(kind #:async-apply async result-type (id arg ...) body0 body ...))))] (kind #:async-apply async result-type (id arg ...) body0 body ...))))]
[else (raise-syntax-error #f [else (raise-syntax-error #f
@ -889,6 +919,13 @@
(define (apply-directly f) (f)) (define (apply-directly f) (f))
(define (complain-apply-foreign-thread f)
;; We'd like to complain, but we' not in a context where there's a
;; valid way to complain. Try logging an error, and just maybe that
;; will get some information out.
(log-error "callback in unexpected thread")
(void))
(define methods (make-hasheq)) (define methods (make-hasheq))
(define (save-method! m) (define (save-method! m)
;; Methods are never GCed, since classes are never unregistered ;; Methods are never GCed, since classes are never unregistered
@ -916,7 +953,7 @@
(let ([m #'method]) (let ([m #'method])
(check-method-name m stx) (check-method-name m stx)
(quasisyntax/loc stx (quasisyntax/loc stx
((objc_msgSendSuper/typed (type-vector 'method t)) ((objc_msgSendSuper/typed* (type-vector 'method t))
(make-objc_super self super-class) (make-objc_super self super-class)
#,(register-selector (syntax-e m)))))] #,(register-selector (syntax-e m)))))]
[(_ method) [(_ method)
@ -924,17 +961,17 @@
(let ([m #'method]) (let ([m #'method])
(check-method-name m stx) (check-method-name m stx)
(quasisyntax/loc stx (quasisyntax/loc stx
((objc_msgSendSuper/typed (type-vector 'method _id)) ((objc_msgSendSuper/typed* (type-vector 'method _id))
(make-objc_super self super-class) (make-objc_super self super-class)
#,(register-selector (syntax-e m)))))] #,(register-selector (syntax-e m)))))]
[(_ #:type result-type method/arg ...) [(_ #:type result-type method/arg ...)
(build-send stx #'result-type (build-send stx #'result-type
#'objc_msgSendSuper/typed #'objc_msgSendSuper/typed*
#'((make-objc_super self super-class)) #'((make-objc_super self super-class))
#'(method/arg ...))] #'(method/arg ...))]
[(_ method/arg ...) [(_ method/arg ...)
(build-send stx #'_id (build-send stx #'_id
#'objc_msgSendSuper/typed #'objc_msgSendSuper/typed*
#'((make-objc_super self super-class)) #'((make-objc_super self super-class))
#'(method/arg ...))])) #'(method/arg ...))]))