Revert #1635 + fix for #1633

CHANGES.md

@@ -15,13 +15,14 @@ unreleased
 - 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)
 ------------------
 

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

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)

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 ->

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

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
-