diff --git a/racket/src/cs/io.sls b/racket/src/cs/io.sls index 4d4d245a3a..064a6a36d9 100644 --- a/racket/src/cs/io.sls +++ b/racket/src/cs/io.sls @@ -125,6 +125,10 @@ (syntax-case stx (ref) [(_ (ref _) v) #'(address->ptr v)] [(_ _ v) #'v])) + + (define-syntax (wrap-result/allow-callbacks stx) + (syntax-case stx () + [(_ t v) #'(call-enabling-ffi-callbacks (lambda () (wrap-result t v)))])) (meta define (convert-function stx) (syntax-case stx () @@ -133,7 +137,10 @@ [(arg-type ...) (map convert-type #'(orig-arg-type ...))] [(conv ...) (if (#%memq 'blocking (map syntax->datum #'(flag ...))) #'(__collect_safe) - #'())]) + #'())] + [wrap-result (if (#%memq 'msg-queue (map syntax->datum #'(flag ...))) + #'wrap-result/allow-callbacks + #'wrap-result)]) #'(let ([proc (foreign-procedure conv ... (rktio-lookup 'name) (arg-type ...) ret-type)]) diff --git a/racket/src/cs/rumble.sls b/racket/src/cs/rumble.sls index 207c5eadf0..a745d19368 100644 --- a/racket/src/cs/rumble.sls +++ b/racket/src/cs/rumble.sls @@ -653,6 +653,7 @@ poll-async-callbacks ; not exported to Racket set-make-async-callback-poll-wakeup! ; not exported to Racket set-foreign-eval! ; not exported to Racket + call-enabling-ffi-callbacks ; not exported to Racket ptr-ref/int8 ptr-set!/int8 ; not exported to Racket ptr-ref/uint8 ptr-set!/uint8 ; not exported to Racket diff --git a/racket/src/cs/rumble/foreign.ss b/racket/src/cs/rumble/foreign.ss index 98a8bf2143..b15294bd83 100644 --- a/racket/src/cs/rumble/foreign.ss +++ b/racket/src/cs/rumble/foreign.ss @@ -1827,6 +1827,12 @@ ;; Wait for result: #t))])) +(define (call-enabling-ffi-callbacks proc) + (disable-interrupts) + (let ([v (proc)]) + (enable-interrupts) + v)) + (define scheduler-start-atomic void) (define scheduler-end-atomic void) (define (set-scheduler-atomicity-callbacks! start-atomic end-atomic) diff --git a/racket/src/io/subprocess/main.rkt b/racket/src/io/subprocess/main.rkt index 4dfc6fba2e..201798bb58 100644 --- a/racket/src/io/subprocess/main.rkt +++ b/racket/src/io/subprocess/main.rkt @@ -297,12 +297,15 @@ [(sw_shownoactivate SW_SHOWNOACTIVATE) RKTIO_SW_SHOWNOACTIVATE] [(sw_shownormal SW_SHOWNORMAL) RKTIO_SW_SHOWNORMAL] [else (raise-argument-error who "(or/c 'sw_hide ....)" show-mode)])) + ;; Let `rktio_shell_execute` handle its own atomicity. That's because + ;; it can yield to Windows events, and events need to be handled by callbacks + ;; starting from a mode that's like a Racket foreign call. (define r (rktio_shell_execute rktio (and verb (string->bytes/utf-8 verb)) (string->bytes/utf-8 target) (string->bytes/utf-8 parameters) (->host (->path dir) who '(exists)) - show_mode)) + show_mode))) (when (rktio-error? r) (raise-rktio-error who r "failed")) #f) diff --git a/racket/src/rktio/parse.rkt b/racket/src/rktio/parse.rkt index 44adad0836..69ac29c24f 100644 --- a/racket/src/rktio/parse.rkt +++ b/racket/src/rktio/parse.rkt @@ -52,7 +52,7 @@ OPEN CLOSE BOPEN BCLOSE COPEN CCLOSE SEMI COMMA STAR LSHIFT EQUAL __RKTIO_H__ EXTERN EXTERN/NOERR EXTERN/STEP EXTERN/ERR DEFINE TYPEDEF ENUM STRUCT VOID UNSIGNED SHORT INT CHAR - CONST NULLABLE BLOCKING)) + CONST NULLABLE BLOCKING MSG_QUEUE)) (define lex (lexer-src-pos @@ -85,6 +85,7 @@ ["RKTIO_EXTERN_ERR" 'EXTERN/ERR] ["RKTIO_NULLABLE" 'NULLABLE] ["RKTIO_BLOCKING" 'BLOCKING] + ["RKTIO_MSG_QUEUE" 'MSG_QUEUE] [(:seq (:or #\_ (:/ #\A #\Z #\a #\z)) (:* (:or #\_ (:/ #\A #\Z #\a #\z #\0 #\9)))) (token-ID (string->symbol lexeme))] @@ -122,6 +123,7 @@ [(DEFINE EXTERN/ERR OPEN ID CLOSE EXTERN) #f] [(DEFINE NULLABLE) #f] [(DEFINE BLOCKING) #f] + [(DEFINE MSG_QUEUE) #f] [(STRUCT ID SEMI) #f] [(TYPEDEF SEMI) (if (eq? $2 $3) @@ -135,7 +137,7 @@ `(define-type ,$6 function-pointer)] [(TYPEDEF OPEN STAR CLOSE OPEN SEMI) `(define-type ,$5 function-pointer)] - [( OPEN SEMI) + [( OPEN SEMI) (let ([r-type (shift-stars $4 $3)] [id (unstar $4)]) `(,@(adjust-errno $1 r-type id) ,$2 ,r-type ,id ,$6))] @@ -144,8 +146,9 @@ [(EXTERN/STEP) 'define-function/errno+step] [(EXTERN/NOERR) 'define-function] [(EXTERN/ERR OPEN ID CLOSE) `(define-function/errno ,$3)]) - ( [(BLOCKING) '(blocking)] - [() '()]) + ( [(BLOCKING) '(blocking)] + [(MSG_QUEUE) '(msg-queue)] + [() '()]) ( [(VOID CLOSE) null] [() $1]) ( [( CLOSE) `((,(shift-stars $2 $1) ,(unstar $2)))] diff --git a/racket/src/rktio/rktio.h b/racket/src/rktio/rktio.h index 09c9c3fdb8..9705919ea9 100644 --- a/racket/src/rktio/rktio.h +++ b/racket/src/rktio/rktio.h @@ -91,8 +91,9 @@ Thread and signal conventions: #define RKTIO_EXTERN_NOERR RKTIO_EXTERN #define RKTIO_EXTERN_STEP RKTIO_EXTERN -#define RKTIO_NULLABLE /* empty */ -#define RKTIO_BLOCKING /* empty */ +#define RKTIO_NULLABLE /* empty; pointer type can be NULL */ +#define RKTIO_BLOCKING /* empty; function blocks indefinitely */ +#define RKTIO_MSG_QUEUE /* empty; function can dispatch events on Windows */ /*************************************************/ /* Initialization and general datatypes */ @@ -1100,12 +1101,12 @@ enum { RKTIO_SW_SHOWNORMAL }; -RKTIO_EXTERN rktio_ok_t rktio_shell_execute(rktio_t *rktio, - rktio_const_string_t verb, - rktio_const_string_t target, - rktio_const_string_t arg, - rktio_const_string_t dir, - int show_mode); +RKTIO_EXTERN RKTIO_MSG_QUEUE rktio_ok_t rktio_shell_execute(rktio_t *rktio, + rktio_const_string_t verb, + rktio_const_string_t target, + rktio_const_string_t arg, + rktio_const_string_t dir, + int show_mode); /* Supported only on Windows to run `ShellExecute`. The `dir` argument needs to have normalized path separators. */ diff --git a/racket/src/rktio/rktio.rktl b/racket/src/rktio/rktio.rktl index d09dd441b5..c83708c6cd 100644 --- a/racket/src/rktio/rktio.rktl +++ b/racket/src/rktio/rktio.rktl @@ -1251,7 +1251,7 @@ (int get_gmt))) (define-function/errno #f - () + (msg-queue) rktio_ok_t rktio_shell_execute (((ref rktio_t) rktio)