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

cs & io: fix rktio_shell_execute binding to cooperate with the FFI

Browse Source 
ShellExecute can dispatch Windows events, which means that it needs to
be called in a way that's consistent with the environment expected by
event-handling callbacks.

Relevant to #3832
This commit is contained in:
Matthew Flatt 2021-06-01 15:41:55 -06:00
parent d8d9255c2a
commit 4e89fc638f
7 changed files with 36 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
racket/src/cs/io.sls
View File

@ -126,6 +126,10 @@
[(_ (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 ()
[(_ (flag ...) orig-ret-type name ([orig-arg-type arg-name] ...))
@ -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)])

1
racket/src/cs/rumble.sls
View File

@ -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

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

@ -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)

5
racket/src/io/subprocess/main.rkt
View File

@ -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)

11
racket/src/rktio/parse.rkt
View File

@ -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 <type> <id> SEMI)
(if (eq? $2 $3)
@ -135,7 +137,7 @@
`(define-type ,$6 function-pointer)]
[(TYPEDEF <type> OPEN STAR <id> CLOSE OPEN <params> SEMI)
`(define-type ,$5 function-pointer)]
[(<extern> <blocking> <return-type> <id> OPEN <params> SEMI)
[(<extern> <flags> <return-type> <id> OPEN <params> 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)]
[() '()])
(<flags> [(BLOCKING) '(blocking)]
[(MSG_QUEUE) '(msg-queue)]
[() '()])
(<params> [(VOID CLOSE) null]
[(<paramlist>) $1])
(<paramlist> [(<type> <id> CLOSE) `((,(shift-stars $2 $1) ,(unstar $2)))]

17
racket/src/rktio/rktio.h
View File

@ -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. */

2
racket/src/rktio/rktio.rktl
View File

@ -1251,7 +1251,7 @@
(int get_gmt)))
(define-function/errno
#f
()
(msg-queue)
rktio_ok_t
rktio_shell_execute
(((ref rktio_t) rktio)