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

ffi/unsafe/objc: remove -A'/+A', add `#:async-apply'

Browse Source 
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 2013-04-23 11:10:52 -06:00
parent bba223a9fe
commit ca0418d47d
4 changed files with 40 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
collects/ffi/unsafe/objc.rkt
View File

@ -750,20 +750,17 @@
(define-syntax (add-method stx) (define-syntax (add-method stx)
(syntax-case stx () (syntax-case stx ()
[(_ whole-stx cls superclass-id m) [(_ whole-stx cls superclass-id m)
(let ([stx #'whole-stx]) (let loop ([stx #'whole-stx] [m #'m])
(syntax-case #'m () (syntax-case m ()
[(kind result-type (id arg ...) body0 body ...) [(kind #:async-apply async result-type (id arg ...) body0 body ...)
(or (free-identifier=? #'kind #'+) (or (free-identifier=? #'kind #'+)
(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)
(free-identifier=? #'kind #'-A))
(let ([id #'id] (let ([id #'id]
[args (syntax->list #'(arg ...))] [args (syntax->list #'(arg ...))]
[in-class? (or (free-identifier=? #'kind #'+) [in-class? (or (free-identifier=? #'kind #'+)
(free-identifier=? #'kind #'+a) (free-identifier=? #'kind #'+a))])
(free-identifier=? #'kind #'+A))])
(when (null? args) (when (null? args)
(unless (identifier? id) (unless (identifier? id)
(raise-syntax-error #f (raise-syntax-error #f
@ -789,35 +786,37 @@
(super-tell #:type _void dealloc)))] (super-tell #:type _void dealloc)))]
[_ (error "oops")]) [_ (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? [in-cls (if in-class?
#'(object-get-class cls) #'(object-get-class cls)
#'cls)] #'cls)]
[atomic? (or (free-identifier=? #'kind #'+a) [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 (quasisyntax/loc stx
(let ([rt result-type] (let ([rt result-type]
[arg-id arg-type] ...) [arg-id arg-type] ...)
(void (class_addMethod in-cls (void (class_addMethod in-cls
(sel_registerName id-str) (sel_registerName id-str)
#,(syntax/loc #'m #,(syntax/loc m
(lambda (self-id cmd arg-id ...) (lambda (self-id cmd arg-id ...)
(syntax-parameterize ([self (make-id-stx #'self-id)] (syntax-parameterize ([self (make-id-stx #'self-id)]
[super-class (make-id-stx #'superclass-id)] [super-class (make-id-stx #'superclass-id)]
[super-tell do-super-tell]) [super-tell do-super-tell])
body0 body ... body0 body ...
dealloc-body ...))) dealloc-body ...)))
(_fun #:atomic? atomic? #:keep save-method! async ... (_fun #:atomic? atomic?
#:keep save-method!
#:async-apply async
_id _id arg-type ... -> rt) _id _id arg-type ... -> rt)
(generate-layout rt (list arg-id ...)))))))))] (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 [else (raise-syntax-error #f
"bad method form" "bad method form"
stx stx

12
collects/mred/private/wx/cocoa/canvas.rkt
View File

@ -65,7 +65,8 @@
(define-objc-mixin (RacketViewMixin Superclass) (define-objc-mixin (RacketViewMixin Superclass)
#:mixins (KeyMouseTextResponder CursorDisplayer FocusResponder) #:mixins (KeyMouseTextResponder CursorDisplayer FocusResponder)
[wxb] [wxb]
(-A _void (drawRect: [_NSRect r]) (-a #:async-apply (box (void))
_void (drawRect: [_NSRect r])
(when wxb (when wxb
(let ([wx (->wx wxb)]) (let ([wx (->wx wxb)])
(when wx (when wx
@ -98,7 +99,8 @@
(define-objc-class CornerlessFrameView NSView (define-objc-class CornerlessFrameView NSView
[] []
(-A _void (drawRect: [_NSRect r]) (-a #:async-apply (box (void))
_void (drawRect: [_NSRect r])
(let ([ctx (tell NSGraphicsContext currentContext)]) (let ([ctx (tell NSGraphicsContext currentContext)])
(tellv ctx saveGraphicsState) (tellv ctx saveGraphicsState)
(let ([cg (tell #:type _CGContextRef ctx graphicsPort)] (let ([cg (tell #:type _CGContextRef ctx graphicsPort)]
@ -129,7 +131,8 @@
[on?] [on?]
(-a _void (setFocusState: [_BOOL is-on?]) (-a _void (setFocusState: [_BOOL is-on?])
(set! on? 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)]) (let ([f (tell #:type _NSRect self frame)])
(tellv bezel-cell (tellv bezel-cell
drawWithFrame: #:type _NSRect (make-NSRect (make-NSPoint 2 2) drawWithFrame: #:type _NSRect (make-NSRect (make-NSPoint 2 2)
@ -154,7 +157,8 @@
#:mixins (FocusResponder KeyMouseTextResponder CursorDisplayer) #:mixins (FocusResponder KeyMouseTextResponder CursorDisplayer)
#:protocols (NSComboBoxDelegate) #:protocols (NSComboBoxDelegate)
[wxb] [wxb]
(-A _void (drawRect: [_NSRect r]) (-a #:async-apply (box (void))
_void (drawRect: [_NSRect r])
(super-tell #:type _void drawRect: #:type _NSRect r) (super-tell #:type _void drawRect: #:type _NSRect r)
(let ([wx (->wx wxb)]) (let ([wx (->wx wxb)])
(when wx (when wx

3
collects/mred/private/wx/cocoa/panel.rkt
View File

@ -22,7 +22,8 @@
(define-objc-class FrameView NSView (define-objc-class FrameView NSView
[] []
(-A _void (drawRect: [_NSRect r]) (- #:async-apply (box (void))
_void (drawRect: [_NSRect r])
(let ([ctx (tell NSGraphicsContext currentContext)]) (let ([ctx (tell NSGraphicsContext currentContext)])
(tellv ctx saveGraphicsState) (tellv ctx saveGraphicsState)
(let ([cg (tell #:type _CGContextRef ctx graphicsPort)] (let ([cg (tell #:type _CGContextRef ctx graphicsPort)]

22
collects/scribblings/foreign/objc.scrbl
View File

@ -138,7 +138,7 @@ Defines each @racket[protocol-id] to the protocol (a value with FFI type
(eval:alts (import-protocol NSCoding) (void)) (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 (define-objc-class class-id superclass-expr
maybe-mixins maybe-mixins
maybe-protocols maybe-protocols
@ -148,9 +148,11 @@ Defines each @racket[protocol-id] to the protocol (a value with FFI type
(code:line #:mixins (mixin-expr ...))] (code:line #:mixins (mixin-expr ...))]
[maybe-protocols code:blank [maybe-protocols code:blank
(code:line #:protocols (protocol-expr ...))] (code:line #:protocols (protocol-expr ...))]
[method (mode result-ctype-expr (method-id) body ...+) [method (mode maybe-async result-ctype-expr (method-id) body ...+)
(mode result-ctype-expr (arg ...+) body ...+)] (mode maybe-async result-ctype-expr (arg ...+) body ...+)]
[mode + - +a -a +A -A] [mode + - +a -a]
[maybe-async code:blank
(code:line #:async-apply async-apply-expr)]
[arg (code:line method-id [ctype-expr arg-id])])]{ [arg (code:line method-id [ctype-expr arg-id])])]{
Defines @racket[class-id] as a new, registered Objective-C class (of 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!]. be referenced and set with @racket[get-ivar] and @racket[set-ivar!].
Each @racket[method] adds or overrides a method to the class (when 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 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 result and argument types must be declared using FFI C types
(@seeCtype). When @racket[mode] is @racket[+a] or @racket[-a], the (@seeCtype). When @racket[mode] is @racket[+a] or @racket[-a], the
method is called in atomic mode (see @racket[_cprocedure]). method is called in atomic mode (see @racket[_cprocedure]).
When @racket[mode] is @racket[+A] or @racket[-A], the An optional @racket[#:async-apply] specification determines how
method is called in atomic mode, and it may also be triggered the method works when called from a foreign thread in the
as a result of a foreign call in a foreign thread same way as for @racket[_cprocedure].
thread, in which case the foreign thread must wait until the
call completes in a Racket thread.
If a @racket[method] is declared with a single @racket[method-id] and If a @racket[method] is declared with a single @racket[method-id] and
no arguments, then @racket[method-id] must not end with no arguments, then @racket[method-id] must not end with