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

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

@ -678,9 +678,11 @@
(define (com-get-active-object name) (define (com-get-active-object name)
(init!) (init!)
(define clsid (gen->clsid 'com-get-active-object name)) (define clsid (gen->clsid 'com-get-active-object name))
(define unknown (GetActiveObject clsid)) (call-as-atomic
(and unknown (lambda ()
(make-com-object unknown clsid))) (define unknown (GetActiveObject clsid))
(and unknown
(make-com-object unknown clsid)))))
(define (check-com-obj who obj) (define (check-com-obj who obj)
(unless (com-object? obj) (unless (com-object? obj)
@ -868,11 +870,13 @@
[else (raise-type-error who "com-object or com-type" obj)])) [else (raise-type-error who "com-object or com-type" obj)]))
(define (do-get-methods who obj inv-kind) (define (do-get-methods who obj inv-kind)
(define type-info (extract-type-info who obj #t)) (call-as-atomic
(define type-attr (GetTypeAttr type-info)) (lambda ()
(begin0 (define type-info (extract-type-info who obj #t))
(sort (get-type-names type-info type-attr null inv-kind) string-ci<?) (define type-attr (GetTypeAttr type-info))
(ReleaseTypeAttr type-info type-attr))) (begin0
(sort (get-type-names type-info type-attr null inv-kind) string-ci<?)
(ReleaseTypeAttr type-info type-attr)))))
(define (com-methods obj) (define (com-methods obj)
(do-get-methods 'com-methods obj INVOKE_FUNC)) (do-get-methods 'com-methods obj INVOKE_FUNC))
@ -1207,80 +1211,82 @@
0))) 0)))
(define (do-get-method-type who obj name inv-kind internal?) (define (do-get-method-type who obj name inv-kind internal?)
(define type-info (extract-type-info who obj (not internal?))) (call-as-atomic
(when (and (= inv-kind INVOKE_FUNC) (lambda ()
(is-dispatch-name? name)) (define type-info (extract-type-info who obj (not internal?)))
(error who "IDispatch methods not available")) (when (and (= inv-kind INVOKE_FUNC)
(define mx-type-desc (is-dispatch-name? name))
(cond (error who "IDispatch methods not available"))
[(com-object? obj) (get-method-type obj name inv-kind (not internal?))] (define mx-type-desc
[else (define x-type-info (cond
(if (= inv-kind INVOKE_EVENT) [(com-object? obj) (get-method-type obj name inv-kind (not internal?))]
(event-type-info-from-com-type obj) [else (define x-type-info
type-info)) (if (= inv-kind INVOKE_EVENT)
(type-desc-from-type-info name inv-kind x-type-info)])) (event-type-info-from-com-type obj)
(cond type-info))
[(not mx-type-desc) (type-desc-from-type-info name inv-kind x-type-info)]))
;; there is no type info (cond
#f] [(not mx-type-desc)
[else ;; there is no type info
(define-values (args ret) #f]
(cond [else
[(function-type-desc? mx-type-desc) (define-values (args ret)
(define func-desc (car (mx-com-type-desc-desc mx-type-desc))) (cond
(define num-actual-params (FUNCDESC-cParams func-desc)) [(function-type-desc? mx-type-desc)
(cond (define func-desc (car (mx-com-type-desc-desc mx-type-desc)))
[(= -1 (FUNCDESC-cParamsOpt func-desc)) (define num-actual-params (FUNCDESC-cParams func-desc))
;; all args > pFuncDesc->cParams - 1 get packaged into SAFEARRAY (cond
(values [(= -1 (FUNCDESC-cParamsOpt func-desc))
(append ;; all args > pFuncDesc->cParams - 1 get packaged into SAFEARRAY
(for/list ([i (in-range num-actual-params)]) (values
(elem-desc-to-scheme-type (elem-desc-ref func-desc i) (append
(for/list ([i (in-range num-actual-params)])
(elem-desc-to-scheme-type (elem-desc-ref func-desc i)
#f
#f
internal?))
(list '...))
(elem-desc-to-scheme-type (FUNCDESC-elemdescFunc func-desc)
#f #f
#f #f
internal?)) internal?))]
(list '...)) [else
(elem-desc-to-scheme-type (FUNCDESC-elemdescFunc func-desc) (define last-is-retval?
#f (is-last-param-retval? inv-kind func-desc))
#f (define num-params (- num-actual-params (if last-is-retval? 1 0)))
internal?))] ;; parameters that are optional with a default value in IDL are not
[else ;; counted in pFuncDesc->cParamsOpt, so look for default bit flag
(define last-is-retval? (define num-opt-params (get-opt-param-count func-desc num-params))
(is-last-param-retval? inv-kind func-desc)) (define first-opt-arg (- num-params num-opt-params))
(define num-params (- num-actual-params (if last-is-retval? 1 0))) (values
;; parameters that are optional with a default value in IDL are not (for/list ([i (in-range num-params)])
;; counted in pFuncDesc->cParamsOpt, so look for default bit flag (elem-desc-to-scheme-type (elem-desc-ref func-desc i)
(define num-opt-params (get-opt-param-count func-desc num-params))
(define first-opt-arg (- num-params num-opt-params))
(values
(for/list ([i (in-range num-params)])
(elem-desc-to-scheme-type (elem-desc-ref func-desc i)
#f
(i . >= . first-opt-arg)
internal?))
(elem-desc-to-scheme-type (if last-is-retval?
(elem-desc-ref func-desc num-params)
(FUNCDESC-elemdescFunc func-desc))
#t
#f
internal?))])]
[(= inv-kind INVOKE_PROPERTYGET)
(define var-desc (mx-com-type-desc-desc mx-type-desc))
(values null
(elem-desc-to-scheme-type (VARDESC-elemdescVar var-desc)
#f #f
#f (i . >= . first-opt-arg)
internal?))] internal?))
[(= inv-kind INVOKE_PROPERTYPUT) (elem-desc-to-scheme-type (if last-is-retval?
(define var-desc (mx-com-type-desc-desc mx-type-desc)) (elem-desc-ref func-desc num-params)
(values (list (elem-desc-to-scheme-type (VARDESC-elemdescVar var-desc) (FUNCDESC-elemdescFunc func-desc))
#f #t
#f #f
internal?)) internal?))])]
'void)] [(= inv-kind INVOKE_PROPERTYGET)
[(= inv-kind INVOKE_EVENT) (define var-desc (mx-com-type-desc-desc mx-type-desc))
(values null 'void)])) (values null
`(-> ,args ,ret)])) (elem-desc-to-scheme-type (VARDESC-elemdescVar var-desc)
#f
#f
internal?))]
[(= inv-kind INVOKE_PROPERTYPUT)
(define var-desc (mx-com-type-desc-desc mx-type-desc))
(values (list (elem-desc-to-scheme-type (VARDESC-elemdescVar var-desc)
#f
#f
internal?))
'void)]
[(= inv-kind INVOKE_EVENT)
(values null 'void)]))
`(-> ,args ,ret)]))))
(define (com-method-type obj name) (define (com-method-type obj name)
(do-get-method-type 'com-method-type obj name INVOKE_FUNC #f)) (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) (define (do-com-invoke who obj name args inv-kind)
(check-com-obj who obj) (check-com-obj who obj)
(unless (string? name) (raise-type-error who "string" name)) (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: ;; wing it by inferring types from the arguments:
`(-> ,(map arg-to-type args) any))]) `(-> ,(map arg-to-type args) any))])
(unless (<= (length (filter (lambda (v) (not (and (pair? v) (eq? (car v) 'opt)))) (unless (<= (length (filter (lambda (v) (not (and (pair? v) (eq? (car v) 'opt))))
@ -1788,64 +1796,66 @@
(for ([arg (in-list args)] (for ([arg (in-list args)]
[type (in-list (cadr t))]) [type (in-list (cadr t))])
(check-argument 'com-invoke name arg type)) (check-argument 'com-invoke name arg type))
(define type-desc (get-method-type obj name inv-kind #f)) ; cached (call-as-atomic
(cond (lambda ()
[(if type-desc (define type-desc (get-method-type obj name inv-kind #f)) ; cached
(mx-com-type-desc-memid type-desc) (cond
(find-memid who obj name)) [(if type-desc
=> (lambda (memid) (mx-com-type-desc-memid type-desc)
(define-values (num-params-passed method-arguments cleanups commits) (find-memid who obj name))
(build-method-arguments type-desc => (lambda (memid)
(cadr t) (define-values (num-params-passed method-arguments cleanups commits)
inv-kind (build-method-arguments type-desc
args)) (cadr t)
;; from this point, don't escape/return without running cleanups inv-kind
(when #f args))
;; for debugging, inspect constructed arguments: ;; from this point, don't escape/return without running cleanups
(eprintf "~e ~e\n" (when #f
t ;; for debugging, inspect constructed arguments:
(reverse (eprintf "~e ~e\n"
(for/list ([i (in-range num-params-passed)]) t
(variant-to-scheme (ptr-ref (DISPPARAMS-rgvarg method-arguments) (reverse
_VARIANT (for/list ([i (in-range num-params-passed)])
i)))))) (variant-to-scheme (ptr-ref (DISPPARAMS-rgvarg method-arguments)
(define method-result _VARIANT
(if (= inv-kind INVOKE_PROPERTYPUT) i))))))
#f (define method-result
(make-a-VARIANT 'atomic))) (if (= inv-kind INVOKE_PROPERTYPUT)
(for ([proc (in-list commits)]) (proc)) #f
(define-values (hr exn-info error-index) (make-a-VARIANT 'atomic)))
(Invoke (com-object-get-dispatch obj) (for ([proc (in-list commits)]) (proc))
memid IID_NULL LOCALE_SYSTEM_DEFAULT (define-values (hr exn-info error-index)
inv-kind method-arguments (Invoke (com-object-get-dispatch obj)
method-result)) memid IID_NULL LOCALE_SYSTEM_DEFAULT
(cond inv-kind method-arguments
[(zero? hr) method-result))
(begin0 (cond
(if method-result [(zero? hr)
(variant-to-scheme method-result) (begin0
(void)) (if method-result
(for ([proc (in-list cleanups)]) (proc)))] (variant-to-scheme method-result)
[(= hr DISP_E_EXCEPTION) (void))
(for ([proc (in-list cleanups)]) (proc)) (for ([proc (in-list cleanups)]) (proc)))]
(define has-error-code? (positive? (EXCEPINFO-wCode exn-info))) [(= hr DISP_E_EXCEPTION)
(define desc (EXCEPINFO-bstrDescription exn-info)) (for ([proc (in-list cleanups)]) (proc))
(windows-error (define has-error-code? (positive? (EXCEPINFO-wCode exn-info)))
(if has-error-code? (define desc (EXCEPINFO-bstrDescription exn-info))
(format "COM object exception during ~s, error code 0x~x~a~a" (windows-error
name (if has-error-code?
(EXCEPINFO-wCode exn-info) (format "COM object exception during ~s, error code 0x~x~a~a"
(if desc "\nDescription: " "") name
(or desc "")) (EXCEPINFO-wCode exn-info)
(format "COM object exception during ~s~a~a" (if desc "\nDescription: " "")
name (or desc ""))
(if desc "\nDescription: " "") (format "COM object exception during ~s~a~a"
(or desc ""))) name
(EXCEPINFO-scode exn-info))] (if desc "\nDescription: " "")
[else (or desc "")))
(for ([proc (in-list cleanups)]) (proc)) (EXCEPINFO-scode exn-info))]
(windows-error (format "~a: failed for ~s" who name) hr)]))] [else
[else (error "not yet implemented")]))) (for ([proc (in-list cleanups)]) (proc))
(windows-error (format "~a: failed for ~s" who name) hr)]))]
[else (error "not yet implemented")])))))
(define (com-invoke obj name . args) (define (com-invoke obj name . args)
(do-com-invoke 'com-invoke obj name args INVOKE_FUNC)) (do-com-invoke 'com-invoke obj name args INVOKE_FUNC))
@ -2047,11 +2057,15 @@
(define (com-object-get-iunknown obj) (define (com-object-get-iunknown obj)
(check-com-obj '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) (define (com-object-get-idispatch obj)
(check-com-obj '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-iunknown? v) (and (IUnknown? v) #t))
(define (com-idispatch? v) (and (IDispatch? v) #t)) (define (com-idispatch? v) (and (IDispatch? v) #t))