feat(cli): parallel tests, target names in explain and graph

bin/meowc.ml

@@ -14,7 +14,7 @@ let usage =
       "    meowc configure               run the checks and write the config header";
       "    meowc check                   parse and validate, build nothing";
       "    meowc targets                 list every target";
-      "    meowc graph [--dot]           show the dependency graph";
+      "    meowc graph [target...]       show the dependency graph, --dot for graphviz";
       "    meowc explain <file>          say why a file is or is not up to date";
       "    meowc compdb                  write compile_commands.json";
       "    meowc watch [target...]       rebuild whenever an input changes";
@@ -194,7 +194,7 @@ let on_done ~ok ~log (n : Graph.node) =
   if ok then Printf.printf "  %s%s\n" (Build.paint n.tag (Style.pad 8 n.tag)) n.label
   else
     Printf.printf "  %s%s\n%s\n" (Style.red (Style.pad 8 "failed")) n.label
-      (Style.dim ("      " ^ Exec.show n.cmd));
+      (Style.dim ("      " ^ Exec.brief n.cmd));
   if String.trim log <> "" then (print_string log; flush stdout);
   flush stdout
 
@@ -318,7 +318,8 @@ let cmd_test filter =
   let _, r = execute p ~names:(List.map (fun (t : target) -> t.name) chosen) in
   if r.failed > 0 then summarise r (Unix.gettimeofday () -. t0);
   if r.built > 0 then print_newline ();
-  let results = List.map (Testrun.run_one p) chosen in
+  let jobs = if fl.jobs > 0 then fl.jobs else cores () in
+  let results = Testrun.run_all ~jobs p chosen in
   List.iter
     (fun (o : Testrun.outcome) ->
       Printf.printf "  %s%s%s\n"
@@ -377,33 +378,43 @@ let cmd_targets () =
           (Style.plural (List.length p.targets) "target"
           :: (if p.scripts = [] then [] else [ Style.plural (List.length p.scripts) "run block" ]))))
 
-let cmd_graph () =
+let cmd_graph names =
   let p = configure () in
   if fl.targets_only then print_string (Dot.targets_only p)
   else
     let b = Build.of_project p in
-    if fl.dot then print_string (Dot.render b)
+    let selected =
+      match names with [] -> None | _ -> Some (Build.select b (select_targets p names))
+    in
+    let keep i = match selected with None -> true | Some s -> Hashtbl.mem s i in
+    if fl.dot then print_string (Dot.render ?selected b)
     else begin
       banner p;
       let order = Graph.topo b.g in
+      let shown = ref 0 in
       List.iter
         (fun i ->
+          if keep i then begin
+          incr shown;
           let v = b.g.Graph.nodes.(i) in
           Printf.printf "  %s%s\n" (Build.paint v.tag (Style.pad 8 v.tag)) (Style.pad 34 v.label);
           List.iter
             (fun d -> Printf.printf "      %s %s\n" (Style.dim "<-") (Style.dim b.g.Graph.nodes.(d).label))
-            v.deps)
+            v.deps
+          end)
         order;
       Printf.printf "\n  %s\n"
-        (Style.dim (Style.plural (Array.length b.g.Graph.nodes) "action"))
+        (Style.dim (Style.plural !shown "action"))
     end
 
 let cmd_explain = function
   | [] -> Diag.error "explain needs a file path"
-  | path :: _ ->
+  | name :: _ ->
       let p = configure () in
       let b = Build.of_project p in
       banner p;
