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

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