From d45ef526db208cd4e0f7c98a436318dcc83ad266 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9mie=20Dimino?= Date: Thu, 13 Sep 2018 11:15:45 +0100 Subject: [PATCH] Add support for response files (#1256) Signed-off-by: Jeremie Dimino --- CHANGES.md | 3 +++ src/context.ml | 14 +++++++++++++- src/ocaml_version.ml | 3 +++ src/ocaml_version.mli | 3 +++ src/process.ml | 27 +++++++++++++++++++++++---- src/response_file.ml | 13 +++++++++++++ src/response_file.mli | 14 ++++++++++++++ 7 files changed, 72 insertions(+), 5 deletions(-) create mode 100644 src/response_file.ml create mode 100644 src/response_file.mli diff --git a/CHANGES.md b/CHANGES.md index c6e2a92fb57..5afe812b8db 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -62,6 +62,9 @@ next - Add support for private modules via the `private_modules` field (#1241, fix #427, @rgrinberg) +- Add support for passing arguments to the OCaml compiler via a + response file when the list of arguments is too long (#1256, @diml) + - Do not print diffs by default when running inside dune (#1260, @diml) 1.1.1 (08/08/2018) diff --git a/src/context.ml b/src/context.ml index f2b51656d36..dae9f484f7c 100644 --- a/src/context.ml +++ b/src/context.ml @@ -391,7 +391,7 @@ let create ~(kind : Kind.t) ~path ~env ~env_nodes ~name ~merlin ~targets let version_string = Ocaml_config.version_string ocfg in let version = Ocaml_version.of_ocaml_config ocfg in let arch_sixtyfour = Ocaml_config.word_size ocfg = 64 in - Fiber.return + let t = { name ; implicit ; kind @@ -461,6 +461,18 @@ let create ~(kind : Kind.t) ~path ~env ~env_nodes ~name ~merlin ~targets ; which_cache } + in + if Ocaml_version.supports_response_file version then begin + let set prog = + Response_file.set ~prog (Zero_terminated_strings "-args0") + in + set t.ocaml; + set t.ocamlc; + Option.iter t.ocamlopt ~f:set; + set t.ocamldep; + set t.ocamlmklib + end; + Fiber.return t in let implicit = not (List.mem ~set:targets Workspace.Context.Target.Native) in diff --git a/src/ocaml_version.ml b/src/ocaml_version.ml index 21ad5a56431..94bc589aaf8 100644 --- a/src/ocaml_version.ml +++ b/src/ocaml_version.ml @@ -17,3 +17,6 @@ let supports_color_in_ocamlparam version = let supports_ocaml_color version = version >= (4, 05, 0) + +let supports_response_file version = + version >= (4, 05, 0) diff --git a/src/ocaml_version.mli b/src/ocaml_version.mli index f6106864e22..a1e36549649 100644 --- a/src/ocaml_version.mli +++ b/src/ocaml_version.mli @@ -18,3 +18,6 @@ val supports_color_in_ocamlparam : t -> bool (** Does this support [OCAML_COLOR]? *) val supports_ocaml_color : t -> bool + +(** Does this this support [-args0]? *) +val supports_response_file : t -> bool diff --git a/src/process.ml b/src/process.ml index fc2710c5015..17a2492c1a4 100644 --- a/src/process.ml +++ b/src/process.ml @@ -214,6 +214,10 @@ let gen_id = let next = ref (-1) in fun () -> incr next; !next +let cmdline_approximate_length prog args = + List.fold_left args ~init:(String.length prog) ~f:(fun acc arg -> + acc + String.length arg) + let run_internal ?dir ?(stdout_to=Terminal) ?(stderr_to=Terminal) ~env ~purpose fail_mode prog args = Scheduler.wait_for_available_job () @@ -234,8 +238,22 @@ let run_internal ?dir ?(stdout_to=Terminal) ?(stderr_to=Terminal) ~env ~purpose if display = Verbose then Format.eprintf "@{Running@}[@{%d@}]: %s@." id (Colors.strip_colors_for_stderr command_line); - let prog = Path.reach_for_running ?from:dir prog in - let argv = Array.of_list (prog :: args) in + let prog_str = Path.reach_for_running ?from:dir prog in + let args, response_file = + if Sys.win32 && cmdline_approximate_length prog_str args >= 1024 then + match Response_file.get ~prog with + | Not_supported -> (args, None) + | Zero_terminated_strings arg -> + let fn = Temp.create "responsefile" ".data" in + Io.with_file_out fn ~f:(fun oc -> + List.iter args ~f:(fun arg -> + output_string oc arg; + output_char oc '\000')); + ([arg; Path.to_string fn], Some fn) + else + (args, None) + in + let argv = Array.of_list (prog_str :: args) in let output_filename, stdout_fd, stderr_fd, to_close = match stdout_to, stderr_to with | (Terminal, _ | _, Terminal) when !Clflags.capture_outputs -> @@ -248,7 +266,7 @@ let run_internal ?dir ?(stdout_to=Terminal) ?(stderr_to=Terminal) ~env ~purpose let stdout, close_stdout = get_std_output stdout_to ~default:stdout_fd in let stderr, close_stderr = get_std_output stderr_to ~default:stderr_fd in let run () = - Unix.create_process_env prog argv (Env.to_unix env) + Unix.create_process_env prog_str argv (Env.to_unix env) Unix.stdin stdout stderr in let pid = @@ -261,6 +279,7 @@ let run_internal ?dir ?(stdout_to=Terminal) ?(stderr_to=Terminal) ~env ~purpose close_std_output close_stderr; Scheduler.wait_for_process pid >>| fun exit_status -> + Option.iter response_file ~f:Path.unlink; let output = match output_filename with | None -> "" @@ -274,7 +293,7 @@ let run_internal ?dir ?(stdout_to=Terminal) ?(stderr_to=Terminal) ~env ~purpose s in Log.command (Scheduler.log scheduler) ~command_line ~output ~exit_status; - let _, progname, _ = Fancy.split_prog prog in + let _, progname, _ = Fancy.split_prog prog_str in let print fmt = Errors.kerrf ~f:(Scheduler.print scheduler) fmt in match exit_status with | WEXITED n when code_is_ok ok_codes n -> diff --git a/src/response_file.ml b/src/response_file.ml new file mode 100644 index 00000000000..1a76f5430be --- /dev/null +++ b/src/response_file.ml @@ -0,0 +1,13 @@ +open Stdune + +type t = + | Not_supported + | Zero_terminated_strings of string + +let registry = Hashtbl.create 128 + +let get ~prog = + Option.value (Hashtbl.find registry prog) ~default:Not_supported + +let set ~prog t = + Hashtbl.add registry prog t diff --git a/src/response_file.mli b/src/response_file.mli new file mode 100644 index 00000000000..669aecc22e6 --- /dev/null +++ b/src/response_file.mli @@ -0,0 +1,14 @@ +(** Response file support *) + +open Stdune + +type t = + | Not_supported + | Zero_terminated_strings of string + (** The argument is the command line flag, such as "-args0" *) + +(** Return whether [prog] supports a response file or not *) +val get : prog:Path.t -> t + +(** Registers the fact that [prog] supports a response file *) +val set : prog:Path.t -> t -> unit