From f41e27bb95616a9903a48830b7571b2b153dc25f Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Wed, 12 Dec 2018 10:19:42 +0100 Subject: [PATCH] Open files lazily + close them ASAP (#1643) Revert #1635 + implement another fix for #1633. When executing actions: - open files as late as possible - close them as soon as possible This ensures that fds stay open for the least amount of time and helps reduce the maximum number of fds opened by Dune. Signed-off-by: Rudi Grinberg Signed-off-by: Jeremie Dimino --- CHANGES.md | 10 +- src/action_exec.ml | 35 ++--- src/build.ml | 2 +- src/main.ml | 2 +- src/process.ml | 134 +++++++++++++----- src/process.mli | 37 +++-- src/stdune/path.ml | 2 - src/stdune/path.mli | 3 - test/blackbox-tests/dune.inc | 10 ++ .../test-cases/double-echo/dune | 9 ++ .../test-cases/double-echo/dune-project | 1 + .../test-cases/double-echo/run.t | 2 + 12 files changed, 166 insertions(+), 81 deletions(-) create mode 100644 test/blackbox-tests/test-cases/double-echo/dune create mode 100644 test/blackbox-tests/test-cases/double-echo/dune-project create mode 100644 test/blackbox-tests/test-cases/double-echo/run.t diff --git a/CHANGES.md b/CHANGES.md index f038d2d9614..2a14c409eae 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -7,9 +7,13 @@ - Fix preprocessing for libraries with `(include_subdirs ..)` (#1624, fix #1626, @nojb, @rgrinberg) -- Delay opening redirected output files until executing commands in - order to reduce the number of maximum number of open file - descriptors (#1635, fixes #1633, @jonludlam) +- Do not generate targets for archive that don't match the `modes` field. + (#1632, fix #1617, @rgrinberg) + +- When executing actions, open files lazily and close them as soon as + possible in order to reduce the maximum number of file descriptors + opened by Dune (#1635, #1643, fixes #1633, @jonludlam, @rgrinberg, + @diml) 1.6.2 (05/12/2018) ------------------ diff --git a/src/action_exec.ml b/src/action_exec.ml index 1688d46031c..3f4788a3420 100644 --- a/src/action_exec.ml +++ b/src/action_exec.ml @@ -7,11 +7,7 @@ type exec_context = ; purpose : Process.purpose } -let get_std_output : _ -> Process.std_output_to = function - | None -> Terminal - | Some fn -> File fn - -let exec_run_direct ~ectx ~dir ~env ~stdout_to ~stderr_to prog args = +let exec_run ~ectx ~dir ~env ~stdout_to ~stderr_to prog args = begin match ectx.context with | None | Some { Context.for_host = None; _ } -> () @@ -31,16 +27,8 @@ let exec_run_direct ~ectx ~dir ~env ~stdout_to ~stderr_to prog args = ~purpose:ectx.purpose prog args -let exec_run ~stdout_to ~stderr_to = - let stdout_to = get_std_output stdout_to in - let stderr_to = get_std_output stderr_to in - exec_run_direct ~stdout_to ~stderr_to - let exec_echo stdout_to str = - Fiber.return - (match stdout_to with - | None -> print_string str; flush stdout - | Some fn -> Io.write_file fn str) + Fiber.return (output_string (Process.Output.channel stdout_to) str) let rec exec t ~ectx ~dir ~env ~stdout_to ~stderr_to = match (t : Action.t) with @@ -65,9 +53,7 @@ let rec exec t ~ectx ~dir ~env ~stdout_to ~stderr_to = | Echo strs -> exec_echo stdout_to (String.concat strs ~sep:" ") | Cat fn -> Io.with_file_in fn ~f:(fun ic -> - match stdout_to with - | None -> Io.copy_channels ic stdout - | Some fn -> Io.with_file_out fn ~f:(fun oc -> Io.copy_channels ic oc)); + Io.copy_channels ic (Process.Output.channel stdout_to)); Fiber.return () | Copy (src, dst) -> Io.copy_file ~src ~dst (); @@ -179,16 +165,15 @@ let rec exec t ~ectx ~dir ~env ~stdout_to ~stderr_to = Fiber.return () and redirect outputs fn t ~ectx ~dir ~env ~stdout_to ~stderr_to = - (* We resolve the path to an absolute one here to ensure no - Chdir actions change the eventual path of the file *) - let out = Some (Path.to_absolute fn) in + let out = Process.Output.file fn in let stdout_to, stderr_to = match outputs with | Stdout -> (out, stderr_to) | Stderr -> (stdout_to, out) | Outputs -> (out, out) in - exec t ~ectx ~dir ~env ~stdout_to ~stderr_to + exec t ~ectx ~dir ~env ~stdout_to ~stderr_to >>| fun () -> + Process.Output.release out and exec_list l ~ectx ~dir ~env ~stdout_to ~stderr_to = match l with @@ -197,7 +182,9 @@ and exec_list l ~ectx ~dir ~env ~stdout_to ~stderr_to = | [t] -> exec t ~ectx ~dir ~env ~stdout_to ~stderr_to | t :: rest -> - exec t ~ectx ~dir ~env ~stdout_to ~stderr_to >>= fun () -> + (let stdout_to = Process.Output.multi_use stdout_to in + let stderr_to = Process.Output.multi_use stderr_to in + exec t ~ectx ~dir ~env ~stdout_to ~stderr_to) >>= fun () -> exec_list rest ~ectx ~dir ~env ~stdout_to ~stderr_to let exec ~targets ~context ~env t = @@ -209,4 +196,6 @@ let exec ~targets ~context ~env t = in let purpose = Process.Build_job targets in let ectx = { purpose; context } in - exec t ~ectx ~dir:Path.root ~env ~stdout_to:None ~stderr_to:None + exec t ~ectx ~dir:Path.root ~env + ~stdout_to:Process.Output.stdout + ~stderr_to:Process.Output.stderr diff --git a/src/build.ml b/src/build.ml index 277e16d5929..7027ed48b99 100644 --- a/src/build.ml +++ b/src/build.ml @@ -249,7 +249,7 @@ let symlink ~src ~dst = action ~targets:[dst] (Symlink (src, dst)) let create_file fn = - action ~targets:[fn] (Redirect (Stdout, fn, Echo [])) + action ~targets:[fn] (Redirect (Stdout, fn, Progn [])) let remove_tree dir = arr (fun _ -> Action.Remove_tree dir) diff --git a/src/main.ml b/src/main.ml index e260e281ca4..9d5bc804ca5 100644 --- a/src/main.ml +++ b/src/main.ml @@ -144,7 +144,7 @@ let auto_concurrency = | None -> loop rest | Some prog -> Process.run_capture (Accept All) prog args ~env:Env.initial - ~stderr_to:(File Config.dev_null) + ~stderr_to:(Process.Output.file Config.dev_null) >>= function | Error _ -> loop rest | Ok s -> diff --git a/src/process.ml b/src/process.ml index 78a5c0249cd..7bd3a445ef0 100644 --- a/src/process.ml +++ b/src/process.ml @@ -30,9 +30,67 @@ let map_result | 0 -> Ok (f ()) | n -> Error n -type std_output_to = - | Terminal - | File of Path.t +module Output = struct + type t = + { kind : kind + ; fd : Unix.file_descr Lazy.t + ; channel : out_channel Lazy.t + ; mutable status : status + } + + and kind = + | File of Path.t + | Terminal + + and status = + | Keep_open + | Close_after_exec + | Closed + + let terminal oc = + let fd = Unix.descr_of_out_channel oc in + { kind = Terminal + ; fd = lazy fd + ; channel = lazy stdout + ; status = Keep_open + } + let stdout = terminal stdout + let stderr = terminal stderr + + let file fn = + let fd = + lazy (Unix.openfile (Path.to_string fn) + [O_WRONLY; O_CREAT; O_TRUNC; O_SHARE_DELETE] 0o666) + in + { kind = File fn + ; fd + ; channel = lazy (Unix.out_channel_of_descr (Lazy.force fd)) + ; status = Close_after_exec + } + + let flush t = + if Lazy.is_val t.channel then flush (Lazy.force t.channel) + + let fd t = + flush t; + Lazy.force t.fd + + let channel t = Lazy.force t.channel + + let release t = + match t.status with + | Closed -> () + | Keep_open -> flush t + | Close_after_exec -> + t.status <- Closed; + if Lazy.is_val t.channel then + close_out (Lazy.force t.channel) + else + Unix.close (Lazy.force t.fd) + + let multi_use t = + { t with status = Keep_open } +end type purpose = | Internal_job @@ -101,7 +159,8 @@ module Fancy = struct "-o" :: Colors.(apply_string output_filename) fn :: colorize_args rest | x :: rest -> x :: colorize_args rest - let command_line ~prog ~args ~dir ~stdout_to ~stderr_to = + let command_line ~prog ~args ~dir + ~(stdout_to:Output.t) ~(stderr_to:Output.t) = let prog = Path.reach_for_running ?from:dir prog in let quote = quote_for_shell in let prog = colorize_prog (quote prog) in @@ -113,17 +172,17 @@ module Fancy = struct | None -> s | Some dir -> sprintf "(cd %s && %s)" (Path.to_string dir) s in - match stdout_to, stderr_to with + match stdout_to.kind, stderr_to.kind with | File fn1, File fn2 when Path.equal fn1 fn2 -> sprintf "%s &> %s" s (Path.to_string fn1) | _ -> let s = - match stdout_to with + match stdout_to.kind with | Terminal -> s | File fn -> sprintf "%s > %s" s (Path.to_string fn) in - match stderr_to with + match stderr_to.kind with | Terminal -> s | File fn -> sprintf "%s 2> %s" s (Path.to_string fn) @@ -179,17 +238,6 @@ module Fancy = struct contexts; end -let get_std_output ~default = function - | Terminal -> (default, None) - | File fn -> - let fd = Unix.openfile (Path.to_string fn) - [O_WRONLY; O_CREAT; O_TRUNC; O_SHARE_DELETE] 0o666 in - (fd, Some fd) - -let close_std_output = function - | None -> () - | Some fd -> Unix.close fd - let gen_id = let next = ref (-1) in fun () -> incr next; !next @@ -198,8 +246,8 @@ 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 = +let run_internal ?dir ?(stdout_to=Output.stdout) ?(stderr_to=Output.stderr) + ~env ~purpose fail_mode prog args = Scheduler.wait_for_available_job () >>= fun scheduler -> let display = Scheduler.display scheduler in @@ -234,33 +282,43 @@ let run_internal ?dir ?(stdout_to=Terminal) ?(stderr_to=Terminal) ~env ~purpose (args, None) in let argv = prog_str :: args in - let output_filename, stdout_fd, stderr_fd, to_close = - match stdout_to, stderr_to with + let output_filename, stdout_to, stderr_to = + match stdout_to.kind, stderr_to.kind with | (Terminal, _ | _, Terminal) when !Clflags.capture_outputs -> let fn = Temp.create "dune" ".output" in - let fd = Unix.openfile (Path.to_string fn) [O_WRONLY; O_SHARE_DELETE] 0 in - (Some fn, fd, fd, Some fd) + let terminal = Output.file fn in + let get (out : Output.t) = + if out.kind = Terminal then begin + Output.flush out; + terminal + end else + out + in + (Some fn, get stdout_to, get stderr_to) | _ -> - (None, Unix.stdout, Unix.stderr, None) + (None, stdout_to, stderr_to) in - 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 () = - Spawn.spawn () - ~prog:prog_str - ~argv - ~env:(Spawn.Env.of_array (Env.to_unix env)) - ~stdout - ~stderr + let run = + (* Output.fd might create the file with Unix.openfile. We need to + make sure to call it before doing the chdir as the path might + be relative. *) + let stdout = Output.fd stdout_to in + let stderr = Output.fd stderr_to in + fun () -> + Spawn.spawn () + ~prog:prog_str + ~argv + ~env:(Spawn.Env.of_array (Env.to_unix env)) + ~stdout + ~stderr in let pid = match dir with | None -> run () | Some dir -> Scheduler.with_chdir scheduler ~dir ~f:run in - Option.iter to_close ~f:Unix.close; - close_std_output close_stdout; - close_std_output close_stderr; + Output.release stdout_to; + Output.release stderr_to; Scheduler.wait_for_process pid >>| fun exit_status -> Option.iter response_file ~f:Path.unlink; @@ -334,7 +392,7 @@ let run_capture_gen ?dir ?stderr_to ~env ?(purpose=Internal_job) fail_mode prog args ~f = let fn = Temp.create "dune" ".output" in map_result fail_mode - (run_internal ?dir ~stdout_to:(File fn) ?stderr_to + (run_internal ?dir ~stdout_to:(Output.file fn) ?stderr_to ~env ~purpose fail_mode prog args) ~f:(fun () -> let x = f fn in diff --git a/src/process.mli b/src/process.mli index a3d842929bd..65abd4fbf7f 100644 --- a/src/process.mli +++ b/src/process.mli @@ -14,10 +14,28 @@ type ('a, 'b) failure_mode = (** Accept the following non-zero exit codes, and return [Error code] if the process exists with one of these codes. *) -(** Where to redirect standard output *) -type std_output_to = - | Terminal - | File of Path.t +module Output : sig + (** Where to redirect stdout/stderr *) + type t + + val stdout : t + val stderr : t + + (** Create a [t] representing redirecting the output to a file. The + returned output can only be used by a single call to {!run}. If + you want to use it multiple times, you need to use [clone]. *) + val file : Path.t -> t + + (** Call this when you no longer need this output *) + val release : t -> unit + + (** Return a buffered channel for this output. The channel is + created lazily. *) + val channel : t -> out_channel + + (** [multi_use t] returns a copy for which [release] does nothing *) + val multi_use : t -> t +end (** Why a Fiber.t was run *) type purpose = @@ -27,8 +45,8 @@ type purpose = (** [run ?dir ?stdout_to prog args] spawns a sub-process and wait for its termination *) val run : ?dir:Path.t - -> ?stdout_to:std_output_to - -> ?stderr_to:std_output_to + -> ?stdout_to:Output.t + -> ?stderr_to:Output.t -> env:Env.t -> ?purpose:purpose -> (unit, 'a) failure_mode @@ -39,7 +57,7 @@ val run (** Run a command and capture its output *) val run_capture : ?dir:Path.t - -> ?stderr_to:std_output_to + -> ?stderr_to:Output.t -> env:Env.t -> ?purpose:purpose -> (string, 'a) failure_mode @@ -48,7 +66,7 @@ val run_capture -> 'a Fiber.t val run_capture_line : ?dir:Path.t - -> ?stderr_to:std_output_to + -> ?stderr_to:Output.t -> env:Env.t -> ?purpose:purpose -> (string, 'a) failure_mode @@ -57,11 +75,10 @@ val run_capture_line -> 'a Fiber.t val run_capture_lines : ?dir:Path.t - -> ?stderr_to:std_output_to + -> ?stderr_to:Output.t -> env:Env.t -> ?purpose:purpose -> (string list, 'a) failure_mode -> Path.t -> string list -> 'a Fiber.t - diff --git a/src/stdune/path.ml b/src/stdune/path.ml index 45f0bbf17f6..0795ae98cb7 100644 --- a/src/stdune/path.ml +++ b/src/stdune/path.ml @@ -626,8 +626,6 @@ let of_filename_relative_to_initial_cwd fn = let to_absolute_filename t = Kind.to_absolute_filename (kind t) -let to_absolute t = external_ (External.of_string (to_absolute_filename t)) - let external_of_local x ~root = External.to_string (External.relative root (Local.to_string x)) diff --git a/src/stdune/path.mli b/src/stdune/path.mli index 084eca69f79..f9cc7e3f6b2 100644 --- a/src/stdune/path.mli +++ b/src/stdune/path.mli @@ -66,9 +66,6 @@ val of_filename_relative_to_initial_cwd : string -> t root has been set. [root] is the root directory of local paths *) val to_absolute_filename : t -> string -(** Convert any path to an absolute path *) -val to_absolute : t -> t - val reach : t -> from:t -> string (** [from] defaults to [Path.root] *) diff --git a/test/blackbox-tests/dune.inc b/test/blackbox-tests/dune.inc index d530ec64b93..5709c98f257 100644 --- a/test/blackbox-tests/dune.inc +++ b/test/blackbox-tests/dune.inc @@ -143,6 +143,14 @@ test-cases/dev-flag-1103 (progn (run %{exe:cram.exe} -test run.t) (diff? run.t run.t.corrected))))) +(alias + (name double-echo) + (deps (package dune) (source_tree test-cases/double-echo)) + (action + (chdir + test-cases/double-echo + (progn (run %{exe:cram.exe} -test run.t) (diff? run.t run.t.corrected))))) + (alias (name dune-build-dir-exec-1101) (deps (package dune) (source_tree test-cases/dune-build-dir-exec-1101)) @@ -1179,6 +1187,7 @@ (alias depend-on-the-universe) (alias deps-conf-vars) (alias dev-flag-1103) + (alias double-echo) (alias dune-build-dir-exec-1101) (alias dune-jbuild-var-case) (alias dune-ppx-driver-system) @@ -1323,6 +1332,7 @@ (alias depend-on-the-universe) (alias deps-conf-vars) (alias dev-flag-1103) + (alias double-echo) (alias dune-build-dir-exec-1101) (alias dune-jbuild-var-case) (alias dune-ppx-driver-system) diff --git a/test/blackbox-tests/test-cases/double-echo/dune b/test/blackbox-tests/test-cases/double-echo/dune new file mode 100644 index 00000000000..f057789a1c1 --- /dev/null +++ b/test/blackbox-tests/test-cases/double-echo/dune @@ -0,0 +1,9 @@ +(rule + (with-stdout-to foobar + (progn + (echo "foo") + (echo "bar")))) + +(alias + (name default) + (action (echo %{read:foobar}))) diff --git a/test/blackbox-tests/test-cases/double-echo/dune-project b/test/blackbox-tests/test-cases/double-echo/dune-project new file mode 100644 index 00000000000..4b36203e856 --- /dev/null +++ b/test/blackbox-tests/test-cases/double-echo/dune-project @@ -0,0 +1 @@ +(lang dune 1.6) \ No newline at end of file diff --git a/test/blackbox-tests/test-cases/double-echo/run.t b/test/blackbox-tests/test-cases/double-echo/run.t new file mode 100644 index 00000000000..86fdd4abfa8 --- /dev/null +++ b/test/blackbox-tests/test-cases/double-echo/run.t @@ -0,0 +1,2 @@ + $ dune build + foobar