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

ffi/com: thread safety

Browse Source 
Protect internal data structures via atomic mode.

Merge to v5.3
(cherry picked from commit 572252daec)
This commit is contained in:
Matthew Flatt 2012-08-02 10:57:33 -06:00 committed by Ryan Culpepper
parent 9313bfde31
commit 6ea2c86b88
1 changed files with 154 additions and 140 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
collects/ffi/unsafe/com.rkt
View File

@ -678,9 +678,11 @@
(define (com-get-active-object name)
(init!)
(define clsid (gen->clsid 'com-get-active-object name))
(call-as-atomic
(lambda ()
(define unknown (GetActiveObject clsid))
(and unknown
(make-com-object unknown clsid)))
(make-com-object unknown clsid)))))
(define (check-com-obj who obj)
(unless (com-object? obj)
@ -868,11 +870,13 @@
[else (raise-type-error who "com-object or com-type" obj)]))
(define (do-get-methods who obj inv-kind)
(call-as-atomic
(lambda ()
(define type-info (extract-type-info who obj #t))
(define type-attr (GetTypeAttr type-info))
(begin0
(sort (get-type-names type-info type-attr null inv-kind) string-ci<?)
(ReleaseTypeAttr type-info type-attr)))
(ReleaseTypeAttr type-info type-attr)))))
(define (com-methods obj)
(do-get-methods 'com-methods obj INVOKE_FUNC))
@ -1207,6 +1211,8 @@
0)))
(define (do-get-method-type who obj name inv-kind internal?)
(call-as-atomic
(lambda ()
(define type-info (extract-type-info who obj (not internal?)))
(when (and (= inv-kind INVOKE_FUNC)
(is-dispatch-name? name))
@ -1280,7 +1286,7 @@
'void)]
[(= inv-kind INVOKE_EVENT)
(values null 'void)]))
`(-> ,args ,ret)]))
`(-> ,args ,ret)]))))
(define (com-method-type obj name)
(do-get-method-type 'com-method-type obj name INVOKE_FUNC #f))
@ -1777,7 +1783,9 @@
(define (do-com-invoke who obj name args inv-kind)
(check-com-obj who obj)
(unless (string? name) (raise-type-error who "string" name))
(let ([t (or (do-get-method-type who obj name inv-kind #t)
(let ([t (or (call-as-atomic
(lambda ()
(do-get-method-type who obj name inv-kind #t)))
;; wing it by inferring types from the arguments:
`(-> ,(map arg-to-type args) any))])
(unless (<= (length (filter (lambda (v) (not (and (pair? v) (eq? (car v) 'opt))))
@ -1788,6 +1796,8 @@
(for ([arg (in-list args)]
[type (in-list (cadr t))])
(check-argument 'com-invoke name arg type))
(call-as-atomic
(lambda ()
(define type-desc (get-method-type obj name inv-kind #f)) ; cached
(cond
[(if type-desc
@ -1845,7 +1855,7 @@
[else
(for ([proc (in-list cleanups)]) (proc))
(windows-error (format "~a: failed for ~s" who name) hr)]))]
[else (error "not yet implemented")])))
[else (error "not yet implemented")])))))
(define (com-invoke obj name . args)
(do-com-invoke 'com-invoke obj name args INVOKE_FUNC))
@ -2047,11 +2057,15 @@
(define (com-object-get-iunknown obj)
(check-com-obj 'com-object-get-iunknown obj)
(com-object-get-unknown obj))
(call-as-atomic
(lambda ()
(com-object-get-unknown obj))))
(define (com-object-get-idispatch obj)
(check-com-obj 'com-object-get-idispatch obj)
(com-object-get-dispatch obj))
(call-as-atomic
(lambda ()
(com-object-get-dispatch obj))))
(define (com-iunknown? v) (and (IUnknown? v) #t))
(define (com-idispatch? v) (and (IDispatch? v) #t))