diff --git a/bin/common.ml b/bin/common.ml index ecf541348bd..2536c178507 100644 --- a/bin/common.ml +++ b/bin/common.ml @@ -1423,14 +1423,9 @@ let init_with_root ~(root : Workspace_root.t) (builder : Builder.t) = Dune_console.separate_messages c.builder.separate_error_messages; Option.iter c.stats ~f:(fun stats -> if Dune_trace.extended_build_job_info stats - then - (* Communicate config settings as an instant event here. *) - let open Chrome_trace in - let args = [ "build_dir", `String (Path.Build.to_string Path.Build.root) ] in - let ts = Event.Timestamp.of_float_seconds (Unix.gettimeofday ()) in - let common = Event.common_fields ~cat:[ "config" ] ~name:"config" ~ts () in - let event = Event.instant ~args common in - Dune_trace.emit stats event); + then ( + let event = Dune_trace.Event.config () in + Dune_trace.emit stats event)); (* Setup hook for printing GC stats to a file *) at_exit (fun () -> match c.builder.dump_gc_stats with diff --git a/doc/changes/changed/12867.md b/doc/changes/changed/12867.md new file mode 100644 index 00000000000..7e109e474c5 --- /dev/null +++ b/doc/changes/changed/12867.md @@ -0,0 +1,3 @@ +- Persistent DB and process events have been slightly modified. Persistent + DB events have more concise names and job events always include full + information. (#12867, @rgrinberg) diff --git a/flake.nix b/flake.nix index 8b46a39856c..a10e8fe9a24 100644 --- a/flake.nix +++ b/flake.nix @@ -100,6 +100,7 @@ file mercurial unzip + perl ] ++ lib.optionals stdenv.isLinux [ strace ]; testNativeBuildInputs = diff --git a/otherlibs/chrome-trace/test/chrome_trace_tests.ml b/otherlibs/chrome-trace/test/chrome_trace_tests.ml index 44c434187a3..04a93ba9d1b 100644 --- a/otherlibs/chrome-trace/test/chrome_trace_tests.ml +++ b/otherlibs/chrome-trace/test/chrome_trace_tests.ml @@ -1,17 +1,6 @@ open Stdune -open Dune_tests_common -let () = init () -let buf = Buffer.create 0 - -let c = - let write s = Buffer.add_string buf s in - let close () = () in - let flush () = () in - Dune_trace.create (Custom { write; close; flush }) ~extended_build_job_info:false -;; - -let () = +let%expect_test _ = let module Event = Chrome_trace.Event in let module Id = Chrome_trace.Id in let module Timestamp = Event.Timestamp in @@ -30,22 +19,12 @@ let () = ~args:[ "foo", `Int 100 ] ] in - List.iter events ~f:(Dune_trace.emit c); - Dune_trace.close c -;; - -let buffer_lines () = String.split_lines (Buffer.contents buf) - -let%expect_test _ = - Format.printf - "%a@." - Pp.to_fmt - (Pp.vbox (Pp.concat_map (buffer_lines ()) ~sep:Pp.cut ~f:Pp.verbatim)); + List.iter events ~f:(fun event -> + Chrome_trace.Event.to_json event |> Dune_trace.Json.to_string |> print_endline); [%expect {| -[{"args":{"foo":"bar"},"ph":"X","dur":1000000,"name":"foo","cat":"","ts":500000,"pid":0,"tid":0} -,{"ph":"C","args":{"bar":250},"name":"cnt","cat":"","ts":500000,"pid":0,"tid":0} -,{"args":{"foo":100},"ph":"b","id":"foo","name":"async","cat":"","ts":500000,"pid":0,"tid":0} -] -|}] + {"args":{"foo":"bar"},"ph":"X","dur":1000000,"name":"foo","cat":"","ts":500000,"pid":0,"tid":0} + {"ph":"C","args":{"bar":250},"name":"cnt","cat":"","ts":500000,"pid":0,"tid":0} + {"args":{"foo":100},"ph":"b","id":"foo","name":"async","cat":"","ts":500000,"pid":0,"tid":0} + |}] ;; diff --git a/src/dune_engine/build_system.ml b/src/dune_engine/build_system.ml index fb585798d4a..2cec68efcbc 100644 --- a/src/dune_engine/build_system.ml +++ b/src/dune_engine/build_system.ml @@ -307,17 +307,13 @@ end = struct let report_evaluated_rule_exn (t : Build_config.t) = Option.iter t.stats ~f:(fun stats -> - let module Event = Chrome_trace.Event in let event = let rule_total = match Fiber.Svar.read State.t with | Building progress -> progress.number_of_rules_discovered | _ -> assert false in - let args = [ "value", `Int rule_total ] in - let ts = Event.Timestamp.of_float_seconds (Unix.gettimeofday ()) in - let common = Event.common_fields ~name:"evaluated_rules" ~ts () in - Event.counter common args + Dune_trace.Event.evalauted_rules ~rule_total in Dune_trace.emit stats event) ;; diff --git a/src/dune_engine/process.ml b/src/dune_engine/process.ml index 7c2982d84ab..16b3a011761 100644 --- a/src/dune_engine/process.ml +++ b/src/dune_engine/process.ml @@ -280,14 +280,6 @@ let command_line ~prog ~args ~dir ~stdout_to ~stderr_to ~stdin_from = prefix ^ String.quote_list_for_shell (prog :: args) ^ suffix ;; -module Exit_status = struct - type error = - | Failed of int - | Signaled of Signal.t - - type t = (int, error) result -end - module Fancy = struct let split_prog s = let len = String.length s in @@ -372,6 +364,8 @@ module Fancy = struct ;; end +module Exit_status = Dune_trace.Event.Exit_status + (* Implemt the rendering for [--display short] *) module Short_display : sig val pp_ok : prog:string -> purpose:purpose -> User_message.Style.t Pp.t @@ -822,58 +816,29 @@ let report_process_finished ~stderr (times : Proc.Times.t) = - let common = - let name = - match metadata.name with - | Some n -> n - | None -> Filename.basename prog - in - let ts = Timestamp.of_float_seconds started_at in - Event.common_fields ~cat:("process" :: metadata.categories) ~name ~ts () + let targets = + match metadata.purpose with + | Internal_job -> [] + | Build_job None -> [] + | Build_job (Some targets) -> Targets.Validated.to_trace_args targets in - let always = - [ "process_args", `List (List.map args ~f:(fun arg -> `String arg)) - ; "pid", `Int (Pid.to_int pid) - ] - in - let extended = - if not (Dune_trace.extended_build_job_info stats) - then [] - else ( - let targets = - match metadata.purpose with - | Internal_job -> [] - | Build_job None -> [] - | Build_job (Some targets) -> Targets.Validated.to_trace_args targets - in - let exit = - match exit_status with - | Ok n -> [ "exit", `Int n ] - | Error (Exit_status.Failed n) -> - [ "exit", `Int n; "error", `String (sprintf "exited with code %d" n) ] - | Error (Signaled s) -> - [ "exit", `Int (Signal.to_int s) - ; "error", `String (sprintf "got signal %s" (Signal.name s)) - ] - in - let output name s = - match Result.Out.get s with - | "" -> [] - | s -> [ name, `String s ] - in - List.concat - [ [ "prog", `String prog - ; "dir", `String (Option.map ~f:Path.to_string dir |> Option.value ~default:".") - ] - ; targets - ; exit - ; output "stdout" stdout - ; output "stderr" stderr - ]) + let stdout = Result.Out.get stdout in + let stderr = Result.Out.get stderr in + let event = + Dune_trace.Event.process + ~name:metadata.name + ~started_at + ~targets + ~categories:metadata.categories + ~pid + ~exit:exit_status + ~prog + ~process_args:args + ~dir + ~stdout + ~stderr + ~times:(times : Proc.Times.t) in - let args = always @ extended in - let dur = Event.Timestamp.of_float_seconds times.elapsed_time in - let event = Event.complete ~args ~dur common in Dune_trace.emit stats event ;; diff --git a/src/dune_engine/sandbox.ml b/src/dune_engine/sandbox.ml index ce8bdec9f47..ab04753da38 100644 --- a/src/dune_engine/sandbox.ml +++ b/src/dune_engine/sandbox.ml @@ -185,7 +185,7 @@ let create ~mode ~dune_stats ~rule_loc ~dirs ~deps ~rule_dir ~rule_digest = Dune_trace.start dune_stats (fun () -> let cat = Some [ "create-sandbox" ] in let name = Loc.to_file_colon_line rule_loc in - Dune_trace.Event.data ~cat ~name ~args:None) + Dune_trace.Event.Async.data ~cat ~name ~args:None) in init (); let sandbox_dir = diff --git a/src/dune_engine/scheduler.ml b/src/dune_engine/scheduler.ml index 0021d5b9614..3f2c06d48a8 100644 --- a/src/dune_engine/scheduler.ml +++ b/src/dune_engine/scheduler.ml @@ -1182,15 +1182,7 @@ module Run = struct But we don't care because the user enabled this manually with [--trace-file] *) Option.iter stats ~f:(fun stats -> - let event = - let fields = - let ts = Chrome_trace.Event.Timestamp.of_float_seconds (Unix.gettimeofday ()) in - Chrome_trace.Event.common_fields ~name:"watch mode iteration" ~ts () - in - (* the instant event allows us to separate build commands from - different iterations of the watch mode in the event viewer *) - Chrome_trace.Event.instant ~scope:Global fields - in + let event = Dune_trace.Event.scheduler_idle () in Dune_trace.emit stats event; Dune_trace.flush stats) ;; diff --git a/src/dune_pkg/fetch.ml b/src/dune_pkg/fetch.ml index 3eb9168f22a..b40edd110e0 100644 --- a/src/dune_pkg/fetch.ml +++ b/src/dune_pkg/fetch.ml @@ -253,7 +253,7 @@ let fetch ~unpack ~checksum ~target ~url:(url_loc, url) = let event = Dune_trace.( start (global ()) (fun () -> - Dune_trace.Event.data + Dune_trace.Event.Async.data ~cat:None ~name:label ~args: diff --git a/src/dune_rpc_server/dune_rpc_server.ml b/src/dune_rpc_server/dune_rpc_server.ml index 7fac970d613..cbb45f56e95 100644 --- a/src/dune_rpc_server/dune_rpc_server.ml +++ b/src/dune_rpc_server/dune_rpc_server.ml @@ -270,52 +270,30 @@ type message_kind = | Request of Dune_rpc_private.Id.t | Notification -type stage = - | Start - | Stop - module Event = struct module Event = Chrome_trace.Event - let async_kind_of_stage = function - | Start -> Event.Start - | Stop -> Event.End - ;; - type t = - | Session of stage + | Session of Dune_trace.Event.Rpc.stage | Message of { kind : message_kind ; meth_ : string - ; stage : stage + ; stage : Dune_trace.Event.Rpc.stage } let emit t stats id = Option.iter stats ~f:(fun stats -> let event = - let kind, name, args = - match t with - | Session stage -> async_kind_of_stage stage, "rpc_session", None - | Message { kind; meth_; stage } -> - let args = - match kind with - | Notification -> None - | Request id -> - let id = Dune_rpc_private.Id.to_sexp id in - let rec to_json : Sexp.t -> Chrome_trace.Json.t = function - | Atom s -> `String s - | List s -> `List (List.map s ~f:to_json) - in - Some [ "request_id", to_json id ] - in - async_kind_of_stage stage, meth_, args - in - let common = - let ts = Event.Timestamp.of_float_seconds (Unix.gettimeofday ()) in - Event.common_fields ~ts ~name () - in - let id = Chrome_trace.Id.create (`Int (Session.Id.to_int id)) in - Event.async ?args id kind common + let id = Session_id.to_int id in + match t with + | Session stage -> Dune_trace.Event.Rpc.session ~id stage + | Message { kind; meth_; stage } -> + let kind = + match kind with + | Request id -> `Request (Dune_rpc_private.Id.to_sexp id) + | Notification -> `Notification + in + Dune_trace.Event.Rpc.message kind ~meth_ ~id stage in Dune_trace.emit stats event) ;; @@ -351,7 +329,10 @@ module H = struct let dispatch_notification (type a) (t : a t) stats (session : a Session.t) meth_ n = let kind = Notification in - Event.emit (Message { kind; meth_; stage = Start }) stats (Session.id session); + Event.emit + (Message { kind; meth_; stage = Dune_trace.Event.Rpc.Start }) + stats + (Session.id session); let+ result = V.Handler.handle_notification t.handler session n in let () = match result with diff --git a/src/dune_trace/dune_trace.ml b/src/dune_trace/dune_trace.ml index 56532d006a7..cac453cd33e 100644 --- a/src/dune_trace/dune_trace.ml +++ b/src/dune_trace/dune_trace.ml @@ -81,25 +81,205 @@ let printf t format_string = Printf.ksprintf t.print ("%c" ^^ format_string ^^ "\n") c ;; -let emit t event = printf t "%s" (Json.to_string (Chrome_trace.Event.to_json event)) - module Event = struct - type data = - { args : Chrome_trace.Event.args option - ; cat : string list option - ; name : string - } - - type nonrec t = - { t : t - ; event_data : data - ; start : float - } - - let data ~args ~cat ~name = { args; cat; name } + module Async = struct + type data = + { args : Chrome_trace.Event.args option + ; cat : string list option + ; name : string + } + + type nonrec t = + { t : t + ; event_data : data + ; start : float + } + + let data ~args ~cat ~name = { args; cat; name } + end + + type t = Chrome_trace.Event.t + + let scan_source ~name ~start ~stop ~dir = + let module Event = Chrome_trace.Event in + let module Timestamp = Event.Timestamp in + let dur = Timestamp.of_float_seconds (stop -. start) in + let common = + Event.common_fields + ~name:(name ^ ": " ^ Path.Source.to_string dir) + ~ts:(Timestamp.of_float_seconds start) + () + in + let args = [ "dir", `String (Path.Source.to_string dir) ] in + Event.complete common ~args ~dur + ;; + + let evalauted_rules ~rule_total = + let open Chrome_trace in + let args = [ "value", `Int rule_total ] in + let ts = Event.Timestamp.of_float_seconds (Unix.gettimeofday ()) in + let common = Event.common_fields ~name:"evaluated_rules" ~ts () in + Event.counter common args + ;; + + let config () = + let open Chrome_trace in + let args = [ "build_dir", `String (Path.Build.to_string Path.Build.root) ] in + let ts = Event.Timestamp.of_float_seconds (Unix.gettimeofday ()) in + let common = Event.common_fields ~cat:[ "config" ] ~name:"config" ~ts () in + Event.instant ~args common + ;; + + let scheduler_idle () = + let fields = + let ts = Chrome_trace.Event.Timestamp.of_float_seconds (Unix.gettimeofday ()) in + Chrome_trace.Event.common_fields ~name:"watch mode iteration" ~ts () + in + (* the instant event allows us to separate build commands from + different iterations of the watch mode in the event viewer *) + Chrome_trace.Event.instant ~scope:Global fields + ;; + + module Exit_status = struct + type error = + | Failed of int + | Signaled of Signal.t + + type t = (int, error) result + end + + let process + ~name + ~started_at + ~targets + ~categories + ~pid + ~exit + ~prog + ~process_args + ~dir + ~stdout + ~stderr + ~(times : Proc.Times.t) + = + let open Chrome_trace in + let common = + let name = + match name with + | Some n -> n + | None -> Filename.basename prog + in + let ts = Timestamp.of_float_seconds started_at in + Event.common_fields ~cat:("process" :: categories) ~name ~ts () + in + let always = + [ "process_args", `List (List.map process_args ~f:(fun arg -> `String arg)) + ; "pid", `Int (Pid.to_int pid) + ] + in + let extended = + let exit = + match exit with + | Ok n -> [ "exit", `Int n ] + | Error (Exit_status.Failed n) -> + [ "exit", `Int n; "error", `String (sprintf "exited with code %d" n) ] + | Error (Signaled s) -> + [ "exit", `Int (Signal.to_int s) + ; "error", `String (sprintf "got signal %s" (Signal.name s)) + ] + in + let output name s = + match s with + | "" -> [] + | s -> [ name, `String s ] + in + List.concat + [ [ "prog", `String prog + ; "dir", `String (Option.map ~f:Path.to_string dir |> Option.value ~default:".") + ] + ; targets + ; exit + ; output "stdout" stdout + ; output "stderr" stderr + ] + in + let args = always @ extended in + let dur = Event.Timestamp.of_float_seconds times.elapsed_time in + Event.complete ~args ~dur common + ;; + + let persistent ~file ~module_ what ~start ~stop = + let module Event = Chrome_trace.Event in + let module Timestamp = Event.Timestamp in + let dur = Timestamp.of_float_seconds (stop -. start) in + let common = + Event.common_fields ~name:"db" ~ts:(Timestamp.of_float_seconds start) () + in + let args = + [ "path", `String (Path.to_string file) + ; "module", `String module_ + ; ( "operation" + , `String + (match what with + | `Save -> "save" + | `Load -> "load") ) + ] + in + Event.complete common ~args ~dur + ;; + + module Rpc = struct + type stage = + | Start + | Stop + + let async_kind_of_stage = function + | Start -> Chrome_trace.Event.Start + | Stop -> End + ;; + + let session ~id stage = + let open Chrome_trace in + let common = + let ts = Event.Timestamp.of_float_seconds (Unix.gettimeofday ()) in + Event.common_fields ~ts ~name:"rpc_session" () + in + let id = Chrome_trace.Id.create (`Int id) in + Event.async id (async_kind_of_stage stage) common + ;; + + let rec to_json : Sexp.t -> Chrome_trace.Json.t = function + | Atom s -> `String s + | List s -> `List (List.map s ~f:to_json) + ;; + + let message what ~meth_ ~id stage = + let open Chrome_trace in + let name = + match what with + | `Notification -> "notification" + | `Request _ -> "request" + in + let args = [ "meth", `String meth_ ] in + let args = + match what with + | `Notification -> args + | `Request id -> ("request_id", to_json id) :: args + in + let ts = Event.Timestamp.of_float_seconds (Unix.gettimeofday ()) in + let common = Event.common_fields ~cat:[ "rpc" ] ~ts ~name () in + Event.async + (Chrome_trace.Id.create (`Int id)) + ~args + (async_kind_of_stage stage) + common + ;; + end end -let start t k : Event.t option = +let emit t event = printf t "%s" (Json.to_string (Chrome_trace.Event.to_json event)) + +let start t k : Event.Async.t option = match t with | None -> None | Some t -> @@ -111,7 +291,7 @@ let start t k : Event.t option = let finish event = match event with | None -> () - | Some { Event.t; start; event_data = { args; cat; name } } -> + | Some { Event.Async.t; start; event_data = { args; cat; name } } -> let dur = let stop = Unix.gettimeofday () in Timestamp.of_float_seconds (stop -. start) diff --git a/src/dune_trace/dune_trace.mli b/src/dune_trace/dune_trace.mli index 5bd7ff436aa..a08923f688b 100644 --- a/src/dune_trace/dune_trace.mli +++ b/src/dune_trace/dune_trace.mli @@ -1,3 +1,5 @@ +open Stdune + type t module Json : sig @@ -17,24 +19,80 @@ type dst = val global : unit -> t option val set_global : t -> unit val create : extended_build_job_info:bool -> dst -> t -val emit : t -> Chrome_trace.Event.t -> unit val record_gc_and_fd : t -> unit val close : t -> unit val extended_build_job_info : t -> bool module Event : sig + module Async : sig + type t + type data + + val data + : args:(string * Json.t) list option + -> cat:string list option + -> name:string + -> data + end + type t - type data - val data - : args:(string * Json.t) list option - -> cat:string list option - -> name:string - -> data + val evalauted_rules : rule_total:int -> t + + module Exit_status : sig + type error = + | Failed of int + | Signaled of Signal.t + + type t = (int, error) result + end + + val process + : name:string option + -> started_at:float + -> targets:(string * Json.t) list + -> categories:string list + -> pid:Pid.t + -> exit:Exit_status.t + -> prog:string + -> process_args:string list + -> dir:Path.t option + -> stdout:string + -> stderr:string + -> times:Proc.Times.t + -> t + + val persistent + : file:Path.t + -> module_:string + -> [ `Save | `Load ] + -> start:float + -> stop:float + -> t + + val scan_source : name:string -> start:float -> stop:float -> dir:Path.Source.t -> t + val scheduler_idle : unit -> t + val config : unit -> t + + module Rpc : sig + type stage = + | Start + | Stop + + val session : id:int -> stage -> t + + val message + : [ `Request of Sexp.t | `Notification ] + -> meth_:string + -> id:int + -> stage + -> t + end end -val start : t option -> (unit -> Event.data) -> Event.t option -val finish : Event.t option -> unit +val emit : t -> Event.t -> unit +val start : t option -> (unit -> Event.Async.data) -> Event.Async.t option +val finish : Event.Async.t option -> unit val flush : t -> unit module Private : sig diff --git a/src/dune_util/persistent.ml b/src/dune_util/persistent.ml index 9a1db89d026..1ada79bb81e 100644 --- a/src/dune_util/persistent.ml +++ b/src/dune_util/persistent.ml @@ -53,17 +53,16 @@ module Make (D : Desc) = struct let to_string (v : D.t) = Printf.sprintf "%s%s" magic (Marshal.to_string v []) - let with_record stats ~name ~file ~f = + let with_record stats what ~file ~f = let start = Unix.gettimeofday () in let res = Result.try_with f in let event = - let stop = Unix.gettimeofday () in - let module Event = Chrome_trace.Event in - let module Timestamp = Event.Timestamp in - let dur = Timestamp.of_float_seconds (stop -. start) in - let common = Event.common_fields ~name ~ts:(Timestamp.of_float_seconds start) () in - let args = [ "path", `String (Path.to_string file); "module", `String D.name ] in - Event.complete common ~args ~dur + Dune_trace.Event.persistent + ~file + ~module_:D.name + what + ~start + ~stop:(Unix.gettimeofday ()) in Dune_trace.emit stats event; Result.ok_exn res @@ -83,9 +82,7 @@ module Make (D : Desc) = struct (match Dune_trace.global () with | None -> dump | Some stats -> - fun file v -> - with_record stats ~name:"Writing Persistent Dune State" ~file ~f:(fun () -> - dump file v)) + fun file v -> with_record stats `Save ~file ~f:(fun () -> dump file v)) in fun file (v : D.t) -> (Lazy.force dump) file v ;; @@ -118,9 +115,7 @@ module Make (D : Desc) = struct (match Dune_trace.global () with | None -> read_file | Some stats -> - fun file -> - with_record stats ~name:"Loading Persistent Dune State" ~file ~f:(fun () -> - read_file file)) + fun file -> with_record stats `Load ~file ~f:(fun () -> read_file file)) in fun file -> if Path.exists file then (Lazy.force read_file) file else None ;; diff --git a/src/source/source_tree.ml b/src/source/source_tree.ml index adde5f4530c..388ed713ceb 100644 --- a/src/source/source_tree.ml +++ b/src/source/source_tree.ml @@ -364,19 +364,13 @@ module Dir = struct fun t ~traverse ~trace_event_name ~f -> let start = Unix.gettimeofday () in let+ res = map_reduce t ~traverse ~trace_event_name ~f in + let stop = Unix.gettimeofday () in let event = - let stop = Unix.gettimeofday () in - let module Event = Chrome_trace.Event in - let module Timestamp = Event.Timestamp in - let dur = Timestamp.of_float_seconds (stop -. start) in - let common = - Event.common_fields - ~name:(trace_event_name ^ ": " ^ Path.Source.to_string t.path) - ~ts:(Timestamp.of_float_seconds start) - () - in - let args = [ "dir", `String (Path.Source.to_string t.path) ] in - Event.complete common ~args ~dur + Dune_trace.Event.scan_source + ~name:trace_event_name + ~start + ~stop + ~dir:t.path in Dune_trace.emit stats event; res) diff --git a/test/blackbox-tests/test-cases/dune b/test/blackbox-tests/test-cases/dune index d8dbfeceda3..522adfbe694 100644 --- a/test/blackbox-tests/test-cases/dune +++ b/test/blackbox-tests/test-cases/dune @@ -126,3 +126,7 @@ (applies_to hidden-deps-unsupported) (enabled_if (< %{ocaml_version} 5.2.0))) + +(cram + (applies_to trace-file) + (deps %{bin:perl})) diff --git a/test/blackbox-tests/test-cases/trace-file.t/run.t b/test/blackbox-tests/test-cases/trace-file.t/run.t index 42783a3284e..64589d91ef7 100644 --- a/test/blackbox-tests/test-cases/trace-file.t/run.t +++ b/test/blackbox-tests/test-cases/trace-file.t/run.t @@ -2,15 +2,15 @@ This captures the commands that are being run: - $