+      (* a target name stands for whatever it produces *)
+      let path = match find p name with Some t -> Build.out_of p t | None -> name in
       (match Graph.producing b.g path with
       | None ->
           Printf.printf "  %s is not produced by this build\n" (Style.bold path);
@@ -512,7 +523,7 @@ let () =
          Printf.printf "  %s\n" (Style.dim "configured")
      | "check" :: _ -> cmd_check ()
      | "targets" :: _ -> cmd_targets ()
-     | "graph" :: _ -> cmd_graph ()
+     | "graph" :: names -> cmd_graph names
      | "explain" :: rest -> cmd_explain rest
      | "compdb" :: _ -> cmd_compdb ()
      | "watch" :: names -> cmd_watch names

lib/dot.ml

@@ -2,13 +2,17 @@ open Types
 
 let color = function
   | "cc" | "c++" -> "#4c78a8"
+  | "as" -> "#b279a2"
   | "ar" -> "#b279a2"
   | "so" -> "#72b7b2"
   | "ld" -> "#54a24b"
   | "gen" -> "#eeca3b"
   | _ -> "#888888"
 
-let render ?(nodes = true) (b : Build.t) =
+let render ?(nodes = true) ?selected (b : Build.t) =
+  let keep (n : Graph.node) =
+    match selected with None -> true | Some s -> Hashtbl.mem s n.id
+  in
   let buf = Buffer.create 4096 in
   Buffer.add_string buf "digraph meowc {\n";
   Buffer.add_string buf "  rankdir=LR;\n  bgcolor=\"transparent\";\n";
@@ -18,6 +22,7 @@ let render ?(nodes = true) (b : Build.t) =
   if nodes then
     Array.iter
       (fun (n : Graph.node) ->
+        if keep n then
         Buffer.add_string buf
           (Printf.sprintf "  n%d [label=%s, fillcolor=%s];\n" n.id
              (Json.str (n.tag ^ "  " ^ Filename.basename n.label))
@@ -25,7 +30,12 @@ let render ?(nodes = true) (b : Build.t) =
       b.g.Graph.nodes;
   Array.iter
     (fun (n : Graph.node) ->
-      List.iter (fun d -> Buffer.add_string buf (Printf.sprintf "  n%d -> n%d;\n" d n.id)) n.deps)
+      if keep n then
+        List.iter
+          (fun d ->
+            if keep b.g.Graph.nodes.(d) then
+              Buffer.add_string buf (Printf.sprintf "  n%d -> n%d;\n" d n.id))
+          n.deps)
     b.g.Graph.nodes;
   Buffer.add_string buf "}\n";
   Buffer.contents buf

lib/exec.ml

@@ -5,6 +5,13 @@ let quote s =
 
 let show cmd = String.concat " " (List.map quote (Array.to_list cmd))
 
+(* A failing link can carry ten thousand object paths, and printing them all
+   buries the message the compiler actually wrote. *)
+let brief ?(keep = 20) cmd =
+  let n = Array.length cmd in
+  if n <= keep then show cmd
+  else show (Array.sub cmd 0 keep) ^ Printf.sprintf " … and %d more arguments" (n - keep)
+
 let devnull () = Unix.openfile "/dev/null" [ Unix.O_RDONLY ] 0
 
 let capture cmd =

lib/testrun.ml

@@ -2,11 +2,52 @@ open Types
 
 type outcome = { name : string; ok : bool; ms : float; output : string; code : int }
 
-let run_one p (t : target) =
-  let exe = Build.test_of p t in
-  let t0 = Unix.gettimeofday () in
-  let code, out = Exec.capture (Array.of_list (exe :: t.args)) in
-  let ms = (Unix.gettimeofday () -. t0) *. 1000.0 in
-  { name = t.name; ok = code = 0; ms; output = out; code }
-
 let tests p = List.filter (fun (t : target) -> t.kind = Test) p.targets
+
+let failed name code = { name; ok = false; ms = 0.0; output = ""; code }
+
+(* Tests are independent processes, so they run the same way the build does:
+   up to jobs at once, each with its own output, reported in declaration order. *)
+let run_all ~jobs p ts =
+  let results = Hashtbl.create 8 in
+  let running = Hashtbl.create 8 in
+  let queue = ref ts in
+  let spawn (t : target) =
+    let exe = Build.test_of p t in
+    let tmp = Filename.temp_file "meowc-test" ".log" in
+    let fd = Unix.openfile tmp [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
+    let nul = Exec.devnull () in
+    let argv = Array.of_list (exe :: t.args) in
+    (match Unix.create_process exe argv nul fd fd with
+    | pid -> Hashtbl.replace running pid (t, tmp, Unix.gettimeofday ())
+    | exception Unix.Unix_error _ ->
+        (try Sys.remove tmp with Sys_error _ -> ());
+        Hashtbl.replace results t.name (failed t.name 127));
+    Unix.close fd;
+    Unix.close nul
+  in
+  let reap () =
+    match Unix.wait () with
+    | exception Unix.Unix_error (Unix.EINTR, _, _) -> ()
+    | exception Unix.Unix_error (Unix.ECHILD, _, _) -> Hashtbl.reset running
+    | pid, status -> (
+        match Hashtbl.find_opt running pid with
+        | None -> ()
+        | Some (t, tmp, t0) ->
+            Hashtbl.remove running pid;
+            let ms = (Unix.gettimeofday () -. t0) *. 1000.0 in
+            let output = try Fs.read tmp with Sys_error _ -> "" in
+            (try Sys.remove tmp with Sys_error _ -> ());
+            let code = match status with Unix.WEXITED c -> c | _ -> 128 in
+            Hashtbl.replace results t.name { name = t.name; ok = code = 0; ms; output; code })
+  in
+  while !queue <> [] || Hashtbl.length running > 0 do
+    while !queue <> [] && Hashtbl.length running < jobs do
+      match !queue with t :: rest -> queue := rest; spawn t | [] -> ()
+    done;
+    if Hashtbl.length running > 0 then reap ()
+  done;
+  List.map
+    (fun (t : target) ->
+      match Hashtbl.find_opt results t.name with Some o -> o | None -> failed t.name 127)
+    ts