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

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

racket/src/cs/io.sls

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

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

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)

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)
 

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 <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,7 +146,8 @@
               [(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])

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_NULLABLE      /* empty; pointer type can be NULL */
-#define RKTIO_BLOCKING      /* empty */
+#define RKTIO_BLOCKING      /* empty; function blocks indefinitely */
+#define RKTIO_MSG_QUEUE     /* empty; function can dispatch events on Windows */
 
 /*************************************************/
 /* Initialization and general datatypes          */
@@ -1100,7 +1101,7 @@ enum {
   RKTIO_SW_SHOWNORMAL
 };
 
-RKTIO_EXTERN rktio_ok_t rktio_shell_execute(rktio_t *rktio,
+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,

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)