robur/builder-web
4
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Builder_web.job_build_treemap: Calculating treemap visualization via CLI call to new binary

Browse source 
.. this doesn't block server on requests, as Lwt IO is run in parallel
This commit is contained in:
rand00 2022-01-24 13:34:04 +01:00 committed by Reynir Björnsson
parent f3178cace0
commit dde9d5b2da
1 changed files with 19 additions and 47 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

66
lib/builder_web.ml
View file

@ -183,6 +183,19 @@ let add_routes datadir =
|> Lwt_result.ok |> Lwt_result.ok
in in
let treemap_visualization_cmd ~elf_path ~elf_size =
let builder_viz_cmd =
(*> goto make work across different cwd's*)
let bin = "_build/default/bin/visualizations/builder_viz.exe" in
bin, [| bin; "treemap"; elf_path; Int.to_string elf_size |]
in
Lwt_process.pread ~stderr:`Dev_null builder_viz_cmd
|> Lwt_result.catch
|> Lwt_result.map_err (fun exn ->
Printexc.to_string exn, `Internal_Server_Error
)
in
let job_build_treemap req = let job_build_treemap req =
let _job_name = Dream.param "job" req let _job_name = Dream.param "job" req
and build = Dream.param "build" req in and build = Dream.param "build" req in
@ -200,54 +213,13 @@ let add_routes datadir =
|> if_error "Error getting job build" |> if_error "Error getting job build"
~log:(fun e -> Log.warn (fun m -> m "Error getting job build: %a" pp_error e)) ~log:(fun e -> Log.warn (fun m -> m "Error getting job build: %a" pp_error e))
>>= fun (debug_binary, main_binary) -> >>= fun (debug_binary, main_binary) ->
let binary_size = main_binary.Builder_db.size in let elf_size = main_binary.Builder_db.size in
let datadir = Dream.global datadir_global req in let datadir = Dream.global datadir_global req in
let path = Fpath.(datadir // debug_binary.Builder_db.localpath) in let elf_path = Fpath.(
let open Modulectomy in datadir // debug_binary.Builder_db.localpath
Lwt.return ( |> to_string
Result.map_error (fun _ -> `File_error path) ) in
(Elf.get (Fpath.to_string path))) treemap_visualization_cmd ~elf_path ~elf_size >>= fun svg_html ->
|> if_error "Error reading ELF binary"
~log:(fun _ -> Log.warn (fun m ->
m "Error reading ELF file %a" Fpath.pp path))
>>= fun infos ->
let svg_html =
let info, excluded_minors =
let size, info =
infos
|> Info.import
|> Info.diff_size_tree
in
(*> Note: this heuristic fails if one has all subtrees of equal size*)
let node_big_enough subtree =
match Info.(subtree.T.value.size) with
| None -> true
| Some subtree_size ->
let pct = Int64.(to_float subtree_size /. to_float size) in
pct > 0.004
in
info
|> Info.prefix_filename
|> Info.cut 2
|> Info.partition_subtrees node_big_enough
in
let scale_chunks =
let excluded_minors_size =
excluded_minors
|> List.map Info.compute_area
|> List.fold_left Int64.add 0L
in
[
"Smaller excluded entries", excluded_minors_size
]
in
info
|> Treemap.of_tree
|> Treemap.to_html_with_scale ~binary_size ~scale_chunks
|> Fmt.to_to_string (Tyxml.Html.pp ())
(* |> Treemap.svg
* |> Fmt.to_to_string (Tyxml.Svg.pp ()) *)
in
(* Lwt_result.ok (dream_svg svg) *) (* Lwt_result.ok (dream_svg svg) *)
Lwt_result.ok (Dream.html svg_html) Lwt_result.ok (Dream.html svg_html)
in in