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

use msg-send table atomically

Browse Source
This commit is contained in:
Matthew Flatt 2010-07-13 08:00:01 -06:00
parent 87b1ec35f3
commit 95dd131e93
1 changed files with 10 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,7 +1,8 @@
#lang racket/base #lang racket/base
(require ffi/unsafe (require ffi/unsafe
racket/stxparam racket/stxparam
(for-syntax racket/base)) (for-syntax racket/base)
"atomic.rkt")
(define objc-lib (ffi-lib "libobjc")) (define objc-lib (ffi-lib "libobjc"))
@ -91,9 +92,14 @@
;; simple as this: ;; simple as this:
((ctype-sizeof v) . <= . 16))])) ((ctype-sizeof v) . <= . 16))]))
;; Make `msgSends' access atomic, so that a thread cannot be suspended
;; or killed during access, whcih would block other threads.
(define-syntax-rule (as-atomic e)
(begin (start-atomic) (begin0 e (end-atomic))))
(define (lookup-send types msgSends msgSend msgSend_fpret msgSend_stret first-arg-type) (define (lookup-send 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 (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))])
(if (and (list? ret-layout) (if (and (list? ret-layout)
(not (sizes-for-direct-struct-results (vector-ref types 0)))) (not (sizes-for-direct-struct-results (vector-ref types 0))))
@ -106,7 +112,7 @@
(let ([v (malloc (vector-ref types 0))]) (let ([v (malloc (vector-ref types 0))])
(apply pre-m v args) (apply pre-m v args)
(ptr-ref v (vector-ref types 0))))]) (ptr-ref v (vector-ref types 0))))])
(hash-set! msgSends types m) (as-atomic (hash-set! msgSends types m))
m) m)
;; Non-structure return type: ;; Non-structure return type:
(let ([m (function-ptr (if (memq ret-layout (let ([m (function-ptr (if (memq ret-layout
@ -116,7 +122,7 @@
(_cprocedure (_cprocedure
(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)))])
(hash-set! msgSends types m) (as-atomic (hash-set! msgSends types m))
m))))) m)))))
(define msgSends (make-hash)) (define msgSends (make-hash))