unikernel/duniverse/dune_/otherlibs/chrome-trace/src/chrome_trace.ml

@@ -0,0 +1,351 @@
+module List = ListLabels
+module String = StringLabels
+
+module Json = struct
+  type t =
+    [ `Int of int
+    | `Float of float
+    | `String of string
+    | `List of t list
+    | `Bool of bool
+    | `Assoc of (string * t) list
+    | `Null
+    ]
+end
+
+module Timestamp : sig
+  type t
+
+  val to_json : t -> Json.t
+  val of_float_seconds : float -> t
+  val to_float_seconds : t -> float
+end = struct
+  type t = float
+
+  let of_float_seconds x = x
+  let to_float_seconds x = x
+
+  let to_json f =
+    let n = int_of_float @@ (f *. 1_000_000.) in
+    `Int n
+  ;;
+end
+
+module Id = struct
+  type t =
+    [ `Int of int
+    | `String of string
+    ]
+
+  let create x = x
+
+  let to_string = function
+    | `String s -> s
+    | `Int i -> string_of_int i
+  ;;
+
+  let to_json (t : t) = (t :> Json.t)
+  let field id = "id", to_json id
+end
+
+module Stack_frame = struct
+  module Raw = struct
+    type t = string list
+
+    let create t = t
+    let to_json t = `List (List.map t ~f:(fun s -> `String s))
+  end
+
+  type t =
+    { parent : Id.t option
+    ; name : string
+    ; category : string
+    }
+
+  let create ?parent ~name ~category () = { parent; name; category }
+
+  let to_json { parent; name; category } : Json.t =
+    let json = [ "name", `String name; "category", `String category ] in
+    let json =
+      match parent with
+      | None -> json
+      | Some id -> ("parent", Id.to_json id) :: json
+    in
+    `Assoc json
+  ;;
+end
+
+module Event = struct
+  [@@@ocaml.warning "-37"]
+
+  module Timestamp = Timestamp
+
+  type common_fields =
+    { name : string
+    ; cat : string list
+    ; ts : Timestamp.t
+    ; tts : Timestamp.t option
+    ; pid : int
+    ; tid : int
+    ; cname : string option
+    ; stackframe : [ `Id of Id.t | `Raw of Stack_frame.Raw.t ] option
+    }
+
+  let common_fields ?tts ?cname ?(cat = []) ?(pid = 0) ?(tid = 0) ?stackframe ~ts ~name ()
+    =
+    { tts; cname; cat; ts; pid; tid; name; stackframe }
+  ;;
+
+  let set_ts t ts = { t with ts }
+  let ts t = t.ts
+
+  type scope =
+    | Global
+    | Process
+    | Thread
+
+  type async =
+    | Start
+    | Instant
+    | End
+
+  type args = (string * Json.t) list
+
+  type object_kind =
+    | New
+    | Snapshot of
+        { cat : string list option
+        ; args : args
+        }
+    | Destroy
+
+  type metadata =
+    | Process_name of
+        { pid : int
+        ; name : string
+        }
+    | Process_labels of
+        { pid : int
+        ; labels : string
+        }
+    | Thread_name of
+        { tid : int
+        ; pid : int
+        ; name : string
+        }
+    | Process_sort_index of
+        { pid : int
+        ; sort_index : int
+        }
+    | Thread_sort_index of
+        { pid : int
+        ; tid : int
+        ; sort_index : int
+        }
+
+  (* TODO support flow, samples, references, memory dumps *)
+  type t =
+    | Counter of common_fields * args * Id.t option
+    | Duration_start of common_fields * args * Id.t option
+    | Duration_end of
+        { pid : int
+        ; tid : int
+        ; ts : float
+        ; args : args option
+        }
+    | Complete of
+        { common : common_fields
+        ; args : args option
+        ; dur : Timestamp.t
+        ; tdur : Timestamp.t option
+        }
+    | Instant of common_fields * scope option * args option
+    | Async of
+        { common : common_fields
+        ; async : async
+        ; scope : string option
+        ; id : Id.t
+        ; args : args option
+        }
+    | Object of
+        { common : common_fields
+        ; object_kind : object_kind
+        ; id : Id.t
+        ; scope : string option
+        }
+    | Metadata of metadata
+
+  let phase s = "ph", `String s
+
+  let add_field_opt to_field field fields =
+    match field with
+    | None -> fields
+    | Some f -> to_field f :: fields
+  ;;
+
+  let json_fields_of_common_fields { name; cat; ts; tts; pid; tid; cname; stackframe } =
+    let fields =
+      [ "name", `String name
+      ; "cat", `String (String.concat ~sep:"," cat)
+      ; "ts", Timestamp.to_json ts
+      ; "pid", `Int pid
+      ; "tid", `Int tid
+      ]
+    in
+    let fields = add_field_opt (fun cname -> "cname", `String cname) cname fields in
+    let fields = add_field_opt (fun tts -> "tts", Timestamp.to_json tts) tts fields in
+    add_field_opt
+      (fun stackframe ->
+         match stackframe with
+         | `Id id -> "sf", Id.to_json id
+         | `Raw r -> "stack", Stack_frame.Raw.to_json r)
+      stackframe
+      fields
+  ;;
+
+  let json_of_scope = function
+    | Global -> `String "g"
+    | Process -> `String "p"
+    | Thread -> `String "t"
+  ;;
+
+  let args_field fields = "args", `Assoc fields
+
+  let json_fields_of_metadata m =
+    let fields =
+      let common pid name = [ "name", `String name; "pid", `Int pid ] in
+      match m with
+      | Process_name { pid; name } ->
+        args_field [ "name", `String name ] :: common pid "thread_name"
+      | Process_labels { pid; labels } ->
+        args_field [ "labels", `String labels ] :: common pid "process_labels"
+      | Thread_name { tid; pid; name } ->
+        ("tid", `Int tid)
+        :: args_field [ "name", `String name ]
+        :: common pid "process_name"
+      | Process_sort_index { pid; sort_index } ->
+        args_field [ "sort_index", `Int sort_index ] :: common pid "process_sort_index"
+      | Thread_sort_index { pid; sort_index; tid } ->
+        ("tid", `Int tid)
+        :: args_field [ "sort_index", `Int sort_index ]
+        :: common pid "thread_sort_index"
+    in
+    phase "M" :: fields
+  ;;
+
+  let to_json_fields : t -> (string * Json.t) list = function
+    | Counter (common, args, id) ->
+      let fields = json_fields_of_common_fields common in
+      let fields = phase "C" :: args_field args :: fields in
+      add_field_opt Id.field id fields
+    | Duration_start (common, args, id) ->
+      let fields = json_fields_of_common_fields common in
+      let fields = phase "B" :: args_field args :: fields in
+      add_field_opt Id.field id fields
+    | Duration_end { pid; tid; ts; args } ->
+      let fields = [ "tid", `Int tid; "pid", `Int pid; "ts", `Float ts; phase "E" ] in
+      add_field_opt args_field args fields
+    | Complete { common; dur; args; tdur } ->
+      let fields = json_fields_of_common_fields common in
+      let fields = phase "X" :: ("dur", Timestamp.to_json dur) :: fields in
+      let fields =
+        add_field_opt (fun tdur -> "tdur", Timestamp.to_json tdur) tdur fields
+      in
+      add_field_opt args_field args fields
+    | Instant (common, scope, args) ->
+      let fields = json_fields_of_common_fields common in
+      let fields = phase "i" :: fields in
+      let fields = add_field_opt (fun s -> "s", json_of_scope s) scope fields in
+      add_field_opt args_field args fields
+    | Async { common; async; scope; id; args } ->
+      let fields = json_fields_of_common_fields common in
+      let fields = Id.field id :: fields in
+      let fields =
+        let ph =
+          let s =
+            match async with
+            | Start -> "b"
+            | Instant -> "n"
+            | End -> "e"
+          in
+          phase s
+        in
+        ph :: fields
+      in
+      let fields = add_field_opt (fun s -> "scope", `String s) scope fields in
+      add_field_opt args_field args fields
+    | Object { common; object_kind; id; scope } ->
+      let fields = json_fields_of_common_fields common in
+      let fields = Id.field id :: fields in
+      let fields =
+        let ph, args =
+          match object_kind with
+          | New -> "N", None
+          | Destroy -> "D", None
+          | Snapshot { cat; args } ->
+            let snapshot =
+              add_field_opt
+                (fun cat -> "cat", `String (String.concat ~sep:"," cat))
+                cat
+                args
+            in
+            "O", Some [ "snapshot", `Assoc snapshot ]
+        in
+        let fields = phase ph :: fields in
+        add_field_opt args_field args fields
+      in
+      add_field_opt (fun s -> "scope", `String s) scope fields
+    | Metadata m -> json_fields_of_metadata m
+  ;;
+
+  let to_json t = `Assoc (to_json_fields t)
+  let counter ?id common args = Counter (common, args, id)
+  let complete ?tdur ?args ~dur common = Complete { common; tdur; dur; args }
+  let async ?scope ?args id async common = Async { common; args; scope; id; async }
+  let instant ?args ?scope common = Instant (common, scope, args)
+end
+
+module Output_object = struct
+  type t =
+    { displayTimeUnit : [ `Ms | `Ns ] option
+    ; traceEvents : Event.t list
+    ; stackFrames : (Id.t * Stack_frame.t) list option
+    ; extra_fields : (string * Json.t) list option
+    }
+
+  let to_json { displayTimeUnit; traceEvents; extra_fields; stackFrames } =
+    let json = [ "traceEvents", `List (List.map traceEvents ~f:Event.to_json) ] in
+    let json =
+      match displayTimeUnit with
+      | None -> json
+      | Some u ->
+        ( "displayTimeUnit"
+        , `String
+            (match u with
+             | `Ms -> "ms"
+             | `Ns -> "ns") )
+        :: json
+    in
+    let json : (string * Json.t) list =
+      match stackFrames with
+      | None -> json
+      | Some frames ->
+        let frames =
+          List.map frames ~f:(fun (id, frame) ->
+            let id = Id.to_string id in
+            id, Stack_frame.to_json frame)
+        in
+        ("stackFrames", `Assoc frames) :: json
+    in
+    let json =
+      match extra_fields with
+      | None -> json
+      | Some extra_fields -> json @ extra_fields
+    in
+    `Assoc json
+  ;;
+
+  let create ?displayTimeUnit ?extra_fields ?stackFrames ~traceEvents () =
+    { displayTimeUnit; extra_fields; traceEvents; stackFrames }
+  ;;
+end

unikernel/duniverse/dune_/otherlibs/chrome-trace/src/chrome_trace.mli

@@ -0,0 +1,110 @@
+[@@@alert unstable "The API of this library is not stable and may change without notice."]
+[@@@alert "-unstable"]
+
+(** Output trace data to a file in Chrome's trace_event format. This format is
+    compatible with chrome trace viewer [chrome://tracing].
+
+    Trace viewer is a part of the catapult project
+    (https://github.com/catapult-project/catapult/blob/master/tracing/README.md).
+
+    The trace format is documented at:
+    https://docs.google.com/document/d/1CvAClvFfyA5R-PhYUmn5OOQtYMH4h6I0nSsKchNAySU/preview *)
+
+module Json : sig
+  (** Simplifies JSON type *)
+  type t =
+    [ `Int of int
+    | `Float of float
+    | `String of string
+    | `List of t list
+    | `Bool of bool
+    | `Assoc of (string * t) list
+    | `Null
+    ]
+end
+
+module Id : sig
+  type t
+
+  val create : [ `String of string | `Int of int ] -> t
+end
+
+module Stack_frame : sig
+  module Raw : sig
+    type t
+
+    val create : string list -> t
+  end
+
+  type t
+
+  val create : ?parent:Id.t -> name:string -> category:string -> unit -> t
+end
+
+module Event : sig
+  type t
+
+  module Timestamp : sig
+    type t
+
+    val of_float_seconds : float -> t
+    val to_float_seconds : t -> float
+  end
+
+  type common_fields
+
+  val common_fields
+    :  ?tts:Timestamp.t
+    -> ?cname:string
+    -> ?cat:string list
+    -> ?pid:int
+    -> ?tid:int
+    -> ?stackframe:[ `Id of Id.t | `Raw of Stack_frame.Raw.t ]
+    -> ts:Timestamp.t
+    -> name:string
+    -> unit
+    -> common_fields
+
+  val ts : common_fields -> Timestamp.t
+  val set_ts : common_fields -> Timestamp.t -> common_fields
+
+  type args = (string * Json.t) list
+
+  (** Create a counter event *)
+  val counter : ?id:Id.t -> common_fields -> args -> t
+
+  type async =
+    | Start
+    | Instant
+    | End
+
+  val async : ?scope:string -> ?args:args -> Id.t -> async -> common_fields -> t
+  val complete : ?tdur:Timestamp.t -> ?args:args -> dur:Timestamp.t -> common_fields -> t
+  val to_json : t -> Json.t
+
+  (** The scope of an instant event. The scopes below come from the standard
+      reference for this format *)
+  type scope =
+    | Global
+    | Process
+    | Thread
+
+  (** Create an instant event. *)
+  val instant : ?args:args -> ?scope:scope -> common_fields -> t
+end
+
+module Output_object : sig
+  (** The object format provided in whole *)
+
+  type t
+
+  val create
+    :  ?displayTimeUnit:[ `Ms | `Ns ]
+    -> ?extra_fields:(string * Json.t) list
+    -> ?stackFrames:(Id.t * Stack_frame.t) list
+    -> traceEvents:Event.t list
+    -> unit
+    -> t
+
+  val to_json : t -> Json.t
+end

unikernel/duniverse/dune_/otherlibs/chrome-trace/src/dune

@@ -0,0 +1,4 @@
+(library
+ (name chrome_trace)
+ (public_name chrome-trace)
+ (synopsis "Emit catapult trace files, compatible with chrome://tracing"))

unikernel/duniverse/dune_/otherlibs/chrome-trace/test/chrome_trace_tests.ml

@@ -0,0 +1,51 @@
+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_stats.create (Custom { write; close; flush }) ~extended_build_job_info:false
+;;
+
+let () =
+  let module Event = Chrome_trace.Event in
+  let module Id = Chrome_trace.Id in
+  let module Timestamp = Event.Timestamp in
+  let events =
+    [ Event.complete
+        ~dur:(Timestamp.of_float_seconds 1.)
+        ~args:[ "foo", `String "bar" ]
+        (Event.common_fields ~ts:(Timestamp.of_float_seconds 0.5) ~name:"foo" ())
+    ; Event.counter
+        (Event.common_fields ~ts:(Timestamp.of_float_seconds 0.5) ~name:"cnt" ())
+        [ "bar", `Int 250 ]
+    ; Event.async
+        (Id.create (`String "foo"))
+        Event.Start
+        (Event.common_fields ~ts:(Timestamp.of_float_seconds 0.5) ~name:"async" ())
+        ~args:[ "foo", `Int 100 ]
+    ]
+  in
+  List.iter events ~f:(Dune_stats.emit c);
+  Dune_stats.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));
+  [%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}
+]
+|}]
+;;

unikernel/duniverse/dune_/otherlibs/chrome-trace/test/dune

@@ -0,0 +1,16 @@
+(library
+ (name chrome_trace_tests)
+ (inline_tests)
+ (libraries
+  dune_tests_common
+  stdune
+  dune_stats
+  chrome_trace
+  ;; This is because of the (implicit_transitive_deps false)
+  ;; in dune-project
+  ppx_expect.config
+  ppx_expect.config_types
+  base
+  ppx_inline_test.config)
+ (preprocess
+  (pps ppx_expect)))