diff --git a/bin/meowc.ml b/bin/meowc.ml index 4c38a59..4011892 100644 --- a/bin/meowc.ml +++ b/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 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 diff --git a/lib/dot.ml b/lib/dot.ml index 19c6598..08748d5 100644 --- a/lib/dot.ml +++ b/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 diff --git a/lib/exec.ml b/lib/exec.ml index 4f1e041..63a2a20 100644 --- a/lib/exec.ml +++ b/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 = diff --git a/lib/testrun.ml b/lib/testrun.ml index 10521f9..52558e0 100644 --- a/lib/testrun.ml +++ b/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