Windows: process spawning support

lib_eio/utils/nt_path.ml

@@ -124,15 +124,25 @@ let normalise rest =
   in
   "\\" ^ String.concat "\\" (go [] (String.split_on_char '\\' rest))
 
+(* The rest of [p] after the prefix [r], if [p] has it. *)
+let after r p = Option.map (fun i -> drop i p) (r p 0)
+
 (* [qualify p] is the absolute Win32 path [p] named in the NT namespace. *)
 let qualify p =
-  let after r = Option.map (fun i -> drop i p) (r p 0) in
   "\\??\\" ^
-  match after nt_prefix, after (bslash *> bslash) with
+  match after nt_prefix p, after (bslash *> bslash) p with
   | Some rest, _ -> rest                     (* \??\, \\?\ or \\.\ *)
   | None, Some share -> "UNC\\" ^ share      (* \\server\share *)
   | None, None -> p                          (* C:\... *)
 
+let to_win32 p =
+  match after (verbatim_prefix *> bslash) p with
+  | None -> p                                (* including \\.\, which Win32 understands *)
+  | Some rest ->
+    match after (unc_kw *> bslash) rest with
+    | Some share -> "\\\\" ^ share           (* \\server\share *)
+    | None -> rest                           (* C:\... *)
+
 let to_nt ~cwd p =
   if verbatim p then qualify p
   else (

lib_eio/utils/nt_path.mli

@@ -22,6 +22,12 @@ val basename : string -> string
 (** [basename p] is the final component of [p]. It is [p] itself when [p] has
     no directory part, and ["."] when [p] is empty. *)
 
+val to_win32 : string -> string
+(** [to_win32 p] is [p] without any verbatim ([\\?\]) or NT ([\??\]) prefix,
+    for programs that cannot handle one. It undoes {!to_nt}: [to_win32 (to_nt ~cwd p)]
+    is the absolute Win32 form of [p]. A device path ([\\.\]) is left alone,
+    as Win32 understands it. *)
+
 val to_nt : cwd:string -> string -> string
 (** [to_nt ~cwd path] is the NT object-manager form of the Win32 path [path].
 

lib_eio_windows/eio_windows.ml

@@ -33,7 +33,7 @@ let run main =
     method domain_mgr = Domain_mgr.v
     method cwd = (Fs.cwd :> Eio.Fs.dir_ty Eio.Path.t)
     method fs = (Fs.fs :> Eio.Fs.dir_ty Eio.Path.t)
-    method process_mgr = failwith "process operations not supported on Windows yet"
+    method process_mgr = Process.mgr
     method secure_random = Flow.secure_random
     method backend_id = "windows"
   end

lib_eio_windows/eio_windows_stubs.c

@@ -277,7 +277,153 @@ CAMLprim value caml_eio_windows_symlinkat(value v_old_path, value v_new_fd, valu
   uerror("symlinkat is not supported on windows yet", Nothing);
 }
 
-CAMLprim value caml_eio_windows_spawn(value v_errors, value v_actions)
+/* The block CreateProcess expects: the entries NUL-separated, then a final NUL. */
+static wchar_t *env_block_of_array(value v_env)
 {
-  uerror("processes are not supported on windows yet", Nothing);
+  mlsize_t n = Wosize_val(v_env), i;
+  size_t total = n == 0 ? 2 : 1;
+  wchar_t **parts = caml_stat_alloc((n + 1) * sizeof(wchar_t *));
+  wchar_t *block, *p;
+
+  for (i = 0; i < n; i++) {
+    parts[i] = caml_stat_strdup_to_utf16(String_val(Field(v_env, i)));
+    total += wcslen(parts[i]) + 1;
+  }
+  p = block = caml_stat_alloc(total * sizeof(wchar_t));
+  for (i = 0; i < n; i++) {
+    size_t len = wcslen(parts[i]) + 1;
+    memcpy(p, parts[i], len * sizeof(wchar_t));
+    caml_stat_free(parts[i]);
+    p += len;
+  }
+  *p = 0;
+  if (n == 0) p[1] = 0;
+  caml_stat_free(parts);
+  return block;
+}
+
+CAMLprim value caml_eio_windows_spawn(value v_cwd, value v_env,
+                                      value v_stdin, value v_stdout, value v_stderr,
+                                      value v_cmdline)
+{
+  CAMLparam5(v_cwd, v_env, v_stdin, v_stdout, v_stderr);
+  CAMLxparam1(v_cmdline);
+  CAMLlocal1(v_result);
+
+  wchar_t *cmdline = NULL, *cwd = NULL, *env_block = NULL;
+  HANDLE src[3];
+  HANDLE dup[3] = { NULL, NULL, NULL };
+  STARTUPINFOEXW si;
+  PROCESS_INFORMATION pi;
+  SIZE_T attr_size = 0;
+  BOOL ok = FALSE;
+  DWORD err = 0;
+  DWORD create_flags = EXTENDED_STARTUPINFO_PRESENT | CREATE_UNICODE_ENVIRONMENT;
+  HANDLE cur = GetCurrentProcess();
+
+  memset(&si, 0, sizeof(si));
+  memset(&pi, 0, sizeof(pi));
+
+  caml_unix_check_path(v_cmdline, "execve");
+  if (Is_some(v_cwd)) caml_unix_check_path(Field(v_cwd, 0), "execve");
+  cmdline = caml_stat_strdup_to_utf16(String_val(v_cmdline));
+  if (Is_some(v_cwd)) cwd = caml_stat_strdup_to_utf16(String_val(Field(v_cwd, 0)));
+  /* Always passed: NULL would make the child inherit our environment. */
+  env_block = env_block_of_array(v_env);
+
+  src[0] = Handle_val(v_stdin);
+  src[1] = Handle_val(v_stdout);
+  src[2] = Handle_val(v_stderr);
+
+  for (int i = 0; i < 3; i++) {
+    if (!DuplicateHandle(cur, src[i], cur, &dup[i], 0, TRUE, DUPLICATE_SAME_ACCESS)) {
+      err = GetLastError();
+      goto cleanup;
+    }
+  }
+
+  si.StartupInfo.cb = sizeof(STARTUPINFOEXW);
+  si.StartupInfo.dwFlags = STARTF_USESTDHANDLES;
+  si.StartupInfo.hStdInput  = dup[0];
+  si.StartupInfo.hStdOutput = dup[1];
+  si.StartupInfo.hStdError  = dup[2];
+
+  if (!GetConsoleWindow()) create_flags |= CREATE_NO_WINDOW;
+
+  InitializeProcThreadAttributeList(NULL, 1, 0, &attr_size);
+  si.lpAttributeList = caml_stat_alloc(attr_size);
+  if (!InitializeProcThreadAttributeList(si.lpAttributeList, 1, 0, &attr_size)) {
+    err = GetLastError();
+    caml_stat_free(si.lpAttributeList);
+    si.lpAttributeList = NULL;
+    goto cleanup;
+  }
+  if (!UpdateProcThreadAttribute(si.lpAttributeList, 0, PROC_THREAD_ATTRIBUTE_HANDLE_LIST,
+                                 dup, 3 * sizeof(HANDLE), NULL, NULL)) {
+    err = GetLastError();
+    goto cleanup;
+  }
+
+  caml_enter_blocking_section();
+  ok = CreateProcessW(NULL, cmdline, NULL, NULL, TRUE, create_flags, env_block, cwd,
+                      &si.StartupInfo, &pi);
+  if (!ok) err = GetLastError();
+  caml_leave_blocking_section();
+
+cleanup:
+  if (si.lpAttributeList) {
+    DeleteProcThreadAttributeList(si.lpAttributeList);
+    caml_stat_free(si.lpAttributeList);
+  }
+  for (int i = 0; i < 3; i++)
+    if (dup[i]) CloseHandle(dup[i]);
+  caml_stat_free(cmdline);
+  caml_stat_free(cwd);
+  caml_stat_free(env_block);
+
+  if (!ok) {
+    caml_win32_maperr(err);
+    /* Named "execve" so the portable error translation applies unchanged. */
+    uerror("execve", v_cmdline);
+  }
+
+  CloseHandle(pi.hThread);
+  v_result = caml_alloc_tuple(2);
+  Store_field(v_result, 0, Val_long(pi.dwProcessId));
+  Store_field(v_result, 1, caml_win32_alloc_handle(pi.hProcess));
+  CAMLreturn(v_result);
+}
+
+CAMLprim value caml_eio_windows_spawn_bytes(value *argv, int argn)
+{
+  (void)argn;
+  return caml_eio_windows_spawn(argv[0], argv[1], argv[2], argv[3],
+                                argv[4], argv[5]);
+}
+
+CAMLprim value caml_eio_windows_process_wait(value v_handle)
+{
+  CAMLparam1(v_handle);
+  HANDLE h = Handle_val(v_handle);
+  DWORD code = 0;
+  DWORD wait_res;
+  caml_enter_blocking_section();
+  wait_res = WaitForSingleObject(h, INFINITE);
+  caml_leave_blocking_section();
+  if (wait_res == WAIT_FAILED) {
+    caml_win32_maperr(GetLastError());
+    uerror("process_wait", Nothing);
+  }
+  if (!GetExitCodeProcess(h, &code)) {
+    caml_win32_maperr(GetLastError());
+    uerror("process_wait", Nothing);
+  }
+  CAMLreturn(Val_long((intnat)(unsigned int)code));
+}
+
+CAMLprim value caml_eio_windows_process_terminate(value v_handle, value v_code)
+{
+  CAMLparam2(v_handle, v_code);
+  /* Signalling an already-exited process is a no-op rather than an error. */
+  CAMLreturn(Val_bool(TerminateProcess(Handle_val(v_handle), (UINT)Long_val(v_code))));
 }

lib_eio_windows/include/discover.ml

@@ -35,6 +35,9 @@ let () =
             "FILE_NO_INTERMEDIATE_BUFFERING", Int;
             "FILE_WRITE_THROUGH", Int;
             "FILE_SEQUENTIAL_ONLY", Int;
+
+            (* Exit Codes *)
+            "STATUS_CONTROL_C_EXIT", Int;
           ]
         |> List.map (function
             | name, C.C_define.Value.Int v ->

lib_eio_windows/low_level.ml

@@ -38,25 +38,27 @@ let rec do_nonblocking ty fn fd =
       );
     do_nonblocking ty fn fd
 
+let transfer label ty op fd =
+  match Fd.is_blocking fd with
+  | true ->
+    Fd.use_exn label fd @@ fun fd ->
+    in_worker_thread ~label (fun () -> op fd)
+  | false ->
+    (match ty with Read -> await_readable fd | Write -> await_writable fd);
+    Fd.use_exn label fd @@ fun fd ->
+    do_nonblocking ty op fd
+
 let read fd buf start len =
-  await_readable fd;
-  Fd.use_exn "read" fd @@ fun fd ->
-  do_nonblocking Read (fun fd -> Unix.read fd buf start len) fd
+  transfer "read" Read (fun fd -> Unix.read fd buf start len) fd
 
 let read_cstruct fd (buf:Cstruct.t) =
-  await_readable fd;
-  Fd.use_exn "read_cstruct" fd @@ fun fd ->
-  do_nonblocking Read (fun fd -> Unix.read_bigarray fd buf.buffer buf.off buf.len) fd
+  transfer "read_cstruct" Read (fun fd -> Unix.read_bigarray fd buf.buffer buf.off buf.len) fd
 
 let write fd buf start len =
-  await_writable fd;
-  Fd.use_exn "write" fd @@ fun fd ->
-  do_nonblocking Write (fun fd -> Unix.write fd buf start len) fd
+  transfer "write" Write (fun fd -> Unix.write fd buf start len) fd
 
 let write_cstruct fd (buf:Cstruct.t) =
-  await_writable fd;
-  Fd.use_exn "write_cstruct" fd @@ fun fd ->
-  do_nonblocking Write (fun fd -> Unix.write_bigarray fd buf.buffer buf.off buf.len) fd
+  transfer "write_cstruct" Write (fun fd -> Unix.write_bigarray fd buf.buffer buf.off buf.len) fd
 
 let sleep_until time =
   Sched.enter @@ fun t k ->
@@ -305,8 +307,6 @@ let ftruncate fd len =
 
 let pipe ~sw =
   let unix_r, unix_w = Unix.pipe ~cloexec:true () in
-  let r = Fd.of_unix ~sw ~blocking:false ~close_unix:true unix_r in
-  let w = Fd.of_unix ~sw ~blocking:false ~close_unix:true unix_w in
-  Unix.set_nonblock unix_r;
-  Unix.set_nonblock unix_w;
+  let r = Fd.of_unix ~sw ~blocking:true ~close_unix:true unix_r in
+  let w = Fd.of_unix ~sw ~blocking:true ~close_unix:true unix_w in
   r, w