From b604871aab73d7157f7f473991ae333fc7e759e8 Mon Sep 17 00:00:00 2001
From: David Allsopp <david.allsopp@metastack.com>
Date: Thu, 8 Mar 2018 18:28:14 +0000
Subject: [PATCH] Limit number of simultaneously opened fds (#578)

Non-optimal solution: only handles the common case.
---
 CHANGES.md    |  2 ++
 src/action.ml | 18 +++++++++++++++---
 2 files changed, 17 insertions(+), 3 deletions(-)

diff --git a/CHANGES.md b/CHANGES.md
index 420343f7..aeb80968 100644
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -3,6 +3,8 @@ next
 
 - Ignore errors during the generation of the .merlin (#569, fixes #568 and #51)
 
+- Reduce the number of simultaneously opened fds (#578)
+
 - Add a workaround for when a library normally installed by the
   compiler is not installed but still has a META file (#574, fixes
   #563)
diff --git a/src/action.ml b/src/action.ml
index 8517f286..24fb19b9 100644
--- a/src/action.ml
+++ b/src/action.ml
@@ -702,7 +702,7 @@ type exec_context =
   ; env     : string array
   }
 
-let exec_run ~ectx ~dir ~env_extra ~stdout_to ~stderr_to prog args =
+let exec_run_direct ~ectx ~dir ~env_extra ~stdout_to ~stderr_to prog args =
   begin match ectx.context with
    | None
    | Some { Context.for_host = None; _ } -> ()
@@ -717,13 +717,16 @@ let exec_run ~ectx ~dir ~env_extra ~stdout_to ~stderr_to prog args =
      invalid_prefix ("_build/" ^ target.name);
      invalid_prefix ("_build/install/" ^ target.name);
   end;
-  let stdout_to = get_std_output stdout_to in
-  let stderr_to = get_std_output stderr_to in
   let env = Context.extend_env ~vars:env_extra ~env:ectx.env in
   Process.run Strict ~dir:(Path.to_string dir) ~env ~stdout_to ~stderr_to
     ~purpose:ectx.purpose
     (Path.reach_for_running ~from:dir 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
@@ -744,6 +747,15 @@ let rec exec t ~ectx ~dir ~env_extra ~stdout_to ~stderr_to =
   | Redirect (Stdout, fn, Echo s) ->
     Io.write_file (Path.to_string fn) s;
     Fiber.return ()
+  | Redirect (outputs, fn, Run (Ok prog, args)) ->
+    let out = Process.File (Path.to_string 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_extra ~stdout_to ~stderr_to prog args
   | Redirect (outputs, fn, t) ->
     redirect ~ectx ~dir outputs fn t ~env_extra ~stdout_to ~stderr_to
   | Ignore (outputs, t) ->