Revert "Delay opening redirected files until execing cmd (ocaml#1635)"

This reverts commit 59c4daa.

Signed-off-by: Rudi Grinberg <rudi.grinberg@gmail.com>

CHANGES.md

@@ -15,13 +15,10 @@ 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)
 
+>>>>>>> parent of 59c4daa3... Delay opening redirected files until execing cmd (#1635)
 1.6.2 (05/12/2018)
 ------------------
 

src/action_exec.ml

@@ -8,8 +8,12 @@ type exec_context =
   }
 
 let get_std_output : _ -> Process.std_output_to = function
-  | None    -> Terminal
-  | Some fn -> File fn
+  | None          -> Terminal
+  | Some (fn, oc) ->
+    Opened_file { filename = fn
+                ; tail = false
+                ; desc = Channel oc }
+
 
 let exec_run_direct ~ectx ~dir ~env ~stdout_to ~stderr_to prog args =
   begin match ectx.context with
@@ -40,7 +44,7 @@ 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)
+     | Some (_, oc) -> output_string oc str)
 
 let rec exec t ~ectx ~dir ~env ~stdout_to ~stderr_to =
   match (t : Action.t) with
@@ -56,6 +60,15 @@ 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) ->
@@ -65,9 +78,12 @@ 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));
+      let oc =
+        match stdout_to with
+        | None -> stdout
+        | Some (_, oc) -> oc
+      in
+      Io.copy_channels ic oc);
     Fiber.return ()
   | Copy (src, dst) ->
     Io.copy_file ~src ~dst ();
@@ -179,16 +195,16 @@ 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 oc = Io.open_out fn in
+  let out = Some (fn, oc) 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 () ->
+  close_out oc
 
 and exec_list l ~ectx ~dir ~env ~stdout_to ~stderr_to =
   match l with

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/process.ml

@@ -33,6 +33,17 @@ let map_result
 type std_output_to =
   | Terminal
   | File        of Path.t
+  | Opened_file of opened_file
+
+and opened_file =
+  { filename : Path.t
+  ; desc     : opened_file_desc
+  ; tail     : bool
+  }
+
+and opened_file_desc =
+  | Fd      of Unix.file_descr
+  | Channel of out_channel
 
 type purpose =
   | Internal_job
@@ -114,18 +125,19 @@ module Fancy = struct
       | Some dir -> sprintf "(cd %s && %s)" (Path.to_string dir) s
     in
     match stdout_to, stderr_to with
-    | File fn1, File fn2 when Path.equal fn1 fn2 ->
+    | (File fn1 | Opened_file { filename = fn1; _ }),
+      (File fn2 | Opened_file { filename = fn2; _ }) when Path.equal fn1 fn2 ->
       sprintf "%s &> %s" s (Path.to_string fn1)
     | _ ->
       let s =
         match stdout_to with
         | Terminal -> s
-        | File fn ->
+        | File fn | Opened_file { filename = fn; _ } ->
           sprintf "%s > %s" s (Path.to_string fn)
       in
       match stderr_to with
       | Terminal -> s
-      | File fn ->
+      | File fn | Opened_file { filename = fn; _ } ->
         sprintf "%s 2> %s" s (Path.to_string fn)
 
   let pp_purpose ppf = function
@@ -184,11 +196,19 @@ let get_std_output ~default = function
   | File fn ->
     let fd = Unix.openfile (Path.to_string fn)
                [O_WRONLY; O_CREAT; O_TRUNC; O_SHARE_DELETE] 0o666 in
-    (fd, Some fd)
+    (fd, Some (Fd fd))
+  | Opened_file { desc; tail; _ } ->
+    let fd =
+      match desc with
+      | Fd      fd -> fd
+      | Channel oc -> flush oc; Unix.descr_of_out_channel oc
+    in
+    (fd, Option.some_if tail desc)
 
 let close_std_output = function
   | None -> ()
-  | Some fd -> Unix.close fd
+  | Some (Fd      fd) -> Unix.close fd
+  | Some (Channel oc) -> close_out  oc
 
 let gen_id =
   let next = ref (-1) in

src/process.mli

@@ -18,6 +18,18 @@ type ('a, 'b) failure_mode =
 type std_output_to =
   | Terminal
   | File        of Path.t
+  | Opened_file of opened_file
+
+and opened_file =
+  { filename : Path.t
+  ; desc     : opened_file_desc
+  ; tail     : bool
+  (** If [true], the descriptor is closed after starting the command *)
+  }
+
+and opened_file_desc =
+  | Fd      of Unix.file_descr
+  | Channel of out_channel
 
 (** Why a Fiber.t was run *)
 type purpose =

src/stdune/path.ml

@@ -643,8 +643,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))
 

src/stdune/path.mli

@@ -76,9 +76,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] *)

test/blackbox-tests/test-cases/double-echo/run.t

@@ -1,2 +1,2 @@
   $ dune build
-  bar
+  foobar

test/blackbox-tests/test-cases/enabled_if/run.t

@@ -15,6 +15,4 @@ This rule is disabled, trying to build a should fail:
 
 This one is enabled:
   $ dune build b
-  Building file bError: Rule failed to generate the following targets:
-  - b
-  [1]
+  Building file b

test/blackbox-tests/test-cases/inline_tests/run.t

@@ -51,4 +51,4 @@
       (echo "\n")
       (echo "let () = print_int 43;;")))))
            run alias dune-file/runtest
-  43
+  414243

test/blackbox-tests/test-cases/redirections/run.t

@@ -4,16 +4,5 @@
           diff alias runtest
             sh both
             sh both
-          diff alias runtest (exit 1)
-  (cd _build/default && /usr/bin/diff -uw both.expected both)
-  --- both.expected	2018-12-11 23:49:42.000000000 +0100
-  +++ both	2018-12-11 23:49:42.000000000 +0100
-  @@ -1,2 +1 @@
-  -toto
-   titi
-          diff alias runtest (exit 1)
-  (cd _build/default && /usr/bin/diff -uw stdout.expected stdout)
-  --- stdout.expected	2018-12-11 23:49:42.000000000 +0100
-  +++ stdout	2018-12-11 23:49:42.000000000 +0100
-  @@ -1 +0,0 @@
-  -toto
+          diff alias runtest
+          diff alias runtest

test/unit-tests/path.mlt

@@ -134,7 +134,6 @@ Path.(descendant (relative build_dir "foo") ~of_:(absolute "/foo/bar"))
 [%%expect{|
 File "test/unit-tests/path.mlt", line 133, characters 50-58:
 Error: Unbound value absolute
-Hint: Did you mean to_absolute?
 |}]
 
 Path.(descendant (relative build_dir "foo/bar") ~of_:build_dir)
@@ -156,7 +155,6 @@ Path.(descendant (absolute "/foo/bar") ~of_:(absolute "/foo"))
 [%%expect{|
 File "test/unit-tests/path.mlt", line 154, characters 18-26:
 Error: Unbound value absolute
-Hint: Did you mean to_absolute?
 |}]
 
 Path.explode (Path.of_string "a/b/c");