ffi/unsafe/objc: remove -A'/+A', add `#:async-apply'
Another run at the problem 57516164de was meant to solve. The
new solution just gives up when a `drawRect:' method is called
in the wrong thread, which might create refresh glitches but
avoids a deadlock in the case that the Racket thread is blocked
on the update happening in the foreign thread.
This commit is contained in:
Matthew Flatt
parent
bba223a9fe
commit
ca0418d47d
|
|
@ -750,20 +750,17 @@
|
|||
(define-syntax (add-method stx)
|
||||
(syntax-case stx ()
|
||||
[(_ whole-stx cls superclass-id m)
|
||||
(let ([stx #'whole-stx])
|
||||
(syntax-case #'m ()
|
||||
[(kind result-type (id arg ...) body0 body ...)
|
||||
(let loop ([stx #'whole-stx] [m #'m])
|
||||
(syntax-case m ()
|
||||
[(kind #:async-apply async result-type (id arg ...) body0 body ...)
|
||||
(or (free-identifier=? #'kind #'+)
|
||||
(free-identifier=? #'kind #'-)
|
||||
(free-identifier=? #'kind #'+a)
|
||||
(free-identifier=? #'kind #'-a)
|
||||
(free-identifier=? #'kind #'+A)
|
||||
(free-identifier=? #'kind #'-A))
|
||||
(free-identifier=? #'kind #'-a))
|
||||
(let ([id #'id]
|
||||
[args (syntax->list #'(arg ...))]
|
||||
[in-class? (or (free-identifier=? #'kind #'+)
|
||||
(free-identifier=? #'kind #'+a)
|
||||
(free-identifier=? #'kind #'+A))])
|
||||
(free-identifier=? #'kind #'+a))])
|
||||
(when (null? args)
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error #f
|
||||
|
|
@ -789,35 +786,37 @@
|
|||
(super-tell #:type _void dealloc)))]
|
||||
[_ (error "oops")])
|
||||
'())]
|
||||
[(async ...)
|
||||
(if (or (free-identifier=? #'kind #'+A)
|
||||
(free-identifier=? #'kind #'-A)
|
||||
;; so that objects can be destroyed in foreign threads:
|
||||
(eq? (syntax-e id) 'dealloc))
|
||||
#'(#:async-apply apply-directly)
|
||||
#'())]
|
||||
[in-cls (if in-class?
|
||||
#'(object-get-class cls)
|
||||
#'cls)]
|
||||
[atomic? (or (free-identifier=? #'kind #'+a)
|
||||
(free-identifier=? #'kind #'-a)
|
||||
(free-identifier=? #'kind #'+A)
|
||||
(free-identifier=? #'kind #'-A))])
|
||||
(free-identifier=? #'kind #'-a))])
|
||||
(quasisyntax/loc stx
|
||||
(let ([rt result-type]
|
||||
[arg-id arg-type] ...)
|
||||
(void (class_addMethod in-cls
|
||||
(sel_registerName id-str)
|
||||
#,(syntax/loc #'m
|
||||
#,(syntax/loc m
|
||||
(lambda (self-id cmd arg-id ...)
|
||||
(syntax-parameterize ([self (make-id-stx #'self-id)]
|
||||
[super-class (make-id-stx #'superclass-id)]
|
||||
[super-tell do-super-tell])
|
||||
body0 body ...
|
||||
dealloc-body ...)))
|
||||
(_fun #:atomic? atomic? #:keep save-method! async ...
|
||||
(_fun #:atomic? atomic?
|
||||
#:keep save-method!
|
||||
#:async-apply async
|
||||
_id _id arg-type ... -> rt)
|
||||
(generate-layout rt (list arg-id ...)))))))))]
|
||||
[(kind result-type (id arg ...) body0 body ...)
|
||||
(loop stx
|
||||
(with-syntax ([async
|
||||
(if (eq? (syntax-e #'id) 'dealloc)
|
||||
;; so that objects can be destroyed in foreign threads:
|
||||
#'apply-directly
|
||||
#'#f)])
|
||||
(syntax/loc m
|
||||
(kind #:async-apply async result-type (id arg ...) body0 body ...))))]
|
||||
[else (raise-syntax-error #f
|
||||
"bad method form"
|
||||
stx
|
||||
|
|
|
|||
|
|
@ -65,7 +65,8 @@
|
|||
(define-objc-mixin (RacketViewMixin Superclass)
|
||||
#:mixins (KeyMouseTextResponder CursorDisplayer FocusResponder)
|
||||
[wxb]
|
||||
(-A _void (drawRect: [_NSRect r])
|
||||
(-a #:async-apply (box (void))
|
||||
_void (drawRect: [_NSRect r])
|
||||
(when wxb
|
||||
(let ([wx (->wx wxb)])
|
||||
(when wx
|
||||
|
|
@ -98,7 +99,8 @@
|
|||
|
||||
(define-objc-class CornerlessFrameView NSView
|
||||
[]
|
||||
(-A _void (drawRect: [_NSRect r])
|
||||
(-a #:async-apply (box (void))
|
||||
_void (drawRect: [_NSRect r])
|
||||
(let ([ctx (tell NSGraphicsContext currentContext)])
|
||||
(tellv ctx saveGraphicsState)
|
||||
(let ([cg (tell #:type _CGContextRef ctx graphicsPort)]
|
||||
|
|
@ -129,7 +131,8 @@
|
|||
[on?]
|
||||
(-a _void (setFocusState: [_BOOL is-on?])
|
||||
(set! on? is-on?))
|
||||
(-A _void (drawRect: [_NSRect r])
|
||||
(-a #:async-apply (box (void))
|
||||
_void (drawRect: [_NSRect r])
|
||||
(let ([f (tell #:type _NSRect self frame)])
|
||||
(tellv bezel-cell
|
||||
drawWithFrame: #:type _NSRect (make-NSRect (make-NSPoint 2 2)
|
||||
|
|
@ -154,7 +157,8 @@
|
|||
#:mixins (FocusResponder KeyMouseTextResponder CursorDisplayer)
|
||||
#:protocols (NSComboBoxDelegate)
|
||||
[wxb]
|
||||
(-A _void (drawRect: [_NSRect r])
|
||||
(-a #:async-apply (box (void))
|
||||
_void (drawRect: [_NSRect r])
|
||||
(super-tell #:type _void drawRect: #:type _NSRect r)
|
||||
(let ([wx (->wx wxb)])
|
||||
(when wx
|
||||
|
|
|
|||
|
|
@ -22,7 +22,8 @@
|
|||
|
||||
(define-objc-class FrameView NSView
|
||||
[]
|
||||
(-A _void (drawRect: [_NSRect r])
|
||||
(- #:async-apply (box (void))
|
||||
_void (drawRect: [_NSRect r])
|
||||
(let ([ctx (tell NSGraphicsContext currentContext)])
|
||||
(tellv ctx saveGraphicsState)
|
||||
(let ([cg (tell #:type _CGContextRef ctx graphicsPort)]
|
||||
|
|
|
|||
|
|
@ -138,7 +138,7 @@ Defines each @racket[protocol-id] to the protocol (a value with FFI type
|
|||
(eval:alts (import-protocol NSCoding) (void))
|
||||
]}
|
||||
|
||||
@defform/subs[#:literals (+ - +a -a +A -A)
|
||||
@defform/subs[#:literals (+ - +a -a)
|
||||
(define-objc-class class-id superclass-expr
|
||||
maybe-mixins
|
||||
maybe-protocols
|
||||
|
|
@ -148,9 +148,11 @@ Defines each @racket[protocol-id] to the protocol (a value with FFI type
|
|||
(code:line #:mixins (mixin-expr ...))]
|
||||
[maybe-protocols code:blank
|
||||
(code:line #:protocols (protocol-expr ...))]
|
||||
[method (mode result-ctype-expr (method-id) body ...+)
|
||||
(mode result-ctype-expr (arg ...+) body ...+)]
|
||||
[mode + - +a -a +A -A]
|
||||
[method (mode maybe-async result-ctype-expr (method-id) body ...+)
|
||||
(mode maybe-async result-ctype-expr (arg ...+) body ...+)]
|
||||
[mode + - +a -a]
|
||||
[maybe-async code:blank
|
||||
(code:line #:async-apply async-apply-expr)]
|
||||
[arg (code:line method-id [ctype-expr arg-id])])]{
|
||||
|
||||
Defines @racket[class-id] as a new, registered Objective-C class (of
|
||||
|
|
@ -167,17 +169,15 @@ directly when the method @racket[body]s. Outside the object, they can
|
|||
be referenced and set with @racket[get-ivar] and @racket[set-ivar!].
|
||||
|
||||
Each @racket[method] adds or overrides a method to the class (when
|
||||
@racket[mode] is @racket[-], @racket[-a], or @racket[-A]) to be called on instances,
|
||||
@racket[mode] is @racket[-] or @racket[-a]) to be called on instances,
|
||||
or it adds a method to the meta-class (when @racket[mode] is
|
||||
@racket[+], @racket[+a], or @racket[+A]) to be called on the class itself. All
|
||||
@racket[+] or @racket[+a]) to be called on the class itself. All
|
||||
result and argument types must be declared using FFI C types
|
||||
(@seeCtype). When @racket[mode] is @racket[+a] or @racket[-a], the
|
||||
method is called in atomic mode (see @racket[_cprocedure]).
|
||||
When @racket[mode] is @racket[+A] or @racket[-A], the
|
||||
method is called in atomic mode, and it may also be triggered
|
||||
as a result of a foreign call in a foreign thread
|
||||
thread, in which case the foreign thread must wait until the
|
||||
call completes in a Racket thread.
|
||||
An optional @racket[#:async-apply] specification determines how
|
||||
the method works when called from a foreign thread in the
|
||||
same way as for @racket[_cprocedure].
|
||||
|
||||
If a @racket[method] is declared with a single @racket[method-id] and
|
||||
no arguments, then @racket[method-id] must not end with
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user