unikernel/duniverse/dune_/bench/bench.ml

@@ -0,0 +1,275 @@
+open Stdune
+module Process = Dune_engine.Process
+
+module Console = struct
+  include Dune_console
+
+  let printf fmt = printf ("[Bench] " ^^ fmt)
+end
+
+module Json = struct
+  include Chrome_trace.Json
+  include Dune_stats.Json
+end
+
+module Output = struct
+  type measurement =
+    [ `Int of int
+    | `Float of float
+    ]
+
+  type bench =
+    { name : string
+    ; metrics : (string * [ measurement | `List of measurement list ] * string) list
+    }
+
+  let json_of_bench { name; metrics } : Json.t =
+    let metrics =
+      List.map metrics ~f:(fun (name, value, units) ->
+        let value =
+          match value with
+          | `Int i -> `Int i
+          | `Float f -> `Float f
+          | `List xs -> `List (xs :> Json.t list)
+        in
+        `Assoc [ "name", `String name; "value", value; "units", `String units ])
+    in
+    `Assoc [ "name", `String name; "metrics", `List metrics ]
+  ;;
+
+  type t =
+    { config : (string * Json.t) list
+    ; version : int
+    ; results : bench list
+    }
+
+  let to_json { config; version; results } : Json.t =
+    let assoc = [ "results", `List (List.map results ~f:json_of_bench) ] in
+    let assoc = ("version", `Int version) :: assoc in
+    let assoc =
+      match config with
+      | [] -> assoc
+      | _ :: _ -> ("config", `Assoc config) :: assoc
+    in
+    `Assoc assoc
+  ;;
+end
+
+let git =
+  lazy
+    (let path = Env.get Env.initial "PATH" |> Option.value_exn |> Bin.parse_path in
+     Bin.which ~path "git" |> Option.value_exn)
+;;
+
+let dune = Path.of_string (Filename.concat Fpath.initial_cwd Sys.argv.(1))
+let output_limit = Dune_engine.Execution_parameters.Action_output_limit.default
+let make_stdout () = Process.Io.make_stdout ~output_on_success:Swallow ~output_limit
+let make_stderr () = Process.Io.make_stderr ~output_on_success:Swallow ~output_limit
+
+module Package = struct
+  type t =
+    { org : string
+    ; name : string
+    }
+
+  let uri { org; name } = sprintf "https://github.com/%s/%s" org name
+  let make org name = { org; name }
+
+  let clone t =
+    let stdout_to = make_stdout () in
+    let stderr_to = make_stderr () in
+    let stdin_from = Process.Io.(null In) in
+    Process.run
+      Strict
+      ~display:Quiet
+      ~stdout_to
+      ~stderr_to
+      ~stdin_from
+      (Lazy.force git)
+      [ "clone"; uri t ]
+  ;;
+end
+
+let duniverse =
+  let pkg = Package.make in
+  [ pkg "ocaml-dune" "dune-bench" ]
+;;
+
+let prepare_workspace () =
+  Fiber.parallel_iter duniverse ~f:(fun (pkg : Package.t) ->
+    Fpath.rm_rf pkg.name;
+    Console.printf "cloning %s/%s" pkg.org pkg.name;
+    Fiber.finalize
+      (fun () -> Package.clone pkg)
+      ~finally:(fun () ->
+        Fiber.return @@ Console.printf "finished cloning %s/%s" pkg.org pkg.name))
+;;
+
+let dune_build ~name ~sandbox =
+  let stdin_from = Process.(Io.null In) in
+  let stdout_to = make_stdout () in
+  let stderr_to = make_stderr () in
+  let gc_dump = Temp.create File ~prefix:"gc_stat" ~suffix:name in
+  let open Fiber.O in
+  (* Build with timings and gc stats *)
+  let+ times =
+    Process.run_with_times
+      Strict
+      dune
+      ~display:Quiet
+      ~stdin_from
+      ~stdout_to
+      ~stderr_to
+      ([ "build"
+       ; "@install"
+       ; "--release"
+       ; "--cache" (* explicitly disable cache *)
+       ; "disabled"
+       ; "--dump-gc-stats"
+       ; Path.to_string gc_dump
+       ]
+       @
+       match sandbox with
+       | `Yes -> [ "--sandbox"; "hardlink" ]
+       | `No -> [])
+  in
+  (* Read the gc stats from the dump file *)
+  Dune_lang.Parser.parse_string
+    ~mode:Single
+    ~fname:(Path.to_string gc_dump)
+    (Io.read_file gc_dump)
+  |> Dune_lang.Decoder.parse Dune_util.Gc.decode Univ_map.empty
+  |> Metrics.make times
+;;
+
+let run_bench ~sandbox =
+  let open Fiber.O in
+  let* clean = dune_build ~name:"clean" ~sandbox in
+  let+ zero =
+    let rec zero acc n =
+      if n = 0
+      then Fiber.return (List.rev acc)
+      else
+        let* time = dune_build ~name:("zero" ^ string_of_int n) ~sandbox in
+        zero (time :: acc) (pred n)
+    in
+    zero [] 5
+  in
+  clean, zero
+;;
+
+type ('float, 'int) bench_results =
+  { size : int
+  ; clean : ('float, 'int) Metrics.t
+  ; zero : ('float, 'int) Metrics.t list
+  }
+
+let tag_results { size; clean; zero } =
+  let tag data = Metrics.map ~f:(fun t -> `Float t) ~g:(fun t -> `Int t) data in
+  let list_tag data =
+    List.map data ~f:tag
+    |> Metrics.unzip
+    |> Metrics.map ~f:(fun x -> `List x) ~g:(fun x -> `List x)
+  in
+  `Int size, tag clean, list_tag zero
+;;
+
+(** Display all clean and null builds with a few exceptions:
+
+    - fragments - not consistent between builds
+    - stack_size - not very useful
+    - forced_collections - only available in OCaml >= 4.12 *)
+let display_clean_and_zero_with_sandboxing
+      ({ elapsed_time
+       ; user_cpu_time
+       ; system_cpu_time
+       ; minor_words
+       ; promoted_words
+       ; major_words
+       ; minor_collections
+       ; major_collections
+       ; heap_words
+       ; heap_chunks
+       ; live_words
+       ; live_blocks
+       ; free_words
+       ; free_blocks
+       ; largest_free
+       ; fragments = _
+       ; compactions
+       ; top_heap_words
+       ; stack_size = _
+       } :
+        _ Metrics.t)
+      (zero : _ Metrics.t)
+  =
+  let display what units clean zero =
+    { Output.name = what
+    ; metrics = [ "[Clean] " ^ what, clean, units; "[Null] " ^ what, zero, units ]
+    }
+  in
+  [ display "Build Time" "Seconds" elapsed_time zero.elapsed_time
+  ; display "Minor Words" "Approx. Words" minor_words zero.minor_words
+  ; display "Promoted Words" "Approx. Words" promoted_words zero.promoted_words
+  ; display "Major Words" "Approx. Words" major_words zero.major_words
+  ; display "Minor Collections" "Collections" minor_collections zero.minor_collections
+  ; display "Major Collections" "Collections" major_collections zero.major_collections
+  ; display "Heap Words" "Words" heap_words zero.heap_words
+  ; display "Heap Chunks" "Chunks" heap_chunks zero.heap_chunks
+  ; display "Live Words" "Words" live_words zero.live_words
+  ; display "Live Blocks" "Blocks" live_blocks zero.live_blocks
+  ; display "Free Words" "Words" free_words zero.free_words
+  ; display "Free Blocks" "Blocks" free_blocks zero.free_blocks
+  ; display "Largest Free" "Words" largest_free zero.largest_free
+  ; display "Compactions" "Compactions" compactions zero.compactions
+  ; display "Top Heap Words" "Words" top_heap_words zero.top_heap_words
+  ; display "User CPU Time" "Seconds" user_cpu_time zero.user_cpu_time
+  ; display "System CPU Time" "Seconds" system_cpu_time zero.system_cpu_time
+  ]
+;;
+
+let format_results bench_results =
+  (* tagging data for json conversion *)
+  let size, clean, zero = tag_results bench_results in
+  (* bench results *)
+  [ { Output.name = "Misc"; metrics = [ "Size of _boot/dune.exe", size, "Bytes" ] } ]
+  @ display_clean_and_zero_with_sandboxing clean zero
+;;
+
+let () =
+  Dune_util.Log.init ~file:No_log_file ();
+  let dir = Temp.create Dir ~prefix:"dune" ~suffix:"bench" in
+  Sys.chdir (Path.to_string dir);
+  Path.as_external dir |> Option.value_exn |> Path.set_root;
+  Path.Build.set_build_dir (Path.Outside_build_dir.of_string "_build");
+  let module Scheduler = Dune_engine.Scheduler in
+  let config =
+    Dune_engine.Clflags.display := Quiet;
+    { Scheduler.Config.concurrency = 10
+    ; stats = None
+    ; print_ctrl_c_warning = false
+    ; watch_exclusions = []
+    }
+  in
+  let size =
+    let stat : Unix.stats = Path.stat_exn dune in
+    stat.st_size
+  in
+  let results =
+    Scheduler.Run.go config ~on_event:(fun _ _ -> ())
+    @@ fun () ->
+    let open Fiber.O in
+    (* Prepare the workspace *)
+    let* () = prepare_workspace () in
+    (* Build the clean and null builds *)
+    Console.printf "Building clean and null builds";
+    let+ clean, zero = run_bench ~sandbox:`No in
+    Console.printf "Finished building clean and null builds";
+    (* Return the bench results *)
+    format_results { size; clean; zero }
+  in
+  let version = 4 in
+  let output = { Output.config = []; version; results } in
+  print_string (Json.to_string (Output.to_json output));
+  flush stdout
+;;