fix(windows): use unicode version of CreateProcess (ocaml#10212)

This does several things: - update our spawn vendored version to include janestreet/spawn#58 - pick the dune file - add new build flags for bootstrapping Fixes ocaml#10180 Signed-off-by: Etienne Millon <[email protected]>
Leonidas-from-XIV · Mar 11, 2024 · c33e32d · c33e32d
1 parent 08c5ec2
commit c33e32d
Show file tree

Hide file tree

Showing 9 changed files with 190 additions and 106 deletions.
diff --git a/boot/duneboot.ml b/boot/duneboot.ml
@@ -1067,6 +1067,7 @@ let build
   ~ocaml_config
   ~dependencies
   ~c_files
+  ~build_flags
   ~link_flags
   { target = name, main; external_libraries; _ }
   =
@@ -1114,7 +1115,7 @@ let build
         Process.run
           ~cwd:build_dir
           Config.compiler
-          (List.concat [ [ "-c"; "-g" ]; external_includes; [ file ] ])
+          (List.concat [ [ "-c"; "-g" ]; external_includes; build_flags; [ file ] ])
         >>| fun () -> Filename.chop_extension file ^ ext_obj))
   >>= fun obj_files ->
   let compiled_ml_ext =
@@ -1151,6 +1152,12 @@ let rec rm_rf fn =
 
 and clear dir = List.iter (readdir dir) ~f:rm_rf
 
+let get_flags ocaml_system flags =
+  match List.assoc_opt ocaml_system flags with
+  | None -> []
+  | Some flags -> flags
+;;
+
 (** {2 Bootstrap process} *)
 let main () =
   (try clear build_dir with
@@ -1164,15 +1171,14 @@ let main () =
   let c_files = List.map ~f:(fun (_, _, c_files) -> c_files) libraries |> List.concat in
   get_dependencies libraries
   >>= fun dependencies ->
-  let link_flags =
+  let ocaml_system =
     match StringMap.find_opt "system" ocaml_config with
     | None -> assert false
-    | Some platform ->
-      (match List.assoc_opt platform Libs.link_flags with
-       | None -> []
-       | Some flags -> flags)
+    | Some s -> s
   in
-  build ~ocaml_config ~dependencies ~c_files ~link_flags task
+  let build_flags = get_flags ocaml_system Libs.build_flags in
+  let link_flags = get_flags ocaml_system Libs.link_flags in
+  build ~ocaml_config ~dependencies ~c_files ~build_flags ~link_flags task
 ;;
 
 let () = Fiber.run (main ())
diff --git a/boot/libs.ml b/boot/libs.ml
@@ -97,6 +97,13 @@ let local_libraries =
   ; ("src/dune_rules_rpc", Some "Dune_rules_rpc", false, None)
   ]
 
