feature: concurrency action

Signed-off-by: Ali Caglayan <alizter@gmail.com>

<!-- ps-id: 28962076-9451-4253-be23-14d44a88eec0 -->

Signed-off-by: Ali Caglayan <alizter@gmail.com>

CHANGES.md

@@ -1,6 +1,9 @@
 Unreleased
 ----------
 
+- Added a new user action `(conc )` which is like `(run )` but runs the
+  actions concurrently. (#6933, @Alizter)
+
 - Fix `--trace-file` output. Dune now emits a single *complete* event for every
   executed process. Unterminated *async* events are no longer written. (#6892,
   @rgrinberg)

doc/concepts.rst

@@ -790,6 +790,7 @@ The following constructions are available:
   ``setenv``, ``ignore-<outputs>``, ``with-stdin-from`` and
   ``with-<outputs>-to``. This action is available since Dune 2.0.
 - ``(progn <DSL>...)`` to execute several commands in sequence
+- ``(conc <DSL>...)``` to execute several commands concurrently.
 - ``(echo <string>)`` to output a string on stdout
 - ``(write-file <file> <string>)`` writes ``<string>`` to ``<file>``
 - ``(cat <file> ...)`` to sequentially print the contents of files to stdout

src/dune_engine/action.ml

@@ -61,6 +61,7 @@ struct
     | Ignore (outputs, r) ->
       List [ atom (sprintf "ignore-%s" (Outputs.to_string outputs)); encode r ]
     | Progn l -> List (atom "progn" :: List.map l ~f:encode)
+    | Conc l -> List (atom "conc" :: List.map l ~f:encode)
     | Echo xs -> List (atom "echo" :: List.map xs ~f:string)
     | Cat xs -> List (atom "cat" :: List.map xs ~f:path)
     | Copy (x, y) -> List [ atom "copy"; path x; target y ]
@@ -118,6 +119,8 @@ struct
 
   let progn ts = Progn ts
 
+  let conc ts = Conc ts
+
   let echo s = Echo s
 
   let cat ps = Cat ps
@@ -289,7 +292,7 @@ let fold_one_step t ~init:acc ~f =
   | Redirect_in (_, _, t)
   | Ignore (_, t)
   | With_accepted_exit_codes (_, t) -> f acc t
-  | Progn l | Pipe (_, l) -> List.fold_left l ~init:acc ~f
+  | Progn l | Pipe (_, l) | Conc l -> List.fold_left l ~init:acc ~f
   | Run _
   | Dynamic_run _
   | Echo _
@@ -337,7 +340,7 @@ let rec is_dynamic = function
   | Redirect_in (_, _, t)
   | Ignore (_, t)
   | With_accepted_exit_codes (_, t) -> is_dynamic t
-  | Progn l | Pipe (_, l) -> List.exists l ~f:is_dynamic
+  | Progn l | Pipe (_, l) | Conc l -> List.exists l ~f:is_dynamic
   | Run _
   | System _
   | Bash _
@@ -386,7 +389,7 @@ let is_useful_to distribute memoize =
     | Redirect_out (_, _, _, t) -> memoize || loop t
     | Redirect_in (_, _, t) -> loop t
     | Ignore (_, t) | With_accepted_exit_codes (_, t) -> loop t
-    | Progn l | Pipe (_, l) -> List.exists l ~f:loop
+    | Progn l | Pipe (_, l) | Conc l -> List.exists l ~f:loop
     | Echo _ -> false
     | Cat _ -> memoize
     | Copy _ -> memoize

src/dune_engine/action_exec.ml

@@ -67,6 +67,15 @@ type done_or_more_deps =
      subdirectories that contains targets having the same name. *)
   | Need_more_deps of (DAP.Dependency.Set.t * Dynamic_dep.Set.t)
 
+let done_or_more_deps_union x y =
+  match (x, y) with
+  | Done, Done -> Done
+  | Done, Need_more_deps x | Need_more_deps x, Done -> Need_more_deps x
+  | Need_more_deps (deps1, dyn_deps1), Need_more_deps (deps2, dyn_deps2) ->
+    Need_more_deps
+      ( DAP.Dependency.Set.union deps1 deps2
+      , Dynamic_dep.Set.union dyn_deps1 dyn_deps2 )
+
 type exec_context =
   { targets : Targets.Validated.t option
   ; context : Build_context.t option
@@ -271,6 +280,7 @@ let rec exec t ~ectx ~eenv =
   | Ignore (outputs, t) ->
     redirect_out t ~ectx ~eenv ~perm:Normal outputs Config.dev_null
   | Progn ts -> exec_list ts ~ectx ~eenv
+  | Conc ts -> exec_list_concurrent ts ~ectx ~eenv
   | Echo strs ->
     let+ () = exec_echo eenv.stdout_to (String.concat strs ~sep:" ") in
     Done
@@ -447,6 +457,13 @@ and exec_list ts ~ectx ~eenv =
     | Need_more_deps _ as need -> Fiber.return need
     | Done -> exec_list rest ~ectx ~eenv)
 
+and exec_list_concurrent ts ~ectx ~eenv =
+  Fiber.parallel_map ts ~f:(fun t ->
+      exec t ~ectx ~eenv >>= function
+      | Need_more_deps _ as need -> Fiber.return need
+      | Done -> Fiber.return Done)
+  >>| List.fold_left ~f:done_or_more_deps_union ~init:Done
+
 and exec_pipe outputs ts ~ectx ~eenv =
   let tmp_file () =
     Dtemp.file ~prefix:"dune-pipe-action-"

src/dune_engine/action_intf.ml

@@ -41,6 +41,7 @@ module type Ast = sig
     | Redirect_in of Inputs.t * path * t
     | Ignore of Outputs.t * t
     | Progn of t list
+    | Conc of t list
     | Echo of string list
     | Cat of path list
     | Copy of path * target
@@ -91,6 +92,8 @@ module type Helpers = sig
 
   val progn : t list -> t
 
+  val conc : t list -> t
+
   val echo : string list -> t
 
   val cat : path list -> t

src/dune_engine/action_mapper.ml

@@ -30,6 +30,7 @@ module Make (Src : Action_intf.Ast) (Dst : Action_intf.Ast) = struct
       Redirect_in (inputs, f_path ~dir fn, f t ~dir)
     | Ignore (outputs, t) -> Ignore (outputs, f t ~dir)
     | Progn l -> Progn (List.map l ~f:(fun t -> f t ~dir))
+    | Conc l -> Conc (List.map l ~f:(fun t -> f t ~dir))
     | Echo xs -> Echo (List.map xs ~f:(f_string ~dir))
     | Cat xs -> Cat (List.map xs ~f:(f_path ~dir))
     | Copy (x, y) -> Copy (f_path ~dir x, f_target ~dir y)

src/dune_engine/action_to_sh.ml

@@ -55,6 +55,9 @@ let simplify act =
     | Ignore (outputs, act) ->
       Redirect_out (block act, outputs, Dev_null) :: acc
     | Progn l -> List.fold_left l ~init:acc ~f:(fun acc act -> loop act acc)
+    | Conc l ->
+      (* For now same as progn *)
+      List.fold_left l ~init:acc ~f:(fun acc act -> loop act acc)
     | Echo xs -> echo (String.concat xs ~sep:"")
     | Cat x -> cat x :: acc
     | Copy (x, y) -> Run ("cp", [ x; y ]) :: acc

src/dune_lang/action.ml

@@ -85,6 +85,7 @@ type t =
   | Redirect_in of Inputs.t * String_with_vars.t * t
   | Ignore of Outputs.t * t
   | Progn of t list
+  | Conc of t list
   | Echo of String_with_vars.t list
   | Cat of String_with_vars.t list
   | Copy of String_with_vars.t * String_with_vars.t
@@ -210,6 +211,9 @@ let decode =
         ; ("ignore-stderr", t >>| fun t -> Ignore (Stderr, t))
         ; ("ignore-outputs", t >>| fun t -> Ignore (Outputs, t))
         ; ("progn", repeat t >>| fun l -> Progn l)
+        ; ( "conc"
+          , Syntax.since Stanza.syntax (3, 7) >>> repeat t >>| fun l -> Conc l
+          )
         ; ( "echo"
           , let+ x = sw
             and+ xs = repeat sw in
@@ -299,6 +303,7 @@ let rec encode =
   | Ignore (outputs, r) ->
     List [ atom (sprintf "ignore-%s" (Outputs.to_string outputs)); encode r ]
   | Progn l -> List (atom "progn" :: List.map l ~f:encode)
+  | Conc l -> List (atom "conc" :: List.map l ~f:encode)
   | Echo xs -> List (atom "echo" :: List.map xs ~f:sw)
   | Cat xs -> List (atom "cat" :: List.map xs ~f:sw)
   | Copy (x, y) -> List [ atom "copy"; sw x; sw y ]
@@ -355,7 +360,7 @@ let ensure_at_most_one_dynamic_run ~loc action =
     | Mkdir _
     | Diff _
     | Cram _ -> false
-    | Pipe (_, ts) | Progn ts ->
+    | Pipe (_, ts) | Progn ts | Conc ts ->
       List.fold_left ts ~init:false ~f:(fun acc t ->
           let have_dyn = loop t in
           if acc && have_dyn then
@@ -383,6 +388,7 @@ let rec map_string_with_vars t ~f =
   | Redirect_in (i, sw, t) -> Redirect_in (i, f sw, t)
   | Ignore (o, t) -> Ignore (o, map_string_with_vars t ~f)
   | Progn xs -> Progn (List.map xs ~f:(map_string_with_vars ~f))
+  | Conc xs -> Conc (List.map xs ~f:(map_string_with_vars ~f))
   | Echo xs -> Echo xs
   | Cat xs -> Cat (List.map ~f xs)
   | Copy (sw1, sw2) -> Copy (f sw1, f sw2)

src/dune_lang/action.mli

@@ -78,6 +78,7 @@ type t =
   | Redirect_in of Inputs.t * String_with_vars.t * t
   | Ignore of Outputs.t * t
   | Progn of t list
+  | Conc of t list
   | Echo of String_with_vars.t list
   | Cat of String_with_vars.t list
   | Copy of String_with_vars.t * String_with_vars.t

src/dune_rules/action_unexpanded.ml

@@ -417,6 +417,9 @@ let rec expand (t : Dune_lang.Action.t) ~context : Action.t Action_expander.t =
   | Progn l ->
     let+ l = A.all (List.map l ~f:expand) in
     O.Progn l
+  | Conc l ->
+    let+ l = A.all (List.map l ~f:expand) in
+    O.Conc l
   | Echo xs ->
     let+ l = A.all (List.map xs ~f:E.strings) in
     let l = List.concat l in

test/blackbox-tests/test-cases/actions/conc-multi-diff.t/A

@@ -0,0 +1 @@
+I am file A.

test/blackbox-tests/test-cases/actions/conc-multi-diff.t/B

@@ -0,0 +1 @@
+I am file B.

test/blackbox-tests/test-cases/actions/conc-multi-diff.t/C

@@ -0,0 +1 @@
+I am file C.

test/blackbox-tests/test-cases/actions/conc-multi-diff.t/dune-project

@@ -0,0 +1 @@
+(lang dune 3.7)

test/blackbox-tests/test-cases/actions/conc-multi-diff.t/run.t

@@ -0,0 +1,84 @@
+Illustration of the use of (conc ) in the context of diffing multiple files.
+
+Say we want to diff 3 files.
+  $ cat A
+  I am file A.
+  $ cat B
+  I am file B.
+  $ cat C
+  I am file C.
+
+We set up a (progn ) rule to diff all of them against their generated versions.
+
+  $ cat > dune << EOF
+  > (rule
+  >  (action
+  >   (progn
+  >    (with-outputs-to A.diff (echo "I am file A.\n"))
+  >    (with-outputs-to B.diff (echo "I am certainly file B.\n"))
+  >    (with-outputs-to C.diff (echo "I am most certainly file C.\n")))))
+  > 
+  > (rule
+  >  (action
+  >   (progn
+  >    (with-outputs-to some-target (echo a))
+  >    (diff %{dep:A} %{dep:A.diff})
+  >    (diff %{dep:B} %{dep:B.diff})
+  >    (diff %{dep:C} %{dep:C.diff}))))
+  > EOF
+
+We can now run the rule and see that we fail before diffing C.
+
+  $ dune build
+  File "B", line 1, characters 0-0:
+  Error: Files _build/default/B and _build/default/B.diff differ.
+  [1]
+
+We can check which diffs were run by asking Dune to promote the files.
+
+  $ dune promotion apply
+  Promoting _build/default/B.diff to B.
+
+Since we failed early, only B was promoted.
+
+Let's reset B to its original state.
+
+  $ rm B
+  $ cat > B << EOF
+  > I am file B.
+  > EOF
+
+If we implement the rule using (conc ) instead.
+
+  $ cat > dune << EOF
+  > (rule
+  >  (action
+  >   (progn
+  >    (with-outputs-to A.diff (echo "I am file A.\n"))
+  >    (with-outputs-to B.diff (echo "I am certainly file B.\n"))
+  >    (with-outputs-to C.diff (echo "I am most certainly file C.\n")))))
+  > 
+  > (rule
+  >  (action
+  >   (conc
+  >    (with-outputs-to some-target (echo a))
+  >    (diff %{dep:A} %{dep:A.diff})
+  >    (diff %{dep:B} %{dep:B.diff})
+  >    (diff %{dep:C} %{dep:C.diff}))))
+  > EOF
+
+We see that all the files get diffed.
+
+  $ dune build
+  File "B", line 1, characters 0-0:
+  Error: Files _build/default/B and _build/default/B.diff differ.
+  File "C", line 1, characters 0-0:
+  Error: Files _build/default/C and _build/default/C.diff differ.
+  [1]
+
+And we have promotions for the two that failed.
+
+  $ dune promote
+  Promoting _build/default/B.diff to B.
+  Promoting _build/default/C.diff to C.
+

test/blackbox-tests/test-cases/actions/conc.t

@@ -0,0 +1,107 @@
+Specification of the concurrency action:
+
+  $ cat > dune-project << EOF
+  > (lang dune 3.6)
+  > EOF
+
+  $ cat > dune << EOF
+  > (rule
+  >  (action
+  >   (conc )))
+  > EOF
+
+  $ dune build
+  File "dune", line 3, characters 2-9:
+  3 |   (conc )))
+        ^^^^^^^
+  Error: 'conc' is only available since version 3.7 of the dune language.
+  Please update your dune-project file to have (lang dune 3.7).
+  [1]
+
+Requires Dune 3.7.
+
+  $ cat > dune-project << EOF
+  > (lang dune 3.7)
+  > EOF
+
+It works just like progn.
+
+  $ dune build
+  File "dune", line 1, characters 0-26:
+  1 | (rule
+  2 |  (action
+  3 |   (conc )))
+  Error: Rule has no targets specified
+  [1]
+
+  $ cat > dune << EOF
+  > (rule
+  >  (action
+  >   (conc
+  >    (progn (system "") (echo "A\n"))
+  >    (progn (echo "B\n"))
+  >    (with-outputs-to some-target (progn) ))))
+  > EOF
+
+But runs the actions concurrently. Seen here by adding some delay to the
+printing of A.
+
+  $ dune build
+  B
+  A
+
+Another key difference is that errors do not stop the whole action.
+
+Here is the situation for (progn ):
+
+  $ cat > dune << EOF
+  > (rule
+  >  (action
+  >   (progn
+  >    (progn (echo "A!\n"))
+  >    (progn (system "exit 1") (echo B))
+  >    (progn (echo "C\n"))
+  >    (with-outputs-to some-target (echo some-target)))))
+  > EOF
+
+  $ dune build
+  A!
+  File "dune", line 1, characters 0-165:
+  1 | (rule
+  2 |  (action
+  3 |   (progn
+  4 |    (progn (echo "A!\n"))
+  5 |    (progn (system "exit 1") (echo B))
+  6 |    (progn (echo "C\n"))
+  7 |    (with-outputs-to some-target (echo some-target)))))
+  Command exited with code 1.
+  [1]
+
+And here is the situation for (conc ):
+
+  $ cat > dune << EOF
+  > (rule
+  >  (action
+  >   (conc
+  >    (progn (echo "A\n"))
+  >    (progn (system "exit 1") (echo B))
+  >    (progn (echo "C\n"))
+  >    (with-outputs-to some-target (echo some-target)))))
+  > EOF
+
+  $ dune build
+  A
+  File "dune", line 1, characters 0-163:
+  1 | (rule
+  2 |  (action
+  3 |   (conc
+  4 |    (progn (echo "A\n"))
+  5 |    (progn (system "exit 1") (echo B))
+  6 |    (progn (echo "C\n"))
+  7 |    (with-outputs-to some-target (echo some-target)))))
+  Command exited with code 1.
+  C
+  [1]
+
+As you can see, even though C occurs after the failing action for B, it still
+runs due to concurrency.