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

cs: add sanity check for proper callbacks during blocking callouts

Browse Source
This commit is contained in:
Matthew Flatt 2018-09-11 08:46:36 -06:00
parent 90514ef075
commit 30fb62e438
1 changed files with 10 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
racket/src/cs/rumble/foreign.ss
View File

@ -1337,6 +1337,9 @@
(check who ctype? out-type) (check who ctype? out-type)
(ffi-call/callable #t in-types out-type abi save-errno blocking? #f #f)])) (ffi-call/callable #t in-types out-type abi save-errno blocking? #f #f)]))
;; For sanity checking of callbacks during a blocking callout:
(define-virtual-register currently-blocking? #f)
(define (ffi-call/callable call? in-types out-type abi save-errno blocking? atomic? async-apply) (define (ffi-call/callable call? in-types out-type abi save-errno blocking? atomic? async-apply)
(let* ([conv (case abi (let* ([conv (case abi
[(stdcall) '__stdcall] [(stdcall) '__stdcall]
@ -1441,6 +1444,7 @@
;; result is a struct type; need to allocate space for it ;; result is a struct type; need to allocate space for it
(make-bytevector ret-size))]) (make-bytevector ret-size))])
(with-interrupts-disabled (with-interrupts-disabled
(when blocking? (currently-blocking? #t))
(let ([r (#%apply (gen-proc (cpointer-address proc-p)) (let ([r (#%apply (gen-proc (cpointer-address proc-p))
(append (append
(if ret-ptr (if ret-ptr
@ -1455,6 +1459,7 @@
(maker (cpointer-address arg))] (maker (cpointer-address arg))]
[else arg]))) [else arg])))
args in-types arg-makers)))]) args in-types arg-makers)))])
(when blocking? (currently-blocking? #f))
(case save-errno (case save-errno
[(posix) (thread-cell-set! errno-cell (get-errno))] [(posix) (thread-cell-set! errno-cell (get-errno))]
[(windows) (thread-cell-set! errno-cell (get-last-error))]) [(windows) (thread-cell-set! errno-cell (get-last-error))])
@ -1470,6 +1475,11 @@
(gen-proc (lambda args ; if ret-id, includes an extra initial argument to receive the result (gen-proc (lambda args ; if ret-id, includes an extra initial argument to receive the result
(let ([v (call-as-atomic-callback (let ([v (call-as-atomic-callback
(lambda () (lambda ()
(unless async-apply
;; Sanity check; if the check fails, things can go bad from here on,
;; but we try to continue, anyway
(when (currently-blocking?)
(#%printf "non-async in callback during blocking: ~s\n" to-wrap)))
(s->c (s->c
out-type out-type
(apply to-wrap (apply to-wrap