+let build_flags =
+  [ ("win32", [ "-ccopt"; "-D_UNICODE"; "-ccopt"; "-DUNICODE" ])
+  ; ("win64", [ "-ccopt"; "-D_UNICODE"; "-ccopt"; "-DUNICODE" ])
+  ; ("mingw", [ "-ccopt"; "-D_UNICODE"; "-ccopt"; "-DUNICODE" ])
+  ; ("mingw64", [ "-ccopt"; "-D_UNICODE"; "-ccopt"; "-DUNICODE" ])
+  ]
+
 let link_flags =
   [ ("macosx",
     [ "-cclib"

diff --git a/doc/changes/10212.md b/doc/changes/10212.md
@@ -0,0 +1,2 @@
+- on Windows, use an unicode-aware version of `CreateProcess` to avoid crashes
+  when paths contains non-ascii characters. (#10212, fixes #10180, @emillon)
diff --git a/src/dune_rules/bootstrap_info.ml b/src/dune_rules/bootstrap_info.ml
@@ -15,19 +15,19 @@ let rule sctx ~requires_link (exes : Executables.t) =
       | Some x -> Left x
       | None -> Right lib)
   in
+  let windows_system_values = [ "win32"; "win64"; "mingw"; "mingw64" ] in
+  let win_build_flags = [ "-ccopt"; "-D_UNICODE"; "-ccopt"; "-DUNICODE" ] in
+  let build_flags = List.map windows_system_values ~f:(fun f -> f, win_build_flags) in
   let link_flags =
     let win_link_flags =
       [ "-cclib"; "-lshell32"; "-cclib"; "-lole32"; "-cclib"; "-luuid" ]
     in
     (* additional link flags keyed by the platform *)
     [ ( "macosx"
       , [ "-cclib"; "-framework CoreFoundation"; "-cclib"; "-framework CoreServices" ] )
-    ; "win32", win_link_flags
-    ; "win64", win_link_flags
-    ; "mingw", win_link_flags
-    ; "mingw64", win_link_flags
-    ; "beos", [ "-cclib"; "-lbsd" ] (* flags for Haiku *)
     ]
+    @ List.map windows_system_values ~f:(fun w -> w, win_link_flags)
+    @ [ "beos", [ "-cclib"; "-lbsd" ] (* flags for Haiku *) ]
   in
   let+ locals =
     Memo.parallel_map locals ~f:(fun x ->
@@ -83,6 +83,11 @@ let rule sctx ~requires_link (exes : Executables.t) =
           ; Pp.nop
           ; def "local_libraries" (List locals)
           ; Pp.nop
+          ; def
+              "build_flags"
+              (let open Dyn in
+               list (pair string (list string)) build_flags)
+          ; Pp.nop
           ; def
               "link_flags"
               (let open Dyn in

diff --git a/vendor/spawn/src/dune b/vendor/spawn/src/dune
@@ -2,5 +2,24 @@
  (name spawn)
  (foreign_stubs
   (language c)
+  (flags (:standard (:include flags.sexp)))
   (names spawn_stubs))
  (libraries unix threads.posix))
+
+(rule
+ (target flags.sexp)
+ (enabled_if
+  (= %{os_type} "Win32"))
+ (action
+  (with-stdout-to
+   %{target}
+   (echo "(-DUNICODE -D_UNICODE)"))))
+
+(rule
+ (target flags.sexp)
+ (enabled_if
+  (<> %{os_type} "Win32"))
+ (action
+  (with-stdout-to
+   %{target}
+   (echo "()"))))
diff --git a/vendor/spawn/src/spawn.ml b/vendor/spawn/src/spawn.ml
@@ -28,12 +28,20 @@ module Unix_backend = struct
          unsuccessful.
 
          In the end we decided not to default to [vfork] on OSX. *)
-      if is_osx then
-        Fork
-      else
-        Vfork
+      if is_osx then Fork else Vfork
+  ;;
 end
 
+let no_null s =
+  if String.contains s '\000'
+  then
+    Printf.ksprintf
+      invalid_arg
+      "Spawn.Env.of_list: NUL bytes are not allowed in the environment but found one in \
+       %S"
+      s
+;;
+
 module type Env = sig
   type t
 
@@ -44,54 +52,44 @@ module Env_win32 : Env = struct
   type t = string
 
   let of_list env =
-    let len =
-      List.fold_left env ~init:1 ~f:(fun acc s -> acc + String.length s + 1)
-    in
-    let buf = Buffer.create len in
-    List.iter env ~f:(fun s ->
+    if env = []
+    then "\000\000"
+    else (
+      let len = List.fold_left env ~init:1 ~f:(fun acc s -> acc + String.length s + 1) in
+      let buf = Buffer.create len in
+      List.iter env ~f:(fun s ->
+        no_null s;
         Buffer.add_string buf s;
         Buffer.add_char buf '\000');
-    Buffer.add_char buf '\000';
-    Buffer.contents buf
+      Buffer.add_char buf '\000';
+      Buffer.contents buf)
+  ;;
 end
 
 module Env_unix : Env = struct
   type t = string list
 
-  let no_null s =
-    if String.contains s '\000' then
-      Printf.ksprintf invalid_arg
-        "Spawn.Env.of_list: NUL bytes are not allowed in the environment but \
-         found one in %S"
-        s
-
   let of_list l =
     List.iter l ~f:no_null;
     l
+  ;;
 end
 
-module Env : Env = (val if Sys.win32 then
-                          (module Env_win32)
-                        else
-                          (module Env_unix) : Env)
+module Env : Env = (val if Sys.win32 then (module Env_win32) else (module Env_unix) : Env)
 
 module Pgid = struct
   type t = int
 
   let new_process_group = 0
 
   let of_pid = function
-    | 0 ->
-      raise (Invalid_argument "bad pid: 0 (hint: use [Pgid.new_process_group])")
-    | t ->
-      if t < 0 then
-        raise (Invalid_argument ("bad pid: " ^ string_of_int t))
-      else
-        t
+    | 0 -> raise (Invalid_argument "bad pid: 0 (hint: use [Pgid.new_process_group])")
+    | t -> if t < 0 then raise (Invalid_argument ("bad pid: " ^ string_of_int t)) else t
+  ;;
 end
 
-external spawn_unix :
-     env:Env.t option
+external spawn_unix
+  :  env:Env.t option
   -> cwd:Working_dir.t
   -> prog:string
   -> argv:string list
@@ -101,29 +99,38 @@ external spawn_unix :
   -> use_vfork:bool
   -> setpgid:int option
   -> sigprocmask:(Unix.sigprocmask_command * int list) option
-  -> int = "spawn_unix_byte" "spawn_unix"
+  -> int
+  = "spawn_unix_byte" "spawn_unix"
 
-external spawn_windows :
-     env:Env.t option
+external spawn_windows
+  :  env:Env.t option
   -> cwd:string option
   -> prog:string
   -> cmdline:string
   -> stdin:Unix.file_descr
   -> stdout:Unix.file_descr
   -> stderr:Unix.file_descr
-  -> int = "spawn_windows_byte" "spawn_windows"
+  -> int
+  = "spawn_windows_byte" "spawn_windows"
 
 let maybe_quote f =
-  if
-    String.contains f ' ' || String.contains f '\"' || String.contains f '\t'
-    || f = ""
-  then
-    Filename.quote f
-  else
-    f
-
-let spawn_windows ~env ~cwd ~prog ~argv ~stdin ~stdout ~stderr ~use_vfork:_
-    ~setpgid:_ ~sigprocmask:_ =
+  if String.contains f ' ' || String.contains f '\"' || String.contains f '\t' || f = ""
+  then Filename.quote f
+  else f
+;;
+
+let spawn_windows
+  ~env
+  ~cwd
+  ~prog
+  ~argv
+  ~stdin
+  ~stdout
+  ~stderr
+  ~use_vfork:_
+  ~setpgid:_
+  ~sigprocmask:_
+  =
   let cwd =
     match (cwd : Working_dir.t) with
     | Path p -> Some p
@@ -132,48 +139,49 @@ let spawn_windows ~env ~cwd ~prog ~argv ~stdin ~stdout ~stderr ~use_vfork:_
   in
   let cmdline = String.concat (List.map argv ~f:maybe_quote) ~sep:" " in
   let prog =
-    match (Filename.is_relative prog, cwd) with
+    match Filename.is_relative prog, cwd with
     | true, Some p -> Filename.concat p prog
     | _ -> prog
   in
   spawn_windows ~env ~cwd ~prog ~cmdline ~stdin ~stdout ~stderr
+;;
 
 let no_null s =
-  if String.contains s '\000' then
-    Printf.ksprintf invalid_arg
-      "Spawn.spawn: NUL bytes are not allowed in any of the arguments but \
-       found one in %S"
+  if String.contains s '\000'
+  then
+    Printf.ksprintf
+      invalid_arg
+      "Spawn.spawn: NUL bytes are not allowed in any of the arguments but found one in %S"
       s
-
-let spawn ?env ?(cwd = Working_dir.Inherit) ~prog ~argv ?(stdin = Unix.stdin)
-    ?(stdout = Unix.stdout) ?(stderr = Unix.stderr)
-    ?(unix_backend = Unix_backend.default) ?setpgid ?sigprocmask () =
+;;
+
+let spawn
+  ?env
+  ?(cwd = Working_dir.Inherit)
+  ~prog
+  ~argv
+  ?(stdin = Unix.stdin)
+  ?(stdout = Unix.stdout)
+  ?(stderr = Unix.stderr)
+  ?(unix_backend = Unix_backend.default)
+  ?setpgid
+  ?sigprocmask
+  ()
+  =
   (match cwd with
-  | Path s -> no_null s
-  | Fd _
-  | Inherit ->
-    ());
+   | Path s -> no_null s
+   | Fd _ | Inherit -> ());
   no_null prog;
   List.iter argv ~f:no_null;
-  let backend =
-    if Sys.win32 then
-      spawn_windows
-    else
-      spawn_unix
-  in
+  let backend = if Sys.win32 then spawn_windows else spawn_unix in
   let use_vfork =
     match unix_backend with
     | Vfork -> true
     | Fork -> false
   in
-  backend ~env ~cwd ~prog ~argv ~stdin ~stdout ~stderr ~use_vfork ~setpgid
-    ~sigprocmask
+  backend ~env ~cwd ~prog ~argv ~stdin ~stdout ~stderr ~use_vfork ~setpgid ~sigprocmask
+;;
 
 external safe_pipe : unit -> Unix.file_descr * Unix.file_descr = "spawn_pipe"
 
-let safe_pipe =
-  if Sys.win32 then
-    fun () ->
-  Unix.pipe ~cloexec:true ()
-  else
-    safe_pipe
+let safe_pipe = if Sys.win32 then fun () -> Unix.pipe ~cloexec:true () else safe_pipe
diff --git a/vendor/spawn/src/spawn.mli b/vendor/spawn/src/spawn.mli
@@ -6,10 +6,10 @@
 
 module Working_dir : sig
   type t =
-    | Path of string  (** Path in the filesystem *)
+    | Path of string (** Path in the filesystem *)
     | Fd of Unix.file_descr
         (** File descriptor pointing to a directory. Not supported on Windows. *)
-    | Inherit  (** Inherit the working directory of the current process *)
+    | Inherit (** Inherit the working directory of the current process *)
 end
 
 module Unix_backend : sig
@@ -110,8 +110,8 @@ end
     [unix_backend] describes what backend to use on Unix. If set to [Default],
     [vfork] is used unless the environment variable [SPAWN_USE_FORK] is set. On
     Windows, [CreateProcess] is used. *)
-val spawn :
-     ?env:Env.t
+val spawn
+  :  ?env:Env.t
   -> ?cwd:Working_dir.t (* default: [Inherit] *)
   -> prog:string
   -> argv:string list
Original file line number	Diff line number	Diff line change
		@@ -0,0 +1,2 @@
		- on Windows, use an unicode-aware version of `CreateProcess` to avoid crashes
		when paths contains non-ascii characters. (#10212, fixes #10180, @emillon)