From eeccb4c317bc5a5cd7adae67f5c19fa7d999b0c0 Mon Sep 17 00:00:00 2001
From: Jon Ludlam <jon@Davids-MacBook.local>
Date: Tue, 11 Dec 2018 09:07:28 +0000
Subject: [PATCH] Delay opening redirected files until execing cmd

This avoids an issue where the redirected output would be opened
before there was a slot available to execute a command, consuming
fds unnecessarily.

Issue #1633 was an instance of this hitting the default limit on
MacOS of 256 fds.

Signed-off-by: Jon Ludlam <jon@recoil.org>
---
 src/action_exec.ml  | 35 +++++++++--------------------------
 src/build.ml        |  2 +-
 src/stdune/path.ml  |  2 ++
 src/stdune/path.mli |  3 +++
 4 files changed, 15 insertions(+), 27 deletions(-)

diff --git a/src/action_exec.ml b/src/action_exec.ml
index fc2b291a3eaa..ebc6b83e60b5 100644
--- a/src/action_exec.ml
+++ b/src/action_exec.ml
@@ -8,12 +8,8 @@ type exec_context =
   }
 
 let get_std_output : _ -> Process.std_output_to = function
-  | None          -> Terminal
-  | Some (fn, oc) ->
-    Opened_file { filename = fn
-                ; tail = false
-                ; desc = Channel oc }
-
+  | None    -> Terminal
+  | Some fn -> File fn
 
 let exec_run_direct ~ectx ~dir ~env ~stdout_to ~stderr_to prog args =
   begin match ectx.context with
@@ -44,7 +40,7 @@ let exec_echo stdout_to str =
   Fiber.return
     (match stdout_to with
      | None -> print_string str; flush stdout
-     | Some (_, oc) -> output_string oc str)
+     | Some fn -> Io.with_file_out fn ~f:(fun oc -> output_string oc str))
 
 let rec exec t ~ectx ~dir ~env ~stdout_to ~stderr_to =
   match (t : Action.t) with
@@ -60,15 +56,6 @@ let rec exec t ~ectx ~dir ~env ~stdout_to ~stderr_to =
   | Redirect (Stdout, fn, Echo s) ->
     Io.write_file fn (String.concat s ~sep:" ");
     Fiber.return ()
-  | Redirect (outputs, fn, Run (Ok prog, args)) ->
-    let out = Process.File fn in
-    let stdout_to, stderr_to =
-      match outputs with
-      | Stdout -> (out, get_std_output stderr_to)
-      | Stderr -> (get_std_output stdout_to, out)
-      | Outputs -> (out, out)
-    in
-    exec_run_direct ~ectx ~dir ~env ~stdout_to ~stderr_to prog args
   | Redirect (outputs, fn, t) ->
     redirect ~ectx ~dir outputs fn t ~env ~stdout_to ~stderr_to
   | Ignore (outputs, t) ->
@@ -78,12 +65,9 @@ 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 ->
-      let oc =
-        match stdout_to with
-        | None -> stdout
-        | Some (_, oc) -> oc
-      in
-      Io.copy_channels ic oc);
+      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));
     Fiber.return ()
   | Copy (src, dst) ->
     Io.copy_file ~src ~dst ();
@@ -195,16 +179,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 =
-  let oc = Io.open_out fn in
-  let out = Some (fn, oc) in
+  let abs = Path.to_absolute fn in
+  let out = Some abs 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 >>| fun () ->
-  close_out oc
+  exec t ~ectx ~dir ~env ~stdout_to ~stderr_to
 
 and exec_list l ~ectx ~dir ~env ~stdout_to ~stderr_to =
   match l with
diff --git a/src/build.ml b/src/build.ml
index 7027ed48b992..277e16d5929d 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, Progn []))
+  action ~targets:[fn] (Redirect (Stdout, fn, Echo []))
 
 let remove_tree dir =
   arr (fun _ -> Action.Remove_tree dir)
diff --git a/src/stdune/path.ml b/src/stdune/path.ml
index 0a321d9f439a..003381fb41a8 100644
--- a/src/stdune/path.ml
+++ b/src/stdune/path.ml
@@ -643,6 +643,8 @@ 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 e40c6c477423..c00d36828813 100644
--- a/src/stdune/path.mli
+++ b/src/stdune/path.mli
@@ -76,6 +76,9 @@ 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] *)