feature: concurrency action

CHANGES.md

@@ -28,6 +28,9 @@ Unreleased
 - Bytecode executables built for JSOO are linked with `-noautolink` and no
   longer depend on the shared stubs of their dependent libraries (#7156, @nojb)
 
+- Added a new user action `(concurrent )` which is like `(progn )` but runs the
+  actions concurrently. (#6933, @Alizter)
+
 3.7.0 (2023-02-17)
 ------------------
 

doc/concepts.rst

@@ -789,6 +789,11 @@ 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
+- ``(concurrent <DSL>...)``` to execute several commands concurrently
+  and collect all resulting errors, if any.
+  **Warning:** The concurrency is limited by the `-j` flag passed to Dune.
+  In particular, if Dune is running with `-j 1`, these commands will actually
+  run sequentially, which may cause a deadlock if they talk to each other.
 - ``(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)
+    | Concurrent l -> List (atom "concurrent" :: 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 concurrent ts = Concurrent 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) | Concurrent 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) | Concurrent 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) | Concurrent 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
@@ -273,6 +282,9 @@ let rec exec t ~display ~ectx ~eenv =
   | Ignore (outputs, t) ->
     redirect_out t ~display ~ectx ~eenv ~perm:Normal outputs Config.dev_null
   | Progn ts -> exec_list ts ~display ~ectx ~eenv
+  | Concurrent ts ->
+    Fiber.parallel_map ts ~f:(exec ~display ~ectx ~eenv)
+    >>| List.fold_left ~f:done_or_more_deps_union ~init:Done
   | Echo strs ->
     let+ () = exec_echo eenv.stdout_to (String.concat strs ~sep:" ") in
     Done

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
+    | Concurrent 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 concurrent : 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))
+    | Concurrent l -> Concurrent (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

@@ -15,6 +15,7 @@ module Simplified = struct
     | Redirect_in of t list * Inputs.t * source
     | Pipe of t list list * Outputs.t
     | Sh of string
+    | Concurrent of t list list
 end
 
 open Simplified
@@ -55,6 +56,7 @@ 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)
+    | Concurrent l -> Concurrent (List.map ~f:block l) :: acc
     | Echo xs -> echo (String.concat xs ~sep:"")
     | Cat x -> cat x :: acc
     | Copy (x, y) -> Run ("cp", [ x; y ]) :: acc
@@ -172,6 +174,27 @@ and pp = function
            ; Pp.concat ~sep:(Pp.verbatim " | ") (List.map l ~f:block)
            ; Pp.verbatim end_
            ]))
+  | Concurrent t -> (
+    match t with
+    | [] -> Pp.verbatim "true"
+    | [ x ] -> block x
+    | x :: l ->
+      Pp.hovbox ~indent:2
+        (Pp.concat
+           [ Pp.char '('
+           ; Pp.space
+           ; block x
+           ; Pp.space
+           ; Pp.char '&'
+           ; Pp.space
+           ; Pp.concat ~sep:(Pp.verbatim "&") (List.map l ~f:block)
+           ; Pp.space
+           ; Pp.char '&'
+           ; Pp.space
+           ; Pp.verbatim "wait"
+           ; Pp.space
+           ; Pp.verbatim ")"
+           ]))
 
 let rec pp_seq = function
   | [] -> Pp.verbatim "true"

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
+  | Concurrent 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)
+        ; ( "concurrent"
+          , Syntax.since Stanza.syntax (3, 8) >>> repeat t >>| fun l ->
+            Concurrent 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)
+  | Concurrent l -> List (atom "concurrent" :: 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 | Concurrent 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))
+  | Concurrent xs -> Concurrent (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
+  | Concurrent 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
+  | Concurrent l ->
+    let+ l = A.all (List.map l ~f:expand) in
+    O.Concurrent 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/concurrent-multi-diff.t/A

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

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

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

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

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

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

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

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

@@ -0,0 +1,84 @@
+The use of (concurrent ) illustrated 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 A A.diff)
+  >    (diff B B.diff)
+  >    (diff C 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 (concurrent ) 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
+  >   (concurrent
+  >    (with-outputs-to some-target (echo a))
+  >    (diff A A.diff)
+  >    (diff B B.diff)
+  >    (diff C 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/concurrent.t

@@ -0,0 +1,59 @@
+Specification of the concurrency action:
+
+  $ cat > dune-project << EOF
+  > (lang dune 3.7)
+  > EOF
+
+  $ cat > dune << EOF
+  > (rule
+  >  (action
+  >   (concurrent )))
+  > EOF
+
+  $ dune build
+  File "dune", line 3, characters 2-15:
+  3 |   (concurrent )))
+        ^^^^^^^^^^^^^
+  Error: 'concurrent' is only available since version 3.8 of the dune language.
+  Please update your dune-project file to have (lang dune 3.8).
+  [1]
+
+Requires Dune 3.8.
+
+  $ cat > dune-project << EOF
+  > (lang dune 3.8)
+  > EOF
+
+(concurrent ...) runs actions concurrently. Here we mock up an example where two
+subactions rely on eachother to also be running in order to terminate.
+
+We write a shell script that will similtaneously read and write to two named
+pipes. (This has to be similtaneious otherwise the read will block the write).
+They will block on the read however, which means if called with the same two
+pipes but swapped, they will only terminate when both scripts are running at the
+same time.
+  $ cat > run.sh << EOF
+  > #!/bin/bash
+  > echo foo>\$1 & read line<\$2
+  > EOF
+  $ chmod +x run.sh
+
+We create an action that will create named pipes a and b and then run our script
+on both of them, but importantly inside the concurrent action. This will
+demonstrate that subactions are indeed being run concurrently. 
+  $ cat > dune << EOF
+  > (rule
+  >  (alias my-rule)
+  >  (action
+  >   (progn
+  >    (run mkfifo a b)
+  >    (concurrent
+  >     (run ./run.sh a b)
+  >     (run ./run.sh b a)))))
+  > EOF
+
+When we run the rule, we see that the two actions are indeed run concurrently.
+  $ dune build -j2 @my-rule --force
+
+Notice the need for a -j2. If Dune was configured with -j1 then the action would
+never terminate.

test/blackbox-tests/test-cases/dune-cache/mode-copy.t

@@ -36,9 +36,9 @@ never built [target1] before.
   $ dune build --config-file=config target1 --debug-cache=shared,workspace-local \
   >   2>&1 | grep '_build/default/source\|_build/default/target'
   Workspace-local cache miss: _build/default/source: never seen this target before
-  Shared cache miss [46613c392d7e1d9e094764e41ad65596] (_build/default/source): not found in cache
+  Shared cache miss [d2795abc8100d9bed0c2d5281485488c] (_build/default/source): not found in cache
   Workspace-local cache miss: _build/default/target1: never seen this target before
-  Shared cache miss [ad917d574b21794a34fb1eb2c67ed0a6] (_build/default/target1): not found in cache
+  Shared cache miss [85cfda404207853df742b1c0edd00cb9] (_build/default/target1): not found in cache
 
   $ dune_cmd stat hardlinks _build/default/source
   1

test/blackbox-tests/test-cases/dune-cache/mode-hardlink.t

@@ -35,9 +35,9 @@ never built [target1] before.
   $ dune build --config-file=config target1 --debug-cache=shared,workspace-local \
   >   2>&1 | grep '_build/default/source\|_build/default/target'
   Workspace-local cache miss: _build/default/source: never seen this target before
-  Shared cache miss [46613c392d7e1d9e094764e41ad65596] (_build/default/source): not found in cache
+  Shared cache miss [d2795abc8100d9bed0c2d5281485488c] (_build/default/source): not found in cache
   Workspace-local cache miss: _build/default/target1: never seen this target before
-  Shared cache miss [ad917d574b21794a34fb1eb2c67ed0a6] (_build/default/target1): not found in cache
+  Shared cache miss [85cfda404207853df742b1c0edd00cb9] (_build/default/target1): not found in cache
 
   $ dune_cmd stat hardlinks _build/default/source
   3