├── gtk ├── main.mli ├── dune ├── main.ml └── gtk_viewer.ml ├── js-gen ├── main.mli ├── html.mli ├── dune ├── main.ml └── html.ml ├── Makefile ├── .gitignore ├── .merlin ├── examples └── net.ctf ├── unix ├── dune ├── mtv_unix.mli └── mtv_unix.ml ├── lib ├── dune ├── mtv_counter.ml ├── mtv_ctf_loader.mli ├── mtv_event.ml ├── mtv_sorted_array.ml ├── mtv_thread.mli ├── mtv_layout.ml ├── mtv_ITree.ml ├── mtv_view.mli ├── mtv_ctf_loader.ml ├── mtv_view.ml ├── mtv_thread.ml └── mtv_render.ml ├── js ├── dune ├── modal.mli ├── html_viewer.mli ├── modal.ml └── html_viewer.ml ├── 0install ├── build.sh └── mirage-trace-viewer.xml ├── README.md ├── mirage-trace-viewer.opam ├── mirage-trace-viewer-gtk.opam ├── mirage-trace-viewer-js.opam ├── dune-project └── LICENSE /gtk/main.mli: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /js-gen/main.mli: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | dune build 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | examples/*.bin 2 | setup.log 3 | _build 4 | -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | B _build/ 2 | S . 3 | PKG str lwt lwt.unix cairo2 xen-gnt io-page lablgtk2 4 | EXT lwt 5 | -------------------------------------------------------------------------------- /examples/net.ctf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/talex5/mirage-trace-viewer/HEAD/examples/net.ctf -------------------------------------------------------------------------------- /unix/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name mtv_unix) 3 | (public_name mirage-trace-viewer.unix) 4 | (libraries unix cmdliner)) 5 | -------------------------------------------------------------------------------- /js-gen/html.mli: -------------------------------------------------------------------------------- 1 | val write_to : string -> (string * Mirage_trace_viewer.Mtv_thread.vat) list -> [> `Error of bool * string | `Ok of unit ] 2 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name mirage_trace_viewer) 3 | (public_name mirage-trace-viewer) 4 | (libraries itv-tree ocplib-endian.bigstring)) 5 | -------------------------------------------------------------------------------- /unix/mtv_unix.mli: -------------------------------------------------------------------------------- 1 | type source = private string 2 | 3 | val load : source -> (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t 4 | 5 | val trace_files : source list Cmdliner.Term.t 6 | -------------------------------------------------------------------------------- /gtk/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (public_name mirage-trace-viewer-gtk) 4 | (package mirage-trace-viewer-gtk) 5 | (libraries mirage-trace-viewer mirage-trace-viewer.unix lablgtk2 cairo2-gtk cairo2 lwt lwt.unix str)) 6 | -------------------------------------------------------------------------------- /js/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name html_viewer) 3 | (public_name "mirage-trace-viewer-js.runtime") 4 | (preprocess (pps js_of_ocaml-ppx)) 5 | (libraries mirage-trace-viewer js_of_ocaml js_of_ocaml-ppx js_of_ocaml-tyxml js_of_ocaml-lwt)) 6 | -------------------------------------------------------------------------------- /js-gen/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (public_name mirage-trace-viewer-js) 4 | (package mirage-trace-viewer-js) 5 | (libraries mirage-trace-viewer mirage-trace-viewer.unix js_of_ocaml js_of_ocaml-ppx js_of_ocaml-tyxml js_of_ocaml-lwt)) 6 | -------------------------------------------------------------------------------- /0install/build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash -eux 2 | ./configure --enable-xen 3 | make 4 | mkdir ${DISTDIR}/bin 5 | mkdir ${DISTDIR}/gtk 6 | mkdir ${DISTDIR}/xen 7 | cp README.md ${DISTDIR}/ 8 | cp LICENSE ${DISTDIR}/ 9 | cp _build/gtk/mtv-gtk-plugin.cmxs ${DISTDIR}/gtk/ 10 | cp _build/xen/mtv-xen-plugin.cmxs ${DISTDIR}/xen/ 11 | cp _build/main/main.native ${DISTDIR}/bin/mirage-trace-viewer 12 | -------------------------------------------------------------------------------- /lib/mtv_counter.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2014, Thomas Leonard *) 2 | 3 | type time = float 4 | 5 | type scale = { 6 | mutable min : float; 7 | mutable max : float; 8 | } 9 | 10 | (** Measures some user-defined quantity (e.g. packets sent over time). *) 11 | type t = { 12 | name : string; 13 | values : (time * float) array; (* Sorted by time *) 14 | scale : scale; 15 | mutable shown : bool; 16 | } 17 | -------------------------------------------------------------------------------- /lib/mtv_ctf_loader.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2014, Thomas Leonard *) 2 | 3 | open Bigarray 4 | 5 | type packet 6 | type log_buffer = (char, int8_unsigned_elt, c_layout) Array1.t 7 | 8 | (** Locate packets in a trace stream and return them (using [Array1.sub]) in the correct order. *) 9 | val packets : log_buffer -> packet list 10 | 11 | val packet_data : packet -> log_buffer 12 | 13 | val from_bigarray : log_buffer -> Mtv_event.t list 14 | -------------------------------------------------------------------------------- /js/modal.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | (** Manage modal elements. A modal element is automatically closed when: 5 | * - another modal is shown, 6 | * - escape is pressed, or 7 | * - the user clicks outside the modal element *) 8 | 9 | open Js_of_ocaml 10 | 11 | val show : close:(unit -> unit) -> #Dom_html.element Js.t -> unit 12 | (** Show a new modal (closing any currently-open one first). *) 13 | 14 | val close : unit -> unit 15 | (** Close any currently open modal. *) 16 | 17 | val is_open : unit -> bool 18 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Viewer for CTF traces collected by [mirage-profile][]. 2 | 3 | To view a trace in a window using the GTK interface: 4 | 5 | ```bash 6 | mirage-trace-viewer-gtk ./examples/net.ctf 7 | ``` 8 | 9 | To generate a JavaScript viewer in the directory `htdocs`: 10 | 11 | ```bash 12 | mirage-trace-viewer-js --out=./htdocs ./examples/net.ctf 13 | ``` 14 | 15 | To dump a trace from a running Xen domain, use [mirage-trace-dump-xen][]. 16 | 17 | Examples can be found in the blog post [Visualising an Asynchronous Monad](http://roscidus.com/blog/blog/2014/10/27/visualising-an-asynchronous-monad/). 18 | 19 | [mirage-profile]: https://github.com/mirage/mirage-profile 20 | [mirage-trace-dump-xen]: https://github.com/talex5/mirage-trace-dump-xen 21 | -------------------------------------------------------------------------------- /lib/mtv_event.ml: -------------------------------------------------------------------------------- 1 | let printf = Printf.printf 2 | 3 | type thread = int 4 | 5 | type read_outcome = Read_resolved | Read_resolved_later | Read_sleeping 6 | 7 | type op = 8 | | Creates of thread * thread * string 9 | | Reads of thread * thread * read_outcome 10 | | Resolves of thread * thread * string option 11 | | Becomes of thread * thread 12 | | Label of thread * string 13 | | Switch of thread 14 | | Gc of float 15 | | Increases of thread * string * int (* Deprecated; use Counter_value instead *) 16 | | Counter_value of thread * string * int 17 | | Signals_and_switches of thread * thread 18 | | Signals of thread * thread 19 | 20 | type t = { 21 | time : float; 22 | op : op; 23 | } 24 | 25 | let fmt ch tid = Printf.fprintf ch "%d" (tid : thread :> int) 26 | -------------------------------------------------------------------------------- /js/html_viewer.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2014, Thomas Leonard *) 2 | 3 | open Mirage_trace_viewer 4 | open Js_of_ocaml 5 | 6 | val attach : ?grab_focus:bool -> Dom_html.canvasElement Js.t -> Mtv_view.t -> unit 7 | (** [attach canvas view] renders the view to the canvas and attaches event handlers 8 | to respond to events. *) 9 | 10 | val load : ?grab_focus:bool -> ?file:string -> ?metrics:string list -> ?range:(float * float) -> string -> unit 11 | (** [load name] loads "/static/.bin" and attaches it to the canvas element with ID [name]. 12 | @param grab_focus gives the keyboard focus to the new element after creating it 13 | @param file can be used to override the file name 14 | @param metrics limits the displayed metrics to those in the list 15 | @param range can be used to set the default timespan to display *) 16 | -------------------------------------------------------------------------------- /mirage-trace-viewer.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Viewer for CTF traces collected by mirage-profile" 4 | maintainer: ["talex5@gmail.com"] 5 | authors: ["talex5@gmail.com"] 6 | homepage: "https://github.com/talex5/mirage-trace-viewer" 7 | doc: "https://talex5.github.io/mirage-trace-viewer/" 8 | bug-reports: "https://github.com/talex5/mirage-trace-viewer/issues" 9 | depends: [ 10 | "dune" {>= "2.8"} 11 | "ocplib-endian" {>= "1.1"} 12 | "itv-tree" {>= "2.1"} 13 | "cmdliner" {>= "1.0.4"} 14 | "ocaml" {>= "4.08"} 15 | "odoc" {with-doc} 16 | ] 17 | build: [ 18 | ["dune" "subst"] {dev} 19 | [ 20 | "dune" 21 | "build" 22 | "-p" 23 | name 24 | "-j" 25 | jobs 26 | "@install" 27 | "@runtest" {with-test} 28 | "@doc" {with-doc} 29 | ] 30 | ] 31 | dev-repo: "git+https://github.com/talex5/mirage-trace-viewer.git" 32 | -------------------------------------------------------------------------------- /mirage-trace-viewer-gtk.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Viewer for CTF traces collected by mirage-profile" 4 | maintainer: ["talex5@gmail.com"] 5 | authors: ["talex5@gmail.com"] 6 | homepage: "https://github.com/talex5/mirage-trace-viewer" 7 | doc: "https://talex5.github.io/mirage-trace-viewer/" 8 | bug-reports: "https://github.com/talex5/mirage-trace-viewer/issues" 9 | depends: [ 10 | "dune" {>= "2.8"} 11 | "mirage-trace-viewer" {= version} 12 | "lwt" {>= "5.4.0"} 13 | "lablgtk" {>= "2.18.11"} 14 | "cairo2-gtk" {>= "0.6.2"} 15 | "cairo2" {>= "0.6.2"} 16 | "odoc" {with-doc} 17 | ] 18 | build: [ 19 | ["dune" "subst"] {dev} 20 | [ 21 | "dune" 22 | "build" 23 | "-p" 24 | name 25 | "-j" 26 | jobs 27 | "@install" 28 | "@runtest" {with-test} 29 | "@doc" {with-doc} 30 | ] 31 | ] 32 | dev-repo: "git+https://github.com/talex5/mirage-trace-viewer.git" 33 | -------------------------------------------------------------------------------- /js-gen/main.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2014, Thomas Leonard *) 2 | 3 | open Mirage_trace_viewer 4 | 5 | let main dir paths = 6 | let sources = 7 | paths |> List.map (fun path -> 8 | let data = Mtv_unix.load path |> Mtv_ctf_loader.from_bigarray |> Mtv_thread.of_events in 9 | (path :> string), data 10 | ) 11 | in 12 | Html.write_to dir sources 13 | 14 | open Cmdliner 15 | 16 | let html_output = 17 | let doc = "Output directory." in 18 | Arg.(required @@ opt (some string) None @@ info ~doc ~docv:"DIR" ["out"]) 19 | 20 | let () = 21 | let doc = "view mirage-profile trace data" in 22 | let man =[ 23 | `S "DESCRIPTION"; 24 | `P "To generate HTML and JavaScript files in $(b,htdocs):"; 25 | `P "mirage-trace-viewer-js --out=htdocs trace1.ctf trace2.ctf"; 26 | ] in 27 | let info = Cmd.info ~doc ~man "mirage-trace-viewer-js" in 28 | let term = Term.(ret (const main $ html_output $ Mtv_unix.trace_files)) in 29 | exit @@ Cmd.eval (Cmd.v info term) 30 | -------------------------------------------------------------------------------- /lib/mtv_sorted_array.ml: -------------------------------------------------------------------------------- 1 | (* The number of items at the start of the array for which [pred item] is false. 2 | * The array must be sorted so that the first part is all false and the second all true. *) 3 | let count_before pred arr = 4 | let rec loop lo hi = 5 | (* Answer is at least [lo] and at most [hi]. *) 6 | if hi = lo then lo 7 | else ( 8 | let mid = (lo + hi) / 2 in 9 | if pred arr.(mid) then loop lo mid 10 | else loop (mid + 1) hi 11 | ) in 12 | loop 0 (Array.length arr) 13 | 14 | (* Call [f i] on each item in the sorted array where [test_start i] is 15 | * true until [test_end i] is false (binary search). *) 16 | let iter_range arr test_start test_end f = 17 | let l = Array.length arr in 18 | let first = arr |> count_before (fun i2 -> test_start i2) in 19 | let rec aux i = 20 | if i = l then () 21 | else ( 22 | let i2 = arr.(i) in 23 | if test_end i2 then (f i2; aux (i + 1)) 24 | else () 25 | ) in 26 | aux first 27 | -------------------------------------------------------------------------------- /mirage-trace-viewer-js.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Viewer for CTF traces collected by mirage-profile" 4 | maintainer: ["talex5@gmail.com"] 5 | authors: ["talex5@gmail.com"] 6 | homepage: "https://github.com/talex5/mirage-trace-viewer" 7 | doc: "https://talex5.github.io/mirage-trace-viewer/" 8 | bug-reports: "https://github.com/talex5/mirage-trace-viewer/issues" 9 | depends: [ 10 | "dune" {>= "2.8"} 11 | "mirage-trace-viewer" {= version} 12 | "js_of_ocaml-tyxml" {>= "3.9.0"} 13 | "js_of_ocaml-ppx" {>= "3.9.0"} 14 | "js_of_ocaml-lwt" {>= "3.9.0"} 15 | "js_of_ocaml" {>= "3.9.0"} 16 | "odoc" {with-doc} 17 | ] 18 | build: [ 19 | ["dune" "subst"] {dev} 20 | [ 21 | "dune" 22 | "build" 23 | "-p" 24 | name 25 | "-j" 26 | jobs 27 | "@install" 28 | "@runtest" {with-test} 29 | "@doc" {with-doc} 30 | ] 31 | ] 32 | dev-repo: "git+https://github.com/talex5/mirage-trace-viewer.git" 33 | -------------------------------------------------------------------------------- /gtk/main.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2014, Thomas Leonard *) 2 | 3 | open Mirage_trace_viewer 4 | 5 | let main paths = 6 | try 7 | GMain.init () |> ignore; 8 | paths |> List.iter (fun path -> 9 | let vat = Mtv_unix.load path |> Mtv_ctf_loader.from_bigarray |> Mtv_thread.of_events in 10 | let win = Gtk_viewer.make ~name:(path :> string) vat in 11 | ignore (win#connect#destroy ~callback:(fun _ -> 12 | (* todo: only quit when last window is closed *) 13 | GMain.Main.quit ())); 14 | ); 15 | GMain.Main.main (); 16 | `Ok () 17 | with Gtk.Error msg -> 18 | `Error (false, msg) 19 | 20 | open Cmdliner 21 | 22 | let () = 23 | let doc = "view mirage-profile trace data" in 24 | let man =[ 25 | `S "DESCRIPTION"; 26 | `P "$(tname) views trace data from a file."; 27 | `P "mirage-trace-viewer-gtk trace.ctf"; 28 | ] in 29 | let info = Cmd.info ~doc ~man "mirage-trace-viewer-gtk" in 30 | let term = Term.(ret (const main $ Mtv_unix.trace_files)) in 31 | exit @@ Cmd.eval (Cmd.v info term) 32 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.8) 2 | (name mirage-trace-viewer) 3 | (formatting disabled) 4 | (generate_opam_files true) 5 | (source (github talex5/mirage-trace-viewer)) 6 | (authors "talex5@gmail.com") 7 | (maintainers "talex5@gmail.com") 8 | (documentation "https://talex5.github.io/mirage-trace-viewer/") 9 | (package 10 | (name mirage-trace-viewer) 11 | (synopsis "Viewer for CTF traces collected by mirage-profile") 12 | (depends 13 | (ocplib-endian (>= 1.1)) 14 | (itv-tree (>= 2.1)) 15 | (cmdliner (>= 1.0.4)) 16 | (ocaml (>= 4.08)))) 17 | (package 18 | (name mirage-trace-viewer-gtk) 19 | (synopsis "Viewer for CTF traces collected by mirage-profile") 20 | (depends 21 | (mirage-trace-viewer (= :version)) 22 | (lwt (>= 5.4.0)) 23 | (lablgtk (>= 2.18.11)) 24 | (cairo2-gtk (>= 0.6.2)) 25 | (cairo2 (>= 0.6.2)))) 26 | (package 27 | (name mirage-trace-viewer-js) 28 | (synopsis "Viewer for CTF traces collected by mirage-profile") 29 | (depends 30 | (mirage-trace-viewer (= :version)) 31 | (js_of_ocaml-tyxml (>= 3.9.0)) 32 | (js_of_ocaml-ppx (>= 3.9.0)) 33 | (js_of_ocaml-lwt (>= 3.9.0)) 34 | (js_of_ocaml (>= 3.9.0)))) 35 | -------------------------------------------------------------------------------- /0install/mirage-trace-viewer.xml: -------------------------------------------------------------------------------- 1 | 2 | 4 | mirage-trace-viewer 5 | viewer for mirage-profile trace files 6 | 7 | 8 | Can load trace data from a file, a running Unix process or a Xen domain and save 9 | it to a CTF file, display it in a GTK window, or generate a JavaScript viewer 10 | for it. 11 | 12 | 13 | https://github.com/talex5/mirage-trace-viewer 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Thomas Leonard 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 5 | 6 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 7 | 8 | 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | 10 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 11 | -------------------------------------------------------------------------------- /unix/mtv_unix.ml: -------------------------------------------------------------------------------- 1 | type source = string 2 | 3 | let copy src dst = 4 | let len = 4096 in 5 | let buf = Bytes.make len ' ' in 6 | let rec aux () = 7 | match input src buf 0 len with 8 | | 0 -> () 9 | | n -> output dst buf 0 n; aux () in 10 | aux () 11 | 12 | let open_trace_file = function 13 | | "-" -> 14 | let tmp = Filename.temp_file "mtv-" ".ctf" in 15 | let fd = Unix.(openfile tmp [O_RDWR] 0) in 16 | let fd2 = Unix.(openfile tmp [O_RDONLY] 0) in 17 | Unix.unlink tmp; 18 | let ch = Unix.out_channel_of_descr fd in 19 | copy stdin ch; 20 | close_out ch; 21 | fd2 22 | | trace_file -> 23 | Unix.(openfile trace_file [O_RDONLY] 0) 24 | 25 | let load trace_file = 26 | let open Bigarray in 27 | let fd = open_trace_file trace_file in 28 | let size = Unix.((fstat fd).st_size) in 29 | let ba = 30 | Unix.map_file fd char c_layout false [| size |] 31 | |> Bigarray.array1_of_genarray 32 | in 33 | Unix.close fd; 34 | ba 35 | 36 | open Cmdliner 37 | 38 | let parse_trace_filename trace_file = 39 | match trace_file with 40 | | "-" -> `Ok "-" 41 | | trace_file -> fst Arg.non_dir_file trace_file 42 | 43 | let input_file : (_ Arg.conv) = (parse_trace_filename, Format.pp_print_string) 44 | 45 | let trace_files = 46 | let doc = "The CTF-format trace file from which to load the trace data." in 47 | Arg.(non_empty @@ pos_all input_file [] @@ info ~doc ~docv:"TRACE-FILE" []) 48 | -------------------------------------------------------------------------------- /lib/mtv_thread.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2014, Thomas Leonard *) 2 | 3 | (** A single thread/promise. *) 4 | type t 5 | 6 | (** A group of threads, cooperatively threaded within the vat. *) 7 | type vat 8 | 9 | type time = float 10 | type interaction = Resolve | Read | Try_read | Signal 11 | 12 | val top_thread : vat -> t 13 | val gc_periods : vat -> (time * time) list 14 | 15 | val thread_type : t -> string 16 | 17 | val start_time : t -> time 18 | val end_time : t -> time 19 | 20 | (** For simplified binds, we don't show the creating thread (parent might no longer exist). *) 21 | val show_creation : t -> bool 22 | 23 | (** Threads created by this one, in *reverse* order. *) 24 | val creates : t -> t list 25 | 26 | (** At this thread's end_time, it is not resolved, but merges with another thread. *) 27 | val becomes : t -> t option 28 | 29 | val labels : t -> (time * string) list 30 | 31 | (** If the thread failed, the string of the exception. *) 32 | val failure : t -> string option 33 | 34 | (** Interactions initiated by this thread (reverse order) *) 35 | val interactions : t -> (time * interaction * t) list 36 | 37 | (** Return the times when the thread was running. *) 38 | val activations : t -> (time * time) list 39 | 40 | (** Does the thread end because it was resolved, or just because we didn't 41 | * see any more events? Only meaningful if [becomes t] is None. *) 42 | val resolved : t -> bool 43 | 44 | (** Parse a trace file, returning the root thread. *) 45 | val of_events : ?simplify:bool -> Mtv_event.t list -> vat 46 | 47 | val set_y : t -> float -> unit 48 | val y : t -> float 49 | 50 | (** Sorts by y first, then by thread ID *) 51 | val compare : t -> t -> int 52 | 53 | val id : t -> int 54 | 55 | val iter : (t -> unit) -> t -> unit 56 | 57 | val counters : vat -> Mtv_counter.t list 58 | 59 | val dump : t -> unit 60 | (** Dump to console, for debugging *) 61 | -------------------------------------------------------------------------------- /lib/mtv_layout.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2014, Thomas Leonard *) 2 | 3 | module IT = Mtv_ITree.Make(Mtv_thread) 4 | 5 | type t = IT.Interval.t IT.tree 6 | 7 | let fold ~init fn thread = 8 | let rec aux acc t = 9 | let acc = fn acc t in 10 | List.fold_left aux acc (Mtv_thread.creates t) in 11 | Mtv_thread.creates thread |> List.fold_left aux init 12 | 13 | exception Found_gap 14 | 15 | let arrange top_thread = 16 | let max_y = ref 0. in 17 | let add_interval acc t = 18 | assert (Mtv_thread.end_time t >= Mtv_thread.start_time t); 19 | { Interval_tree.Interval. 20 | lbound = Mtv_thread.start_time t; 21 | rbound = Mtv_thread.end_time t; 22 | value = t 23 | } :: acc in 24 | let intervals = fold add_interval top_thread ~init:[] in 25 | let layout = IT.create intervals in 26 | let rec process t ~parent = 27 | let overlaps = IT.overlapping_interval layout (Mtv_thread.start_time t, Mtv_thread.end_time t) in 28 | let p_interval = {Interval_tree.Interval.lbound = Mtv_thread.start_time parent; rbound = Mtv_thread.end_time parent; value = parent} in 29 | let _, overlap_parent, below_parent = overlaps |> IT.IntervalSet.split p_interval in 30 | let y = ref (max 0.5 (Mtv_thread.y parent)) in 31 | begin match Mtv_thread.becomes parent with 32 | | Some child when child == t -> () 33 | | _ -> if overlap_parent && parent != top_thread then y := !y +. 30. end; 34 | 35 | begin try 36 | below_parent |> IT.IntervalSet.iter (fun i -> 37 | let iy = Mtv_thread.y i.Interval_tree.Interval.value in 38 | if iy = !y then y := !y +. 30. 39 | else if iy > !y then raise Found_gap 40 | ); 41 | with Found_gap -> () end; 42 | 43 | Mtv_thread.set_y t !y; 44 | max_y := max !max_y !y; 45 | Mtv_thread.creates t |> List.iter (process ~parent:t) in 46 | Mtv_thread.creates top_thread |> List.iter (process ~parent:top_thread); 47 | layout, !max_y 48 | 49 | -------------------------------------------------------------------------------- /js/modal.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | open Js_of_ocaml 5 | 6 | let ignore_listener : Dom_html.event_listener_id -> unit = ignore 7 | 8 | let inside elem child = 9 | let elem = (elem :> Dom.node Js.t) in 10 | let rec aux child = 11 | if elem == child then true 12 | else ( 13 | Js.Opt.case child##.parentNode 14 | (fun () -> false) 15 | aux 16 | ) in 17 | aux (child :> Dom.node Js.t) 18 | 19 | let keycode_escape = 27 20 | 21 | type t = { 22 | element : Dom_html.element Js.t; 23 | close : unit -> unit; 24 | } 25 | 26 | let current = ref None 27 | 28 | let close () = 29 | match !current with 30 | | None -> () 31 | | Some t -> 32 | current := None; 33 | t.close () 34 | 35 | let show ~close:c element = 36 | close (); 37 | current := Some { 38 | element = (element :> Dom_html.element Js.t); 39 | close = c; 40 | } 41 | 42 | (* Listen to global clicks and keypresses so we can close modals on click/escape *) 43 | let () = 44 | let click (ev:#Dom_html.mouseEvent Js.t) = 45 | match !current with 46 | | None -> Js._true 47 | | Some modal -> 48 | Js.Opt.case ev##.target 49 | (fun () -> Js._true) 50 | (fun target -> 51 | if target |> inside modal.element then ( 52 | (* Click inside modal - pass it on *) 53 | Js._true 54 | ) else ( 55 | (* Click outside modal; close the modal *) 56 | close (); 57 | Dom_html.stopPropagation ev; 58 | Js._false 59 | ) 60 | ) in 61 | let keyup ev = 62 | match !current with 63 | | Some _ when ev##.keyCode = keycode_escape -> 64 | close (); 65 | Dom_html.stopPropagation ev; 66 | Js._false 67 | | _ -> Js._true in 68 | Dom_html.addEventListener Dom_html.document Dom_html.Event.click (Dom.handler click) Js._true |> ignore_listener; 69 | Dom_html.addEventListener Dom_html.document Dom_html.Event.keypress (Dom.handler keyup) Js._true |> ignore_listener 70 | 71 | let is_open () = 72 | !current <> None 73 | -------------------------------------------------------------------------------- /lib/mtv_ITree.ml: -------------------------------------------------------------------------------- 1 | module Make(Value : Set.OrderedType) = struct 2 | 3 | module Interval = struct 4 | open Interval_tree.Interval 5 | 6 | type t = Value.t Interval_tree.Interval.t 7 | 8 | let compare a b = 9 | match Value.compare a.value b.value with 10 | | 0 -> 11 | begin match compare a.lbound b.lbound with 12 | | 0 -> compare a.rbound b.rbound 13 | | r -> r end 14 | | r -> r 15 | end 16 | 17 | module IntervalSet = Set.Make(Interval) 18 | 19 | type 'a tree = { 20 | by_start : Interval.t array; 21 | by_end : Interval.t array; 22 | by_point : Value.t Interval_tree.t; 23 | } 24 | 25 | let compare_by_start a b = 26 | let open Interval_tree.Interval in 27 | compare a.lbound b.lbound 28 | 29 | let compare_by_end a b = 30 | let open Interval_tree.Interval in 31 | compare a.rbound b.rbound 32 | 33 | let create intervals = 34 | let by_start = Array.of_list intervals in 35 | Array.sort compare_by_start by_start; 36 | let by_end = Array.copy by_start in 37 | Array.sort compare_by_end by_end; 38 | { 39 | by_start; 40 | by_end; 41 | by_point = Interval_tree.create intervals; 42 | } 43 | 44 | (* Extend [acc] with intervals from the sorted array [intervals] from the 45 | * index where [test_start interval] is true until [test_end interval] is false. *) 46 | let add_range intervals test_start test_end acc = 47 | let l = Array.length intervals in 48 | let first = intervals |> Mtv_sorted_array.count_before (fun i2 -> test_start i2) in 49 | let rec collect acc i = 50 | if i = l then acc 51 | else ( 52 | let i2 = intervals.(i) in 53 | if test_end i2 then collect (IntervalSet.add i2 acc) (i + 1) 54 | else acc 55 | ) in 56 | collect acc first 57 | 58 | let overlapping_interval t (lbound, rbound) = 59 | (* Intervals overlapping lbound..!rbound are those which: 60 | * - straddle the whole interval OR 61 | * - start inside the interval OR 62 | * - end inside the interval *) 63 | 64 | (* Everything that straddles the interval will also straddle its lower bound. 65 | * This will also include intervals that end inside the interval, but we want those anyway. *) 66 | let straddling_start = 67 | Interval_tree.query t.by_point lbound 68 | |> List.fold_left (fun acc i -> 69 | if i.Interval_tree.Interval.rbound > lbound then (* (right bound is exclusive) *) 70 | IntervalSet.add i acc 71 | else 72 | acc 73 | ) IntervalSet.empty in 74 | 75 | let open Interval_tree.Interval in 76 | straddling_start 77 | |> add_range t.by_start (fun i -> lbound <= i.lbound) (fun i -> i.lbound < rbound) 78 | |> add_range t.by_end (fun i -> lbound < i.rbound) (fun i -> i.rbound <= rbound) 79 | end 80 | -------------------------------------------------------------------------------- /lib/mtv_view.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2014, Thomas Leonard *) 2 | 3 | (** Some values used for calculating vertical positions. 4 | * Saved so we don't have to regenerate them for every thread. *) 5 | type v_projection 6 | 7 | type t 8 | 9 | module ThreadSet : Set.S with type elt = Mtv_thread.t 10 | 11 | val h_margin : float 12 | val v_margin : float 13 | 14 | val x_of_time : t -> Mtv_thread.time -> float 15 | val time_of_x : t -> float -> Mtv_thread.time 16 | val clip_x_of_time : t -> Mtv_thread.time -> float 17 | val width_of_timespan : t -> Mtv_thread.time -> float 18 | val timespan_of_width : t -> float -> Mtv_thread.time 19 | 20 | val x_of_start : t -> Mtv_thread.t -> float 21 | val x_of_end : t -> Mtv_thread.t -> float 22 | 23 | val y_of_thread : t -> Mtv_thread.t -> float 24 | 25 | (** Convert a y-position in screen units to thread units (undoing the effect of the projection). *) 26 | val y_of_view_y : t -> float -> float 27 | 28 | (** Convert a y-position in thread units to screen units. *) 29 | val view_y_of_y : t -> float -> float 30 | 31 | (** Distance between the focal y and this thread in thread coordinates. 32 | * This is used to decide whether it's worth rendering text on this thread. *) 33 | val dist_from_focus : t -> Mtv_thread.t -> float 34 | 35 | val visible_threads : t -> (float * float) -> Mtv_layout.IT.IntervalSet.t 36 | 37 | val iter_interactions : t -> float -> float -> (Mtv_thread.t * Mtv_thread.time * Mtv_thread.interaction * Mtv_thread.t * Mtv_thread.time -> unit) -> unit 38 | 39 | val make : view_width:float -> view_height:float -> vat:Mtv_thread.vat -> t 40 | 41 | (** Returns [min, max, size, value] for each scrollbar. *) 42 | val scroll_bounds : t -> (float * float * float * float) * (float * float * float * float) 43 | 44 | val set_size : t -> float -> float -> unit 45 | 46 | (** Set [view_start_time], within the allowed limits. 47 | * Returns the new horizontol scrollbar position. *) 48 | val set_start_time : t -> Mtv_thread.time -> float 49 | 50 | (** Set the focal y. Returns the input value clamped to the acceptable range. *) 51 | val set_view_y : t -> float -> float 52 | 53 | (** Set the scale factor for converting times to widths. *) 54 | val set_scale : t -> float -> unit 55 | 56 | (** Multiply the scale by the given factor. *) 57 | val zoom : t -> float -> unit 58 | 59 | (** [set_view_y_so v y view_y] sets the focal_y so that [y] appears at [view_y]. 60 | * Returns the new focal y. *) 61 | val set_view_y_so : t -> float -> float -> float 62 | 63 | (** Timespan between grid lines. *) 64 | val grid_step : t -> float 65 | 66 | val vat : t -> Mtv_thread.vat 67 | 68 | (** The time corresponding to the left edge of the visible area. *) 69 | val view_start_time : t -> Mtv_thread.time 70 | 71 | (** The width of the viewport, in screen units. *) 72 | val view_width : t -> float 73 | 74 | (** The height of the viewport, in screen units. *) 75 | val view_height : t -> float 76 | 77 | val clone : t -> t 78 | 79 | val thread_at : t -> x:float -> y:float -> Mtv_thread.t option 80 | (** Return the thread at or near to the given point (probably from a mouse click), or 81 | * None if there is nothing nearby. *) 82 | 83 | val highlights : t -> ThreadSet.t 84 | val set_highlights : t -> ThreadSet.t -> unit 85 | val highlight_related : t -> Mtv_thread.t -> unit 86 | (** Highlight this thread, threads that it becomes or which became it, recursively. *) 87 | 88 | val highlight_matches : t -> (string -> bool) -> unit 89 | (** [highlight_matches t query] highlights those threads for which [query label] returns [true] for some label. *) 90 | 91 | val show_metrics : t -> bool 92 | val set_show_metrics : t -> bool -> unit 93 | -------------------------------------------------------------------------------- /js-gen/html.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2014, Thomas Leonard *) 2 | 3 | open Mirage_trace_viewer 4 | 5 | let ( / ) = Filename.concat 6 | 7 | let error fmt = 8 | let do_raise msg = `Error (false, msg) in 9 | Printf.ksprintf do_raise fmt 10 | 11 | let check_exit_status = function 12 | | Unix.WEXITED 0 -> `Ok () 13 | | Unix.WEXITED code -> error "Child returned error exit status %d" code 14 | | Unix.WSIGNALED signal -> error "Child aborted (signal %d)" signal 15 | | Unix.WSTOPPED signal -> error "Child is currently stopped (signal %d)" signal 16 | 17 | (* From Unix.ml (not exported) *) 18 | let rec waitpid_non_intr pid = 19 | try Unix.waitpid [] pid 20 | with Unix.Unix_error (Unix.EINTR, _, _) -> waitpid_non_intr pid 21 | 22 | let reap_child child_pid = 23 | check_exit_status @@ snd @@ waitpid_non_intr child_pid 24 | 25 | let ( >>= ) x fn = 26 | match x with 27 | | `Error _ as e -> e 28 | | `Ok x -> fn x 29 | 30 | let rec iter_s f = function 31 | | [] -> `Ok () 32 | | x::xs -> f x >>= fun () -> iter_s f xs 33 | 34 | let finally_do cleanup f resource = 35 | let result = 36 | try f resource 37 | with ex -> cleanup resource; raise ex in 38 | cleanup resource; 39 | result 40 | 41 | let write_if_missing dir (name, contents) = 42 | let path = dir / name in 43 | if Sys.file_exists path then `Ok () 44 | else ( 45 | let ch = 46 | try `Ok (open_out_gen [Open_creat; Open_binary; Open_wronly] 0o644 path) 47 | with Sys_error msg -> error "Open failed: %s" msg in 48 | ch >>= finally_do close_out (fun ch -> 49 | output_string ch contents; 50 | `Ok () 51 | ) 52 | ) 53 | 54 | let html : (_, _, _) format = "\ 55 | \n\ 56 | \n\ 57 | \n\ 58 | \n\ 59 | \n\ 60 | \n\ 61 | \n\ 83 | Mirage Trace Toolkit\n\ 84 | \n\ 85 | \n\ 86 | \n\ 87 | \n\ 88 | \n\ 89 | \n\ 90 | " 91 | 92 | let run argv = 93 | print_endline (String.concat " " argv); 94 | Unix.create_process (List.hd argv) (Array.of_list argv) Unix.stdin Unix.stdout Unix.stderr 95 | |> reap_child 96 | 97 | let write_to dir sources = 98 | if not (Sys.file_exists dir) then Unix.mkdir dir 0o755; 99 | if not (Sys.is_directory dir) then `Error (false, "Not a directory: " ^ dir) 100 | else ( 101 | let loads = ref [] in 102 | let bin_args = 103 | sources |> List.mapi (fun i (name, vat) -> 104 | let name = Filename.basename name in 105 | let v = Mtv_view.make ~vat ~view_width:640. ~view_height:480. in 106 | let bin_file = name ^ ".bin" in 107 | let ch = open_out (dir / bin_file) in 108 | Marshal.to_channel ch v []; 109 | close_out ch; 110 | let focus = 111 | if i = 0 then "~grab_focus:true " else "" in 112 | loads := Printf.sprintf "Html_viewer.load %s%S;" focus name :: !loads; 113 | ["--file"; String.escaped bin_file] 114 | ) 115 | |> List.concat in 116 | let skeleton_files = [ 117 | "dune-project", "(lang dune 2.8)"; 118 | "dune", 119 | Printf.sprintf 120 | {|(executable 121 | (name loader) 122 | (modes byte) 123 | (libraries mirage-trace-viewer-js.runtime)) 124 | |}; 125 | "Makefile", 126 | Printf.sprintf 127 | "all:\ 128 | \n\tdune build --profile=release ./loader.bc\ 129 | \n\tjs_of_ocaml --opt=3 _build/default/loader.bc -I . %s -o loader.js" (String.concat " " bin_args); 130 | "loader.ml", 131 | "let () =\n " ^ String.concat "\n " !loads ^ "\n"; 132 | "trace.html", 133 | Printf.sprintf html (Filename.basename (fst (List.hd sources))) 134 | ] in 135 | skeleton_files |> iter_s (write_if_missing dir) >>= fun () -> 136 | run ["make"; "-C"; dir] 137 | ) 138 | -------------------------------------------------------------------------------- /lib/mtv_ctf_loader.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2014, Thomas Leonard *) 2 | 3 | open Mtv_event 4 | open Bigarray 5 | 6 | type log_buffer = (char, int8_unsigned_elt, c_layout) Array1.t 7 | 8 | let thread_type_of_int = function 9 | | 0 -> "Wait" 10 | | 1 -> "Task" 11 | | 2 -> "Bind" 12 | | 3 -> "Try" 13 | | 4 -> "Choose" 14 | | 5 -> "Pick" 15 | | 6 -> "Join" 16 | | 7 -> "Map" 17 | | 8 -> "Condition" 18 | | 9 -> "On_success" 19 | | 10 -> "On_failure" 20 | | 11 -> "On_termination" 21 | | 12 -> "On_any" 22 | | 13 -> "Ignore_result" 23 | | 14 -> "Async" 24 | | 15 -> "Promise" 25 | | 16 -> "Semaphore" 26 | | 17 -> "Switch" 27 | | x -> Printf.eprintf "Warning: unknown thread type '%d'\n%!" x; "Unknown" 28 | 29 | let uuid = "\x05\x88\x3b\x8d\x52\x1a\x48\x7b\xb3\x97\x45\x6a\xb1\x50\x68\x0c" 30 | 31 | type packet = { 32 | mutable packet_counter : int; 33 | start_offset : int; 34 | end_offset : int; 35 | packet_data : log_buffer; 36 | } 37 | 38 | let error fmt = 39 | Printf.ksprintf failwith fmt 40 | 41 | let order_packets = function 42 | | [] -> [] 43 | | (first :: _) as packets -> 44 | (* When the packet counter suddently drops, there are two possibilities: 45 | * - we wrapped back to -2^15 and this is the next packet 46 | * - the next packet is the earliest in the ring *) 47 | let prev_count = ref first.packet_counter in 48 | let earliest_packet = 49 | try 50 | packets |> List.find (fun packet -> 51 | let diff = (packet.packet_counter - !prev_count) land 0xffff in 52 | prev_count := packet.packet_counter; 53 | diff > 0x8000 (* Large jump => this is not the next packet, but the first *) 54 | ) 55 | with Not_found -> first in 56 | (* Printf.printf "Earliest packet is 0x%x\n" earliest_packet.packet_counter; *) 57 | let base_counter = earliest_packet.packet_counter in 58 | packets 59 | |> List.map (fun p -> {p with packet_counter = (p.packet_counter - base_counter) land 0xffff}) 60 | |> List.sort (fun a b -> compare a.packet_counter b.packet_counter) 61 | 62 | let packets data = 63 | let rec aux packet_start = 64 | if packet_start = Array1.dim data then [] 65 | else ( 66 | (* Printf.printf "Read header at %d\n" packet_start; *) 67 | let magic = EndianBigstring.LittleEndian.get_int32 data packet_start in 68 | if magic <> 0xc1fc1fc1l then failwith "Not a CTF log packet (bad magic)"; 69 | for i = 0 to 15 do 70 | if Array1.get data (packet_start + 4 + i) <> uuid.[i] then failwith "Packet UUID doesn't match!" 71 | done; 72 | let packet_size = EndianBigstring.LittleEndian.get_int32 data (packet_start + 20) |> Int32.to_int in 73 | let packet_counter = EndianBigstring.LittleEndian.get_uint16 data (packet_start + 24) in 74 | let packet_content_size = EndianBigstring.LittleEndian.get_int32 data (packet_start + 26) |> Int32.to_int in 75 | if packet_content_size > packet_size then 76 | error "Packet at 0x%x has content_size (%d bits) > size (%d bits)" packet_start packet_content_size packet_size; 77 | let header_length = 30 in 78 | let first_event = packet_start + header_length in 79 | let packet_data = Array1.sub data first_event (packet_content_size / 8 - header_length) in 80 | let item = { 81 | start_offset = packet_start; 82 | end_offset = packet_start + packet_content_size / 8; 83 | packet_counter; 84 | packet_data 85 | } in 86 | (* Printf.printf "Found packet 0x%x at offset %d\n" packet_counter packet_start; *) 87 | item :: aux (packet_start + packet_size / 8) 88 | ) in 89 | order_packets (aux 0) 90 | 91 | let packet_data p = p.packet_data 92 | 93 | let from_bigarray stream_data = 94 | let events = ref [] in 95 | 96 | packets stream_data |> List.iter (fun packet -> 97 | let data = packet.packet_data in 98 | let pos = ref 0 in 99 | let read64 () = 100 | let v = EndianBigstring.LittleEndian.get_int64 data !pos in 101 | pos := !pos + 8; 102 | v in 103 | let read8 () = 104 | let v = EndianBigstring.LittleEndian.get_int8 data !pos in 105 | pos := !pos + 1; 106 | v in 107 | let read_thread () = 108 | read64 () |> Int64.to_int in (* FIXME: will fail on 32-bit platforms *) 109 | let read_string () = 110 | let b = Buffer.create 10 in 111 | let rec aux i = 112 | match EndianBigstring.LittleEndian.get_char data i with 113 | | '\x00' -> pos := i + 1; Buffer.contents b 114 | | x -> Buffer.add_char b x; aux (i + 1) in 115 | aux !pos in 116 | 117 | try 118 | while !pos < Array1.dim data do 119 | let time = read64 () in 120 | let op = 121 | match read8 () with 122 | | 0 -> 123 | let parent = read_thread () in 124 | let child = read_thread () in 125 | let thread_type = read8 () in 126 | Creates (parent, child, thread_type_of_int thread_type) 127 | | 1 -> 128 | let reader = read_thread () in 129 | let input = read_thread () in 130 | Reads (reader, input, Read_resolved) 131 | | 2 -> 132 | let resolver = read_thread () in 133 | let thread = read_thread () in 134 | Resolves (resolver, thread, None) 135 | | 3 -> 136 | let resolver = read_thread () in 137 | let thread = read_thread () in 138 | let ex = read_string () in 139 | Resolves (resolver, thread, Some ex) 140 | | 4 -> 141 | let bind = read_thread () in 142 | let thread = read_thread () in 143 | Becomes (bind, thread) 144 | | 5 -> 145 | let thread = read_thread () in 146 | let label = read_string () in 147 | Label (thread, label) 148 | | 6 -> 149 | let thread = read_thread () in 150 | let amount = read64 () |> Int64.to_int in 151 | let counter = read_string () in 152 | Increases (thread, counter, amount) 153 | | 7 -> 154 | let thread = read_thread () in 155 | Switch thread 156 | | 8 -> 157 | let duration = read64 () in 158 | Gc (Int64.to_float duration /. 1_000_000_000.) 159 | | 9 -> 160 | let recv = read_thread () in 161 | let sender = read_thread () in 162 | Signals_and_switches (sender, recv) 163 | | 10 -> 164 | let reader = read_thread () in 165 | let input = read_thread () in 166 | Reads (reader, input, Read_sleeping) 167 | | 11 -> 168 | let thread = read_thread () in 169 | let value = read64 () |> Int64.to_int in 170 | let counter = read_string () in 171 | Counter_value (thread, counter, value) 172 | | 12 -> 173 | let reader = read_thread () in 174 | let input = read_thread () in 175 | Reads (reader, input, Read_resolved_later) 176 | | 13 -> 177 | let recv = read_thread () in 178 | let sender = read_thread () in 179 | Signals (sender, recv) 180 | | x -> error "Unknown event op %d" x in 181 | let event = { 182 | time = Int64.to_float time /. 1_000_000_000.; 183 | op; 184 | } in 185 | events := event :: !events 186 | done 187 | with ex -> 188 | Printf.eprintf "Error at offset 0x%x (in packet 0x%x - 0x%x); skipping rest of packet:\n%s\n%!" 189 | (!pos + packet.start_offset) 190 | packet.start_offset 191 | packet.end_offset 192 | (Printexc.to_string ex) 193 | ); 194 | List.rev !events 195 | -------------------------------------------------------------------------------- /gtk/gtk_viewer.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2014, Thomas Leonard *) 2 | 3 | open Mirage_trace_viewer 4 | 5 | let (==>) (signal:(callback:_ -> GtkSignal.id)) callback = 6 | ignore (signal ~callback) 7 | 8 | module Canvas = struct 9 | include Cairo 10 | 11 | let move_to cr ~x ~y = move_to cr x y 12 | let line_to cr ~x ~y = line_to cr x y 13 | let rectangle cr ~x ~y ~w ~h = rectangle cr x y ~w ~h 14 | 15 | let paint_text cr ?clip_area ~x ~y msg = 16 | match clip_area with 17 | | None -> 18 | move_to cr ~x ~y; 19 | show_text cr msg 20 | | Some (w, h) -> 21 | save cr; 22 | rectangle cr ~x ~y:0.0 ~w ~h; 23 | clip cr; 24 | move_to cr ~x ~y; 25 | show_text cr msg; 26 | restore cr 27 | 28 | let set_source_rgb cr ~r ~g ~b = set_source_rgb cr r g b 29 | let set_source_alpha cr ~r ~g ~b a = set_source_rgba cr r g b a 30 | let set_source_rgba cr ~r ~g ~b ~a = set_source_rgba cr r g b a 31 | end 32 | 33 | module R = Mtv_render.Make(Canvas) 34 | 35 | let export_as_svg v fname = 36 | let surface = Cairo.SVG.create 37 | fname 38 | ~w:(Mtv_view.view_width v) 39 | ~h:(Mtv_view.view_height v) in 40 | let cr = Cairo.create surface in 41 | Cairo.set_font_size cr 12.; 42 | Cairo.select_font_face cr "Sans"; 43 | Cairo.set_line_join cr Cairo.JOIN_BEVEL; 44 | 45 | (* Note: bounds are slightly smaller than the page because otherwise Cairo 46 | * optimises the clip region out (but Inkscape displays things beyond the 47 | * page boundaries). *) 48 | Cairo.rectangle cr 1.0 0.0 ~w:(Mtv_view.view_width v -. 2.0) ~h:(Mtv_view.view_height v); 49 | Cairo.clip cr; 50 | 51 | R.render v cr ~expose_area:( 52 | (0.0, 0.0), 53 | (Mtv_view.view_width v, Mtv_view.view_height v) 54 | ); 55 | Cairo.Surface.finish surface 56 | 57 | let ignore_widget : #GObj.widget -> unit = ignore 58 | 59 | let toggle_metrics ~area v = 60 | Mtv_view.set_show_metrics v (not (Mtv_view.show_metrics v)); 61 | GtkBase.Widget.queue_draw area#as_widget 62 | 63 | module Menu = struct 64 | type t = { 65 | menu : GMenu.menu; 66 | metrics_menu : GMenu.menu; 67 | mutable metrics_items : GObj.widget list; 68 | } 69 | 70 | let make ~accel_group ~parent ~show_search ~v = 71 | let menu = GMenu.menu () in 72 | menu#set_accel_group accel_group; 73 | let packing = menu#add in 74 | let metrics_items = GMenu.menu_item ~packing ~label:"Metrics" () in 75 | let metrics_menu = 76 | let metrics_menu = GMenu.menu () in 77 | metrics_items#set_submenu metrics_menu; 78 | let packing = metrics_menu#add in 79 | let show_metrics = GMenu.check_menu_item ~packing ~label:"Show metrics" ~active:(Mtv_view.show_metrics v) () in 80 | show_metrics#add_accelerator ~group:accel_group GdkKeysyms._space ~flags:[`VISIBLE]; 81 | show_metrics#connect#activate ==> (fun () -> toggle_metrics ~area:parent v); 82 | GMenu.separator_item ~packing () |> ignore_widget; 83 | metrics_menu in 84 | 85 | let find = GMenu.menu_item ~packing ~label:"Find ..." () in 86 | find#add_accelerator ~group:accel_group GdkKeysyms._slash ~flags:[`VISIBLE]; 87 | find#connect#activate ==> show_search; 88 | let export_svg = GMenu.menu_item ~packing ~label:"Export as SVG..." () in 89 | export_svg#connect#activate ==> (fun () -> 90 | let save_box = GWindow.file_chooser_dialog 91 | ~action:`SAVE 92 | ~parent 93 | ~title:"Export as SVG" 94 | ~position:`MOUSE 95 | () in 96 | save_box#add_button_stock `CANCEL `CANCEL; 97 | save_box#add_select_button "Export" `ACCEPT; 98 | save_box#connect#response ==> (function 99 | | `ACCEPT -> 100 | begin match save_box#filename with 101 | | Some fname -> export_as_svg v fname; save_box#destroy () 102 | | None -> () end; 103 | | _ -> save_box#destroy () 104 | ); 105 | save_box#show () 106 | ); 107 | { menu; metrics_menu; metrics_items = [] } 108 | 109 | let show t ~redraw v bev = 110 | let packing = t.metrics_menu#add in 111 | t.metrics_items |> List.iter (fun i -> i#destroy ()); 112 | t.metrics_items <- []; 113 | let metrics = Mtv_view.vat v |> Mtv_thread.counters in 114 | metrics |> List.iter (fun metric -> 115 | let open Mtv_counter in 116 | let item = GMenu.check_menu_item ~packing ~label:metric.Mtv_counter.name ~active:metric.shown () in 117 | item#connect#activate ==> (fun () -> 118 | metric.shown <- not metric.shown; 119 | redraw () 120 | ); 121 | t.metrics_items <- (item :> GObj.widget) :: t.metrics_items; 122 | ); 123 | t.menu#popup ~button:(GdkEvent.Button.button bev) ~time:(GdkEvent.Button.time bev) 124 | end 125 | 126 | let make ~name vat = 127 | let top_thread = Mtv_thread.top_thread vat in 128 | let title = Printf.sprintf "%s (%s) - Mirage Trace Viewer" 129 | (Filename.basename name) 130 | (Filename.dirname name) in 131 | let win = GWindow.window ~title () in 132 | win#set_default_size 133 | ~width:(Gdk.Screen.width () / 2) 134 | ~height:(Gdk.Screen.height () / 2); 135 | let hadjustment = GData.adjustment () in 136 | let vadjustment = GData.adjustment () in 137 | let table = GPack.table ~rows:3 ~columns:2 ~homogeneous:false ~packing:win#add () in 138 | let area = GMisc.drawing_area ~packing:(table#attach ~left:0 ~top:0 ~expand:`BOTH ~fill:`BOTH) () in 139 | let accel_group = GtkData.AccelGroup.create () in 140 | let redraw () = 141 | GtkBase.Widget.queue_draw area#as_widget in 142 | 143 | let _hscroll = GRange.scrollbar `HORIZONTAL ~adjustment:hadjustment ~packing:(table#attach ~left:0 ~top:1 ~expand:`X ~fill:`BOTH) () in 144 | let _vscroll = GRange.scrollbar `VERTICAL ~adjustment:vadjustment ~packing:(table#attach ~left:1 ~top:0 ~expand:`Y ~fill:`BOTH) () in 145 | 146 | let minibuffer = GPack.hbox 147 | ~packing:(table#attach ~left:0 ~top:2 ~right:2 ~fill:`BOTH) 148 | ~border_width:4 149 | ~show:false 150 | () in 151 | GMisc.label ~packing:minibuffer#pack ~text:"Search: " () |> ignore_widget; 152 | let search_entry = GEdit.entry ~packing:(minibuffer#pack ~expand:true) () in 153 | 154 | win#event#connect#delete ==> (fun _ev -> win#destroy (); true); 155 | win#add_accel_group accel_group; 156 | win#show (); 157 | 158 | let alloc = area#misc#allocation in 159 | let v = Mtv_view.make ~vat 160 | ~view_width:(float_of_int alloc.Gtk.width) 161 | ~view_height:(float_of_int alloc.Gtk.height) in 162 | 163 | search_entry#connect#notify_text ==> (fun text -> 164 | if text = "" then Mtv_view.(set_highlights v ThreadSet.empty) 165 | else ( 166 | let re = Str.regexp_string_case_fold text in 167 | let query label = 168 | try Str.search_forward re label 0 |> ignore; true 169 | with Not_found -> false in 170 | Mtv_view.highlight_matches v query 171 | ); 172 | redraw () 173 | ); 174 | 175 | let show_search () = 176 | search_entry#set_text ""; 177 | minibuffer#misc#show (); 178 | search_entry#misc#grab_focus () in 179 | 180 | win#event#connect#key_press ==> (fun kev -> 181 | let keyval = GdkEvent.Key.keyval kev in 182 | if keyval = GdkKeysyms._Escape || keyval = GdkKeysyms._Return then 183 | (minibuffer#misc#hide (); true) 184 | else if minibuffer#misc#visible then false 185 | else match GdkEvent.Key.string kev with 186 | | "/" -> (* Otherwise, it inserts a "/" into the box... *) 187 | show_search (); 188 | true 189 | | _ -> false 190 | ); 191 | 192 | let menu = Menu.make ~accel_group ~parent:win ~show_search ~v in 193 | 194 | let set_scollbars () = 195 | let (xlo, xhi, xsize, xvalue), (ylo, yhi, ysize, yvalue) = Mtv_view.scroll_bounds v in 196 | hadjustment#set_bounds ~lower:xlo ~upper:xhi ~page_size:xsize (); 197 | vadjustment#set_bounds ~lower:ylo ~upper:yhi ~page_size:ysize (); 198 | hadjustment#set_value xvalue; 199 | vadjustment#set_value yvalue; 200 | in 201 | 202 | area#misc#connect#size_allocate ==> (fun alloc -> 203 | Mtv_view.set_size v (float_of_int alloc.Gtk.width) (float_of_int alloc.Gtk.height); 204 | set_scollbars () 205 | ); 206 | 207 | area#event#connect#expose ==> (fun ev -> 208 | let cr = Cairo_gtk.create area#misc#window in 209 | Cairo.set_font_size cr 16.; 210 | Cairo.select_font_face cr "Sans"; 211 | Cairo.set_line_join cr Cairo.JOIN_BEVEL; 212 | 213 | let expose_area = GdkEvent.Expose.area ev in 214 | let x, y = Gdk.Rectangle.(x expose_area, y expose_area) in 215 | let width, height = Gdk.Rectangle.(width expose_area, height expose_area) in 216 | R.render v cr ~expose_area:( 217 | (float_of_int x, float_of_int y), 218 | (float_of_int (x + width), float_of_int (y + height)) 219 | ); 220 | true 221 | ); 222 | 223 | let set_start_time t = 224 | Mtv_view.set_start_time v t 225 | |> hadjustment#set_value in 226 | 227 | let set_view_y y = 228 | Mtv_view.set_view_y v y 229 | |> vadjustment#set_value in 230 | 231 | area#misc#set_app_paintable true; 232 | area#event#add [`SCROLL; `BUTTON1_MOTION; `BUTTON_PRESS]; 233 | area#event#connect#scroll ==> (fun ev -> 234 | let x = GdkEvent.Scroll.x ev in 235 | let t_at_pointer = Mtv_view.time_of_x v x in 236 | let redraw_zoomed () = 237 | let t_new_at_pointer = Mtv_view.time_of_x v x in 238 | set_start_time (Mtv_view.view_start_time v -. (t_new_at_pointer -. t_at_pointer)); 239 | redraw () in 240 | begin match GdkEvent.Scroll.direction ev with 241 | | `UP -> Mtv_view.zoom v 1.2; set_scollbars (); redraw_zoomed () 242 | | `DOWN -> Mtv_view.zoom v (1. /. 1.2); redraw_zoomed (); set_scollbars () 243 | | _ -> () end; 244 | true 245 | ); 246 | 247 | let drag_start = ref None in 248 | area#event#connect#button_press ==> (fun ev -> 249 | match GdkEvent.get_type ev, GdkEvent.Button.button ev with 250 | | `BUTTON_PRESS, 1 -> 251 | let start_t = Mtv_view.time_of_x v (GdkEvent.Button.x ev) in 252 | let start_y = Mtv_view.y_of_view_y v (GdkEvent.Button.y ev) in 253 | drag_start := Some (start_t, start_y); 254 | true; 255 | | `TWO_BUTTON_PRESS, 1 -> 256 | begin match Mtv_view.thread_at v ~x:(GdkEvent.Button.x ev) ~y:(GdkEvent.Button.y ev) with 257 | | None -> false 258 | | Some thread -> 259 | Mtv_view.highlight_related v thread; 260 | GtkBase.Widget.queue_draw area#as_widget; 261 | Mtv_thread.dump thread; true end 262 | | `BUTTON_PRESS, 3 -> Menu.show menu ~redraw v ev; true 263 | | _ -> false 264 | ); 265 | 266 | area#event#connect#motion_notify ==> (fun ev -> 267 | match !drag_start with 268 | | None -> false 269 | | Some (start_time, start_y) -> 270 | let x = GdkEvent.Motion.x ev in 271 | let y = GdkEvent.Motion.y ev in 272 | let time_at_pointer = Mtv_view.time_of_x v x in 273 | let y_at_pointer = Mtv_view.y_of_view_y v y in 274 | if time_at_pointer <> start_time || start_y <> y_at_pointer then ( 275 | set_start_time (start_time -. Mtv_view.timespan_of_width v x); 276 | Mtv_view.set_view_y_so v start_y y 277 | |> vadjustment#set_value; 278 | GtkBase.Widget.queue_draw area#as_widget 279 | ); 280 | true 281 | ); 282 | 283 | hadjustment#connect#value_changed ==> (fun () -> 284 | set_start_time (Mtv_thread.start_time top_thread +. (Mtv_view.timespan_of_width v hadjustment#value)); 285 | GtkBase.Widget.queue_draw area#as_widget 286 | ); 287 | 288 | vadjustment#connect#value_changed ==> (fun () -> 289 | set_view_y vadjustment#value; 290 | GtkBase.Widget.queue_draw area#as_widget 291 | ); 292 | 293 | win 294 | -------------------------------------------------------------------------------- /lib/mtv_view.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2014, Thomas Leonard *) 2 | 3 | (** Some values used for calculating vertical positions. 4 | * Saved so we don't have to regenerate them for every thread. *) 5 | type v_projection = { 6 | focal_y : float; (* The y position in thread coordinates which is most expanded. *) 7 | v_scale : float; (* To make the distance between threads sensible. *) 8 | unstretched_top_proj : float; (* Where the top would be if we didn't stretch the result. *) 9 | unstretched_range : float; (* Distance beween top and bottom. *) 10 | } 11 | 12 | module ThreadSet = Set.Make(Mtv_thread) 13 | 14 | type t = { 15 | vat : Mtv_thread.vat; 16 | mutable scale : float; 17 | mutable view_width : float; 18 | mutable view_height : float; 19 | mutable view_start_time : float; 20 | mutable v_projection : v_projection; 21 | height : float; 22 | mutable grid_step : float; 23 | layout : Mtv_layout.t; 24 | arrow_events_by_first : (Mtv_thread.t * Mtv_thread.time * Mtv_thread.interaction * Mtv_thread.t * Mtv_thread.time) array; 25 | arrow_events_by_second : (Mtv_thread.t * Mtv_thread.time * Mtv_thread.interaction * Mtv_thread.t * Mtv_thread.time) array; 26 | mutable highlights : ThreadSet.t; 27 | mutable show_metrics : bool; 28 | } 29 | 30 | let clone t = { t with 31 | v_projection = { t.v_projection with v_scale = t.v_projection.v_scale } 32 | } 33 | 34 | let h_margin = 20. 35 | let v_margin = 30. 36 | 37 | let calc_grid_step scale = 38 | let l = 2.5 -. (log scale /. log 10.) |> floor in 39 | 10. ** l 40 | 41 | let by_first_time (_, (t1:float), _, _, _) (_, (t2:float), _, _, _) = compare t1 t2 42 | let by_second_time (_, _, _, _, (t1:float)) (_, _, _, _, (t2:float)) = compare t1 t2 43 | 44 | let collect_events top = 45 | let events = ref [] in 46 | top |> Mtv_thread.iter (fun thread -> 47 | let interactions = Mtv_thread.interactions thread 48 | |> List.map (fun (time, op, other) -> 49 | match op with 50 | | Mtv_thread.Read | Mtv_thread.Try_read -> 51 | let end_time = min time (Mtv_thread.end_time other) in 52 | (thread, time, op, other, end_time) 53 | | Mtv_thread.Signal -> 54 | (thread, time, op, other, time) 55 | | Mtv_thread.Resolve -> 56 | let start_time = min time (Mtv_thread.end_time thread) in 57 | (thread, start_time, op, other, time) 58 | ) in 59 | events := interactions @ !events 60 | ); 61 | let by_first = Array.of_list !events in 62 | let by_second = Array.copy by_first in 63 | Array.sort by_first_time by_first; 64 | Array.sort by_second_time by_second; 65 | (by_first, by_second) 66 | 67 | let v_projection_for_focus ~height ~view_height focal_y = 68 | (* Hack: because we scale so that y=0 is always at the top and y=h is always 69 | * at the bottom, we need to adjust the scale factor to keep the lengths around 70 | * focal_y constant. I couldn't figure out the correct formula for this. *) 71 | let v_scale = 72 | if focal_y < height /. 2. then ( 73 | let d = focal_y /. 500. in 74 | let top_unscaled = (1. -. exp d) /. (1. +. exp d) in 75 | view_height *. (0.5 +. (top_unscaled *. 0.25)) 76 | ) else ( 77 | let d = (focal_y -. height) /. 500. in 78 | let bottom_unscaled = (1. -. exp d) /. (1. +. exp d) in 79 | view_height *. (0.5 -. (bottom_unscaled *. 0.25)) 80 | ) in 81 | 82 | let hyp_project d = 83 | let d = (focal_y -. d) /. v_scale in 84 | (1. -. exp d) /. (1. +. exp d) in 85 | 86 | let top_proj = hyp_project 0.0 in 87 | let bottom_proj = hyp_project height in { 88 | focal_y; 89 | v_scale; 90 | unstretched_top_proj = top_proj; 91 | unstretched_range = bottom_proj -. top_proj; 92 | } 93 | 94 | let make ~view_width ~view_height ~vat = 95 | let top_thread = Mtv_thread.top_thread vat in 96 | let time_range = Mtv_thread.end_time top_thread -. Mtv_thread.start_time top_thread in 97 | let scale = (view_width -. h_margin *. 2.) /. time_range in 98 | let (arrow_events_by_first, arrow_events_by_second) = collect_events top_thread in 99 | let layout, height = Mtv_layout.arrange top_thread in { 100 | vat; 101 | scale; 102 | view_width; 103 | view_height; 104 | view_start_time = Mtv_thread.start_time top_thread -. (h_margin /. scale); 105 | v_projection = v_projection_for_focus ~height ~view_height 0.0; 106 | height; 107 | grid_step = calc_grid_step scale; 108 | layout; 109 | arrow_events_by_first; 110 | arrow_events_by_second; 111 | highlights = ThreadSet.empty; 112 | show_metrics = true; 113 | } 114 | 115 | let x_of_time v time = (time -. v.view_start_time) *. v.scale 116 | let time_of_x v x = (x /. v.scale) +. v.view_start_time 117 | 118 | let x_of_start v t = x_of_time v (Mtv_thread.start_time t) 119 | let x_of_end v t = x_of_time v (Mtv_thread.end_time t) 120 | 121 | let clip_x_of_time v t = 122 | x_of_time v t 123 | |> min 1_000_000. 124 | |> max (-1_000_000.) 125 | 126 | let view_y_of_y v y = 127 | let p = v.v_projection in 128 | let focal_y = p.focal_y in 129 | 130 | let hyp_project d = 131 | let d = (focal_y -. d) /. p.v_scale in 132 | (1. -. exp d) /. (1. +. exp d) in 133 | 134 | let this_proj = hyp_project y in 135 | let frac = (this_proj -. p.unstretched_top_proj) /. p.unstretched_range in 136 | v_margin +. (v.view_height -. 2. *. v_margin) *. frac 137 | 138 | let y_of_view_y v view_y = 139 | if view_y <= v_margin then 0.0 140 | else if view_y >= v.view_height -. v_margin then v.height 141 | else ( 142 | let p = v.v_projection in 143 | let focal_y = p.focal_y in 144 | let frac = (view_y -. v_margin) /. (v.view_height -. 2. *. v_margin) in 145 | let this_proj = frac *. p.unstretched_range +. p.unstretched_top_proj in 146 | let d = -. log ((1. +. this_proj) /. (1. -. this_proj)) in 147 | ~-. (d *. p.v_scale -. focal_y) 148 | ) 149 | 150 | let y_of_thread v t = view_y_of_y v (Mtv_thread.y t) 151 | 152 | let width_of_timespan v t = t *. v.scale 153 | let timespan_of_width v w = w /. v.scale 154 | 155 | let set_scale v scale = 156 | let top_thread = Mtv_thread.top_thread v.vat in 157 | let time_range = Mtv_thread.end_time top_thread -. Mtv_thread.start_time top_thread in 158 | let min_scale = (v.view_width -. h_margin *. 2.) /. time_range in 159 | v.scale <- max min_scale scale; 160 | v.grid_step <- calc_grid_step scale 161 | 162 | let zoom v factor = 163 | set_scale v (v.scale *. factor) 164 | 165 | let scroll_bounds v = 166 | let top_thread = Mtv_thread.top_thread v.vat in 167 | let width = width_of_timespan v (Mtv_thread.end_time top_thread -. Mtv_thread.start_time top_thread) in 168 | ( 169 | (-. h_margin, width +. h_margin, v.view_width, (v.view_start_time -. Mtv_thread.start_time top_thread) *. v.scale), 170 | (-. v_margin, v.height +. v_margin +. v.view_height, v.view_height, v.v_projection.focal_y) 171 | ) 172 | 173 | let visible_threads v visible_time_range = 174 | Mtv_layout.IT.overlapping_interval v.layout visible_time_range 175 | 176 | let set_start_time v t = 177 | let top_thread = Mtv_thread.top_thread v.vat in 178 | let trace_start_time = Mtv_thread.start_time top_thread in 179 | let trace_end_time = Mtv_thread.end_time top_thread in 180 | v.view_start_time <- t 181 | |> min (trace_end_time -. ((v.view_width -. h_margin) /. v.scale)) 182 | |> max (trace_start_time -. (h_margin /. v.scale)); 183 | (v.view_start_time -. trace_start_time) *. v.scale 184 | 185 | let set_size v width height = 186 | let scale_factor = width /. v.view_width in 187 | v.view_width <- width; 188 | v.view_height <- height; 189 | v.v_projection <- v_projection_for_focus ~height:v.height ~view_height:v.view_height v.v_projection.focal_y; 190 | set_scale v (v.scale *. scale_factor); 191 | set_start_time v v.view_start_time |> ignore 192 | 193 | let set_view_y v y = 194 | let focal_y = y 195 | |> min (v.height +. v_margin) 196 | |> max (-. v_margin) in 197 | v.v_projection <- v_projection_for_focus ~height:v.height ~view_height:v.view_height focal_y; 198 | focal_y 199 | 200 | let set_view_y_so v y view_y = 201 | (* Binary search because I didn't pay attention in maths class. *) 202 | let rec aux lo high i = 203 | if i = 0 then () 204 | else ( 205 | let f = (lo +. high) /. 2. in 206 | v.v_projection <- v_projection_for_focus ~height:v.height ~view_height:v.view_height f; 207 | let this_view_y = view_y_of_y v y in 208 | let d = this_view_y -. view_y in 209 | if d < 1. then aux lo f (i - 1) 210 | else if d > -1.0 then aux f high (i - 1) 211 | else () 212 | ) in 213 | if view_y > v_margin && view_y < v.view_height -. v_margin then ( 214 | aux 0.0 v.height 20 215 | ); 216 | v.v_projection.focal_y 217 | 218 | let iter_interactions v t1 t2 f = 219 | Mtv_sorted_array.iter_range v.arrow_events_by_first 220 | (fun (_, t, _, _, _) -> t >= t1) 221 | (fun (_, t, _, _, _) -> t < t2) 222 | f; 223 | Mtv_sorted_array.iter_range v.arrow_events_by_second 224 | (fun (_, _, _, _, t) -> t >= t1) 225 | (fun (_, _, _, _, t) -> t < t2) 226 | (fun i -> 227 | let (_, st, _, _, _) = i in 228 | if st < t1 || st >= t2 then f i 229 | (* else we already processed this one above *) 230 | ) 231 | 232 | let dist_from_focus v t= Mtv_thread.y t -. v.v_projection.focal_y 233 | 234 | let vat t = t.vat 235 | let view_start_time t = t.view_start_time 236 | let view_width t = t.view_width 237 | let view_height t = t.view_height 238 | let grid_step t = t.grid_step 239 | 240 | let thread_at v ~x ~y = 241 | let range = 16.0 in (* How far you can be from the thread *) 242 | let best = ref None in 243 | visible_threads v (time_of_x v (x -. range), time_of_x v (x +. range)) 244 | |> Mtv_layout.IT.IntervalSet.iter (fun i -> 245 | let thread = i.Interval_tree.Interval.value in 246 | let dist_y = abs_float (y_of_thread v thread -. y) in 247 | let start_x = x_of_time v (Mtv_thread.start_time thread) in 248 | let end_x = x_of_time v (Mtv_thread.end_time thread) in 249 | let dist_x = 250 | if x < start_x then start_x -. x 251 | else if x > end_x then x -. end_x 252 | else 0.0 in 253 | let dist = max dist_x dist_y in 254 | if dist <= range then ( 255 | match !best with 256 | | Some (best_dist, _) when best_dist <= dist -> () 257 | | _ -> best := Some (dist, thread) 258 | ) 259 | ); 260 | match !best with 261 | | None -> None 262 | | Some (_, thread) -> Some thread 263 | 264 | let highlights t = t.highlights 265 | let set_highlights t v = t.highlights <- v 266 | 267 | let highlight_related v thread = 268 | let highlights = ref (ThreadSet.singleton thread) in 269 | let rec walk_successors th = 270 | match Mtv_thread.becomes th with 271 | | Some th -> 272 | highlights := !highlights |> ThreadSet.add th; 273 | walk_successors th 274 | | None -> () in 275 | walk_successors thread; 276 | let pred = Hashtbl.create 1000 in 277 | Mtv_thread.top_thread v.vat |> Mtv_thread.iter (fun th -> 278 | match Mtv_thread.becomes th with 279 | | None -> () 280 | | Some s -> Hashtbl.add pred s th 281 | ); 282 | let rec walk_preds th = 283 | let preds = Hashtbl.find_all pred th in 284 | preds |> List.iter (fun th -> 285 | highlights := !highlights |> ThreadSet.add th; 286 | walk_preds th 287 | ) in 288 | walk_preds thread; 289 | set_highlights v !highlights 290 | 291 | let highlight_matches v query = 292 | let highlights = ref ThreadSet.empty in 293 | Mtv_thread.top_thread v.vat |> Mtv_thread.iter (fun th -> 294 | if Mtv_thread.labels th |> List.exists (fun (_time, label) -> query label) then 295 | highlights := !highlights |> ThreadSet.add th; 296 | ); 297 | set_highlights v !highlights 298 | 299 | let show_metrics v = v.show_metrics 300 | let set_show_metrics v show = v.show_metrics <- show 301 | -------------------------------------------------------------------------------- /lib/mtv_thread.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2014, Thomas Leonard *) 2 | 3 | type interaction = Resolve | Read | Try_read | Signal 4 | 5 | let string_of_interaction = function 6 | | Resolve -> "resolve" 7 | | Read -> "read" 8 | | Try_read -> "try_read" 9 | | Signal -> "signal" 10 | 11 | type time = float 12 | 13 | type t = { 14 | thread_type : string; 15 | tid : int; 16 | mutable show_creation : bool; 17 | mutable start_time : time; 18 | mutable resolved : bool; 19 | mutable end_time : time; 20 | mutable creates : t list; 21 | mutable becomes : t option; 22 | mutable labels : (time * string) list; 23 | mutable interactions : (time * interaction * t) list; 24 | mutable activations : (time * time) list; 25 | mutable failure : string option; 26 | mutable y : float; 27 | mutable first_checked : time; (* Prevent bind simplification if we need a try_read arrow first *) 28 | mutable last_signalled_or_checked : time; (* (used to calculate end_time) *) 29 | } 30 | 31 | type mutable_counter = { 32 | mutable mc_values : (time * int) list; 33 | } 34 | 35 | type vat = { 36 | top_thread : t; 37 | mutable gc : (time * time) list; 38 | mutable counters : Mtv_counter.t list; 39 | } 40 | 41 | (* For threads with no end. Call before we reverse the lists. *) 42 | let last_event_time t = 43 | let last = ref (max t.start_time t.last_signalled_or_checked) in 44 | begin match t.creates with 45 | | child :: _ -> last := max !last child.start_time 46 | | _ -> () end; 47 | begin match t.becomes with 48 | | Some child -> last := max !last child.start_time 49 | | None -> () end; 50 | begin match t.labels with 51 | | (time, _) :: _ -> last := max !last time 52 | | _ -> () end; 53 | begin match t.interactions with 54 | | (time, _, _) :: _ -> last := max !last time 55 | | _ -> () end; 56 | begin match t.activations with 57 | | (_, time) :: _ -> last := max !last time 58 | | _ -> () end; 59 | !last 60 | 61 | let scan_first_checked t = 62 | t.interactions |> List.iter (function 63 | | (time, Try_read, other) -> other.first_checked <- min other.first_checked time 64 | | _ -> () 65 | ) 66 | 67 | let make_thread ~tid ~start_time ~thread_type = { 68 | thread_type; 69 | tid; 70 | start_time; 71 | show_creation = true; 72 | end_time = infinity; 73 | creates = []; 74 | becomes = None; 75 | labels = []; 76 | interactions = []; 77 | activations = []; 78 | failure = None; 79 | resolved = false; 80 | y = -.infinity; 81 | first_checked = infinity; 82 | last_signalled_or_checked = -.infinity; 83 | } 84 | 85 | let rec iter fn thread = 86 | fn thread; 87 | thread.creates |> List.iter (iter fn) 88 | 89 | let counter_value c = 90 | match c.mc_values with 91 | | [] -> 0 92 | | (_, v) :: _ -> v 93 | 94 | (** Time of first interaction. 95 | * None if there isn't one, of if a label occurs first. *) 96 | let first_interaction t = 97 | let rec aux = function 98 | | [] -> None 99 | | [i] -> Some i 100 | | _::xs -> aux xs in 101 | let i = aux t.interactions in 102 | match t.labels, i with 103 | | ((l_time, _) :: _), Some (i_time, _, _) when l_time < i_time -> None 104 | | _ -> i 105 | 106 | (** If a bind-type thread's parent is still alive when it wakes up, 107 | * adjust its start time to its wake up time. This reduces visual clutter. *) 108 | let rec simplify_binds parent = 109 | let relocs = ref [] in 110 | parent.creates <- parent.creates |> List.filter (fun t -> 111 | simplify_binds t; 112 | begin match t.thread_type, parent.becomes with 113 | | _, Some became when became == t -> true 114 | | ("bind" | "try" | "map" | "ignore_result" | "on_failure" | "on_termination"), _ -> 115 | begin match first_interaction t with 116 | | Some (wake_time, Read, other) when wake_time < t.first_checked -> 117 | t.show_creation <- false; 118 | t.start_time <- wake_time; 119 | if other == parent then true 120 | else ( 121 | relocs := (t, other) :: !relocs; 122 | false 123 | ) 124 | | _ -> true end 125 | | _ -> true end; 126 | ); 127 | !relocs |> List.iter (fun (t, other) -> 128 | other.creates <- t :: other.creates; 129 | ) 130 | 131 | let rec ensure_resolved ~top_thread th = 132 | match th.becomes with 133 | | None when not th.resolved -> 134 | th.failure <- Some "should-resolve thread never resolved"; 135 | th.end_time <- top_thread.end_time 136 | | None -> () 137 | | Some th -> ensure_resolved ~top_thread th 138 | 139 | (* Sometimes it's useful to show several counters on the same scale. 140 | * Ideally, this information would come from the trace, but for now we just hard-code them. *) 141 | let scale_for = function 142 | | "tcp-ackd-segs" -> "tcp-to-ip" 143 | | counter -> 144 | (* Show e.g. buflen#1 and buflen#2 on the same scale *) 145 | try let i = String.rindex counter '#' in String.sub counter 0 i 146 | with Not_found -> counter 147 | 148 | let of_events ?(simplify=true) events = 149 | let trace_start_time = 150 | match events with 151 | | [] -> failwith "No events!" 152 | | hd :: _ -> Mtv_event.(hd.time) in 153 | let top_thread = make_thread ~start_time:0.0 ~tid:(-1) ~thread_type:"preexisting" in 154 | top_thread.end_time <- 0.0; 155 | 156 | let vat = {top_thread; gc = []; counters = []} in 157 | 158 | let scales = Hashtbl.create 20 in 159 | (* Get or update the scale for a new counter *) 160 | let get_scale_for ~min:low ~max:high counter_name = 161 | let open Mtv_counter in 162 | let low = min low 0.0 in (* For now, assume every scale should go down to zero at least. *) 163 | let high = max high (low +. 10.0) in 164 | let scale_name = scale_for counter_name in 165 | try 166 | let scale = Hashtbl.find scales scale_name in 167 | scale.min <- min scale.min low; 168 | scale.max <- max scale.max high; 169 | scale 170 | with Not_found -> 171 | let s = { min = low; max = high } in 172 | Hashtbl.add scales scale_name s; 173 | s in 174 | 175 | let counters = Hashtbl.create 20 in 176 | let get_counter name = 177 | try Hashtbl.find counters name 178 | with Not_found -> 179 | let c = { mc_values = [] } in 180 | Hashtbl.add counters name c; 181 | c in 182 | 183 | let rec replacement thread = 184 | match thread.becomes with 185 | | None -> thread 186 | | Some t2 -> replacement t2 in 187 | 188 | let threads = Hashtbl.create 100 in 189 | Hashtbl.add threads (-1) top_thread; 190 | let get_thread tid = 191 | try Hashtbl.find threads tid |> replacement 192 | with Not_found -> 193 | let t = make_thread ~tid ~start_time:0.0 ~thread_type:"preexisting" in 194 | Hashtbl.add threads tid t; 195 | top_thread.creates <- t :: top_thread.creates; 196 | t in 197 | 198 | let running_thread = ref None in 199 | let switch time next = 200 | match !running_thread, next with 201 | | Some (_, prev), Some next when prev.tid = next.tid -> () 202 | | prev, next -> 203 | begin match prev with 204 | | Some (start_time, prev) -> 205 | let end_time = min time (prev.end_time) in 206 | prev.activations <- (start_time, end_time) :: prev.activations 207 | | None -> () end; 208 | match next with 209 | | Some next -> running_thread := Some (time, next) 210 | | None -> running_thread := None in 211 | 212 | let should_resolve = ref [] in 213 | 214 | events |> List.iter (fun ev -> 215 | let open Mtv_event in 216 | let time = ev.time -. trace_start_time in 217 | if time > top_thread.end_time then top_thread.end_time <- time; 218 | 219 | match ev.op with 220 | | Creates (a, b, thread_type) -> 221 | let a = get_thread a in 222 | assert (not (Hashtbl.mem threads b)); 223 | let child = make_thread ~start_time:time ~tid:b ~thread_type:(String.lowercase_ascii thread_type) in 224 | Hashtbl.add threads b child; 225 | a.creates <- child :: a.creates 226 | | Resolves (a, b, failure) -> 227 | let a = get_thread a in 228 | let b = get_thread b in 229 | a.interactions <- (time, Resolve, b) :: a.interactions; 230 | b.failure <- failure; 231 | b.end_time <- time; 232 | b.resolved <- true 233 | | Becomes (a, b) -> 234 | let a = get_thread a in 235 | a.end_time <- time; 236 | a.resolved <- true; 237 | assert (a.becomes = None); 238 | let b = Some (get_thread b) in 239 | a.becomes <- b; 240 | begin match !running_thread with 241 | | Some (_t, current_thread) when current_thread.tid = a.tid -> switch time b 242 | | _ -> () end 243 | | Reads (_, -1, _) -> () 244 | | Reads (a, b, Read_resolved) -> 245 | let a = get_thread a in 246 | let b = get_thread b in 247 | switch time (Some a); 248 | let interactions = 249 | match a.interactions with 250 | | (_, Try_read, b2) :: rest when b == b2 -> rest (* Simplify *) 251 | | all -> all in 252 | a.interactions <- (time, Read, b) :: interactions; 253 | | Reads (a, b, Read_resolved_later) -> 254 | let a = get_thread a in 255 | let b = get_thread b in 256 | let interactions = 257 | match a.interactions with 258 | | (_, Try_read, b2) :: rest when b == b2 -> rest (* Simplify *) 259 | | all -> all in 260 | a.interactions <- (time, Read, b) :: interactions; 261 | | Reads (a, b, Read_sleeping) -> 262 | let a = get_thread a in 263 | let b = get_thread b in 264 | a.interactions <- (time, Try_read, b) :: a.interactions; 265 | b.last_signalled_or_checked <- time; 266 | | Signals_and_switches (a, b) -> 267 | let a = get_thread a in 268 | let b = get_thread b in 269 | switch time (Some b); 270 | a.interactions <- (time, Signal, b) :: a.interactions; 271 | b.last_signalled_or_checked <- time; 272 | | Signals (a, b) -> 273 | let a = get_thread a in 274 | let b = get_thread b in 275 | a.interactions <- (time, Signal, b) :: a.interactions; 276 | b.last_signalled_or_checked <- time; 277 | | Label (a, "__should_resolve") -> 278 | let a = get_thread a in 279 | should_resolve := a :: !should_resolve; 280 | | Label (a, msg) -> 281 | if a <> -1 then ( 282 | let a = get_thread a in 283 | a.labels <- (time, msg) :: a.labels 284 | ) 285 | | Switch a -> 286 | switch time (Some (get_thread a)) 287 | | Gc duration -> 288 | vat.gc <- (time -. duration, time) :: vat.gc 289 | | Increases (a, counter, amount) -> 290 | let c = get_counter counter in 291 | let new_value = counter_value c + amount in 292 | c.mc_values <- (time, new_value) :: c.mc_values; 293 | let a = get_thread a in 294 | a.labels <- (time, Printf.sprintf "%s%+d" counter amount) :: a.labels 295 | | Counter_value (a, counter, new_value) -> 296 | let c = get_counter counter in 297 | let amount = new_value - counter_value c in 298 | c.mc_values <- (time, new_value) :: c.mc_values; 299 | let a = get_thread a in 300 | a.labels <- (time, Printf.sprintf "%s%+d" counter amount) :: a.labels 301 | ); 302 | switch top_thread.end_time None; 303 | (* Check that every should-resolve thread did eventually resolve. *) 304 | !should_resolve |> List.iter (ensure_resolved ~top_thread); 305 | (* Add a label for the final failure, if any. 306 | * Set the end-time for unresolved threads. *) 307 | top_thread |> iter (fun t -> 308 | let labels = 309 | match t.failure with 310 | | None -> t.labels 311 | | Some failure -> (t.end_time, failure) :: t.labels in 312 | if t.end_time = infinity then ( 313 | (* It probably got GC'd, but we don't see that. Make it disappear soon after its last event. *) 314 | t.end_time <- last_event_time t +. 0.000_001; 315 | ); 316 | t.labels <- List.rev labels; 317 | ); 318 | (* Set the [first_checked] fields. *) 319 | iter scan_first_checked top_thread; 320 | if simplify then simplify_binds top_thread; 321 | top_thread |> iter (fun t -> 322 | if t.labels = [] then t.labels <- [t.start_time, string_of_int t.tid] 323 | ); 324 | counters |> Hashtbl.iter (fun name mc -> 325 | let values = List.rev mc.mc_values |> List.map (fun (t, v) -> (t, float_of_int v)) |> Array.of_list in 326 | let low = ref 0. in 327 | let high = ref 0. in 328 | values |> Array.iter (fun (_, v) -> 329 | low := min !low v; 330 | high := max !high v; 331 | ); 332 | let scale = get_scale_for name ~min:!low ~max:!high in 333 | let counter = { Mtv_counter. 334 | name; 335 | values; 336 | scale; 337 | shown = true; 338 | } in 339 | vat.counters <- counter :: vat.counters 340 | ); 341 | vat.counters <- vat.counters |> List.sort Mtv_counter.(fun a b -> String.compare a.name b.name); 342 | (* Create pre-existing threads in thread order, not the order we first saw them. *) 343 | let by_thread_id a b = compare a.tid b.tid in 344 | top_thread.creates <- List.sort by_thread_id top_thread.creates; 345 | vat 346 | 347 | let top_thread v = v.top_thread 348 | let gc_periods v = v.gc 349 | 350 | let thread_type t = t.thread_type 351 | let start_time t = t.start_time 352 | let end_time t = t.end_time 353 | let creates t = t.creates 354 | let becomes t = t.becomes 355 | let labels t = t.labels 356 | let interactions t = t.interactions 357 | let activations t = t.activations 358 | let failure t = t.failure 359 | let y t = t.y 360 | let id t = t.tid 361 | let resolved t = t.resolved 362 | let show_creation t = t.show_creation 363 | 364 | let set_y t y = t.y <- y 365 | 366 | (** Sorts by y first, then by thread ID *) 367 | let compare a b = 368 | match compare a.y b.y with 369 | | 0 -> compare a.tid b.tid 370 | | r -> r 371 | 372 | let counters vat = vat.counters 373 | 374 | let dump t = 375 | let { 376 | thread_type; tid; show_creation; start_time; resolved; end_time; 377 | creates; becomes; labels; interactions; activations; failure; 378 | y; first_checked = _; last_signalled_or_checked = _; 379 | } = t in 380 | Printf.printf "[Thread %d (%s):\ 381 | \n show_creation=%b resolved=%b\ 382 | \n time: %f -> %f\ 383 | \n creates:%s\ 384 | \n becomes: %s\ 385 | \n labels:%s\ 386 | \n interactions:%s\ 387 | \n activations:%s\ 388 | \n result: %s\ 389 | \n y: %f\n%!" 390 | tid thread_type 391 | show_creation resolved 392 | start_time end_time 393 | (creates |> List.rev |> List.map (fun thread -> Printf.sprintf "\n - %d" thread.tid) |> String.concat "") 394 | (match becomes with None -> "" | Some t -> string_of_int t.tid) 395 | (labels |> List.map (fun (time, msg) -> Printf.sprintf "\n - %f: %s" time msg) |> String.concat "") 396 | (interactions |> List.rev |> List.map (fun (time, i, other) -> Printf.sprintf "\n - %f: %s %d" time (string_of_interaction i) other.tid) |> String.concat "") 397 | (activations |> List.rev |> List.map (fun (t1, t2) -> Printf.sprintf "\n - %f -> %f" t1 t2) |> String.concat "") 398 | (match failure with None -> "OK" | Some msg -> "Failed: " ^ msg) 399 | y 400 | -------------------------------------------------------------------------------- /js/html_viewer.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2014, Thomas Leonard *) 2 | 3 | open Mirage_trace_viewer 4 | open Js_of_ocaml 5 | open Js_of_ocaml_lwt 6 | open Js_of_ocaml_tyxml 7 | 8 | let auto_focus input = 9 | Lwt_js_events.async (fun () -> 10 | let elem = Tyxml_js.To_dom.of_input input in 11 | elem##select; 12 | Lwt.return () 13 | ) 14 | 15 | let focus elem = 16 | elem##focus 17 | 18 | module Canvas = struct 19 | type context = Dom_html.canvasRenderingContext2D Js.t 20 | 21 | let font_size = 12.0 22 | 23 | type text_extents = { 24 | x_bearing : float; 25 | y_bearing : float; 26 | width : float; 27 | height : float; 28 | x_advance : float; 29 | y_advance : float; 30 | } 31 | 32 | let set_line_width context width = context##.lineWidth := width 33 | 34 | let set_source_rgba (context:context) ~r ~g ~b ~a = 35 | let c = Printf.sprintf "#%02x%02x%02x" 36 | (r *. 255. |> truncate) 37 | (g *. 255. |> truncate) 38 | (b *. 255. |> truncate) |> Js.string in 39 | context##.globalAlpha := a; 40 | context##.fillStyle := c; 41 | context##.strokeStyle := c 42 | 43 | let set_source_alpha (context:context) ~r:_ ~g:_ ~b:_ a = 44 | context##.globalAlpha := a 45 | 46 | let set_source_rgb (context:context) ~r ~g ~b = set_source_rgba context ~r ~g ~b ~a:1.0 47 | 48 | let move_to context ~x ~y = context##moveTo x y 49 | let line_to context ~x ~y = context##lineTo x y 50 | let rectangle context ~x ~y ~w ~h = context##rect x y w h 51 | 52 | let stroke_preserve (context:context) = context##stroke 53 | 54 | let stroke (context:context) = 55 | context##stroke; 56 | context##beginPath 57 | 58 | let fill (context:context) = 59 | context##fill; 60 | context##beginPath 61 | 62 | let text_extents (context:context) msg = 63 | let width = (context##measureText (Js.string msg))##.width in { 64 | x_bearing = 0.0; 65 | y_bearing = -.font_size; 66 | width; 67 | height = font_size; 68 | x_advance = width; 69 | y_advance = 0.0; 70 | } 71 | 72 | let paint_text (context:context) ?clip_area ~x ~y msg = 73 | match clip_area with 74 | | None -> context##fillText (Js.string msg) x y 75 | | Some (w, h) -> 76 | context##save; 77 | context##rect x (y -. font_size) w (h +. font_size); 78 | context##clip; 79 | context##fillText (Js.string msg) x y; 80 | context##restore; 81 | context##beginPath 82 | 83 | let paint ?alpha (context:context) = 84 | let c = context##.canvas in 85 | assert (alpha = None); 86 | context##fillRect 0. 0. (float_of_int c##.width) (float_of_int c##.height) 87 | end 88 | 89 | module R = Mtv_render.Make(Canvas) 90 | 91 | type touch = 92 | | Touch_none 93 | | Touch_drag of (Mtv_thread.time * float) 94 | | Touch_zoom of (Mtv_thread.time * Mtv_thread.time) 95 | 96 | let resize_callbacks = ref [] 97 | let () = 98 | let cb () = !resize_callbacks |> List.iter (fun f -> f ()) in 99 | Js.Unsafe.global##.resizeCanvasElements := Js.wrap_callback cb 100 | 101 | let control_height = 16. 102 | 103 | (** Connect callbacks to render view [v] on canvas [c]. *) 104 | let attach ?(grab_focus=false) (c:Dom_html.canvasElement Js.t) v = 105 | let modal = 106 | let div = Dom_html.createDiv Dom_html.document in 107 | Js.Opt.iter (c##.parentNode) (fun parent -> 108 | parent##insertBefore (div :> Dom.node Js.t) (Js.Opt.return (c :> Dom.node Js.t)) |> ignore 109 | ); 110 | div in 111 | let rel_event_coords ev = 112 | let (cx, cy) = Dom_html.elementClientPosition c in 113 | (float_of_int (ev##.clientX - cx), float_of_int (ev##.clientY - cy)) in 114 | 115 | (* Return the size of the scroll thumb, the width of the scroll well and the 116 | * thumb start position. If the thumb would be too small, limit it and adjust 117 | * the well size to make things fit. *) 118 | let hscroll_values () = 119 | let (xlo, xhi, xsize, xvalue), _y = Mtv_view.scroll_bounds v in 120 | let range = xhi -. xlo in 121 | let well_width = Mtv_view.view_width v -. 96. in 122 | let xsize = (xsize /. range) *. well_width in 123 | let xsize, well_width = 124 | if xsize < 16. then (16., well_width -. (16. -. xsize)) 125 | else (xsize, well_width) in 126 | let xstart = ((xvalue -. xlo) /. range) *. well_width +. 96. in 127 | (xsize, well_width, xstart) in 128 | 129 | let draw_controls ctx = 130 | let top = Mtv_view.view_height v in 131 | ctx##.fillStyle := Js.string "#888"; 132 | ctx##rect 0.0 top (Mtv_view.view_width v) control_height; 133 | ctx##fill; 134 | ctx##beginPath; 135 | (* Zoom *) 136 | ctx##.strokeStyle := Js.string "#fff"; 137 | ctx##moveTo 34.0 (top +. control_height /. 2.); 138 | ctx##lineTo 62.0 (top +. control_height /. 2.); 139 | ctx##moveTo 66.0 (top +. control_height /. 2.); 140 | ctx##lineTo 94.0 (top +. control_height /. 2.); 141 | ctx##moveTo 80.0 top; 142 | ctx##lineTo 80.0 (Mtv_view.view_height v +. control_height); 143 | ctx##stroke; 144 | ctx##beginPath; 145 | (* Hamburger *) 146 | let spacing = control_height /. 4.0 in 147 | for i = 1 to 3 do 148 | let y = top +. spacing *. float_of_int i in 149 | ctx##moveTo 2.0 y; 150 | ctx##lineTo 30.0 y; 151 | done; 152 | ctx##stroke; 153 | ctx##beginPath; 154 | (* Scrollbar *) 155 | let xsize, _well_width, xstart = hscroll_values () in 156 | ctx##.fillStyle := Js.string "#fff"; 157 | ctx##rect xstart top xsize control_height; 158 | ctx##fill; 159 | ctx##beginPath 160 | in 161 | 162 | let render_queued = ref false in 163 | let render_now () = 164 | render_queued := false; 165 | let ctx = c##getContext(Dom_html._2d_) in 166 | ctx##.font := Js.string (Printf.sprintf "%.0fpx Sans" Canvas.font_size); 167 | R.render v ctx ~expose_area:((0.0, 0.0), (float_of_int c##.width, float_of_int c##.height)); 168 | draw_controls ctx in 169 | 170 | let render () = 171 | if not (!render_queued) then ( 172 | let _id : Dom_html.animation_frame_request_id = Dom_html.window##requestAnimationFrame (Js.wrap_callback (fun _ev -> render_now ())) in 173 | render_queued := true 174 | ) in 175 | 176 | let motion_id = ref None in 177 | let mouse_timeout = ref None in 178 | let cancel_mouse_timeouts () = 179 | begin match !mouse_timeout with 180 | | None -> () 181 | | Some t -> Dom_html.window##clearTimeout (t); mouse_timeout := None end; 182 | begin match !motion_id with 183 | | None -> () 184 | | Some id -> Dom_html.removeEventListener id; motion_id := None end in 185 | 186 | let last_focal_x = ref 0.0 in (* Focus for zoom buttons *) 187 | let button_zoom factor = 188 | let zoom factor = 189 | let t_old = Mtv_view.time_of_x v !last_focal_x in 190 | Mtv_view.zoom v factor; 191 | let t_new = Mtv_view.time_of_x v !last_focal_x in 192 | let _hscroll = Mtv_view.set_start_time v (Mtv_view.view_start_time v -. (t_new -. t_old)) in 193 | render () in 194 | 195 | let rec timeout _t = 196 | zoom factor; 197 | cancel_mouse_timeouts (); 198 | mouse_timeout := Some (Dom_html.window##setTimeout (Js.wrap_callback timeout) 50.0) in 199 | 200 | zoom factor; 201 | cancel_mouse_timeouts (); 202 | mouse_timeout := Some (Dom_html.window##setTimeout (Js.wrap_callback timeout) 500.0) in 203 | 204 | let show_side_panel () = 205 | let open Tyxml_js.Html5 in 206 | let input = Tyxml_js.Html5.input in 207 | let search ev = 208 | Js.Opt.iter ev##.target (fun entry -> 209 | Js.Opt.iter (Dom_html.CoerceTo.input entry) (fun entry -> 210 | begin match entry##.value |> Js.to_string with 211 | | "" -> Mtv_view.(set_highlights v ThreadSet.empty) 212 | | text -> 213 | let re = Regexp.regexp_string_case_fold text in 214 | let query label = 215 | Regexp.search_forward re label 0 <> None in 216 | Mtv_view.highlight_matches v query end; 217 | render () 218 | ) 219 | ); 220 | true in 221 | let keyup ev = 222 | if ev##.keyCode = 13 then Modal.close (); 223 | true in 224 | let search_box = input ~a:[a_placeholder "Search"; a_name "search"; a_onkeyup keyup; a_oninput search] () in 225 | auto_focus search_box; 226 | let show_metrics_attrs = 227 | if Mtv_view.show_metrics v then [a_checked ()] else [] in 228 | let set_show_metrics _ev = 229 | Mtv_view.set_show_metrics v (not (Mtv_view.show_metrics v)); 230 | render (); 231 | false in 232 | let metric_toggles = 233 | Mtv_view.vat v |> Mtv_thread.counters |> List.map (fun c -> 234 | let checked = if c.Mtv_counter.shown then [a_checked ()] else [] in 235 | let toggle_metric _ev = 236 | Mtv_counter.(c.shown <- not c.shown); 237 | render (); 238 | false in 239 | li [ 240 | label [ 241 | input ~a:(a_input_type `Checkbox :: a_onchange toggle_metric :: checked) (); 242 | txt c.Mtv_counter.name 243 | ] 244 | ] 245 | ) in 246 | let elem = ( 247 | div ~a:[a_class ["side-panel"]] [ 248 | div [ 249 | div [search_box]; 250 | hr (); 251 | div [ 252 | label [ 253 | input ~a:(a_input_type `Checkbox :: a_name "show_metrics" :: a_onchange set_show_metrics :: show_metrics_attrs) (); 254 | txt "Show metrics"]; 255 | ]; 256 | ul ~a:[a_class ["metrics"]] metric_toggles; 257 | hr (); 258 | button ~a:[a_onclick (fun _ev -> Modal.close (); false)] [txt "Close"] 259 | ] 260 | ] 261 | ) in 262 | let node = modal##appendChild (Tyxml_js.To_dom.of_node elem) in 263 | let close () = 264 | modal##removeChild (node) |> ignore; 265 | focus c in 266 | Modal.show ~close modal in 267 | 268 | let control_click ~x = 269 | if x < 32. then ( 270 | show_side_panel (); 271 | ) else if x < 64. then ( 272 | button_zoom (1. /. 1.2); 273 | ) else if x < 96. then ( 274 | button_zoom 1.2; 275 | ) else ( 276 | let top_thread = Mtv_thread.top_thread (Mtv_view.vat v) in 277 | let time_range = Mtv_thread.end_time top_thread -. Mtv_thread.start_time top_thread in 278 | let scroll_to_x x = 279 | let xsize, well_width, _ = hscroll_values () in 280 | let x = x -. xsize /. 2. in 281 | let frac = (x -. 96.) /. well_width in 282 | Mtv_view.set_start_time v (Mtv_thread.start_time top_thread +. time_range *. frac) |> ignore; 283 | Dom_html.window##setTimeout (Js.wrap_callback (fun _ev -> render ())) 10.0 |> ignore in 284 | 285 | scroll_to_x x; 286 | 287 | let last_x = ref x in 288 | let motion (ev:Dom_html.mouseEvent Js.t) = 289 | let (new_x, _y) = rel_event_coords ev in 290 | if new_x <> !last_x then scroll_to_x new_x; 291 | last_x := new_x; 292 | Js._false in 293 | 294 | cancel_mouse_timeouts (); 295 | motion_id := Some (Dom_html.addEventListener c Dom_html.Event.mousemove (Dom_html.handler motion) (Js._true)) 296 | ) in 297 | 298 | let resize () = 299 | let view_width = c##.clientWidth in 300 | let view_height = c##.clientHeight in 301 | c##.width := view_width; 302 | c##.height := view_height; 303 | let view_width = float_of_int view_width in 304 | let view_height = float_of_int view_height in 305 | Mtv_view.set_size v view_width (view_height -. control_height); 306 | render () in 307 | 308 | let zoom (ev:Dom_html.mouseEvent Js.t) ~dx:_ ~dy = 309 | let (x, _) = rel_event_coords ev in 310 | last_focal_x := x; 311 | let t_at_pointer = Mtv_view.time_of_x v x in 312 | 313 | if dy < 0 then 314 | Mtv_view.zoom v 1.2 315 | else 316 | Mtv_view.zoom v (1. /. 1.2); 317 | let t_new_at_pointer = Mtv_view.time_of_x v x in 318 | let _hscroll = Mtv_view.set_start_time v (Mtv_view.view_start_time v -. (t_new_at_pointer -. t_at_pointer)) in 319 | render (); 320 | Js._false in 321 | 322 | (* (also called for leave events) *) 323 | let mouse_up _ev = 324 | cancel_mouse_timeouts (); 325 | Js._false in 326 | 327 | let mouse_down (ev:Dom_html.mouseEvent Js.t) = 328 | focus c; 329 | let (x, y) = rel_event_coords ev in 330 | if y >= Mtv_view.view_height v then control_click ~x 331 | else ( 332 | let start_time = Mtv_view.time_of_x v x in 333 | let start_y = Mtv_view.y_of_view_y v y in 334 | last_focal_x := x; 335 | 336 | let motion (ev:Dom_html.mouseEvent Js.t) = 337 | let (x, y) = rel_event_coords ev in 338 | last_focal_x := x; 339 | let time_at_pointer = Mtv_view.time_of_x v x in 340 | let y_at_pointer = Mtv_view.y_of_view_y v y in 341 | if time_at_pointer <> start_time || y_at_pointer <> start_y then ( 342 | Mtv_view.set_start_time v (start_time -. Mtv_view.timespan_of_width v x) |> ignore; 343 | Mtv_view.set_view_y_so v start_y y |> ignore; 344 | Dom_html.window##setTimeout (Js.wrap_callback (fun _ev -> render ())) 10.0 |> ignore 345 | ); 346 | Js._false in 347 | 348 | cancel_mouse_timeouts (); 349 | motion_id := Some (Dom_html.addEventListener c Dom_html.Event.mousemove (Dom_html.handler motion) (Js._true)) 350 | ); 351 | Js._false in 352 | 353 | let double_click ev = 354 | let (x, y) = rel_event_coords ev in 355 | begin match Mtv_view.thread_at v ~x ~y with 356 | | Some thread -> 357 | Mtv_view.highlight_related v thread; 358 | Dom_html.window##setTimeout (Js.wrap_callback (fun _ev -> render ())) 10.0 |> ignore 359 | | None -> () end; 360 | let t_min = Mtv_view.view_start_time v in 361 | let t_max = t_min +. Mtv_view.timespan_of_width v (Mtv_view.view_width v) in 362 | Printf.printf "?t_min=%f&t_max=%f\n" t_min t_max; 363 | Js._false in 364 | 365 | let touches ts = 366 | let l = ts##.length in 367 | let rec aux acc i = 368 | if i = l then List.rev acc else ( 369 | Js.Optdef.case (ts##item i) (fun () -> List.rev acc) 370 | (fun t -> aux (t :: acc) (i + 1)) 371 | ) in 372 | aux [] 0 in 373 | 374 | let touch = ref Touch_none in 375 | let touch_change (ev:Dom_html.touchEvent Js.t) = 376 | Dom.preventDefault ev; 377 | begin match touches ev##.touches with 378 | | [t] -> 379 | let (x, y) = rel_event_coords t in 380 | if y >= Mtv_view.view_height v then control_click ~x 381 | else ( 382 | last_focal_x := x; 383 | touch := Touch_drag ( 384 | Mtv_view.time_of_x v x, 385 | Mtv_view.view_y_of_y v y 386 | ) 387 | ) 388 | | [t0; t1] -> 389 | let (x0, _) = rel_event_coords t0 in 390 | let (x1, _) = rel_event_coords t1 in 391 | last_focal_x := x0; 392 | touch := Touch_zoom ( 393 | (Mtv_view.time_of_x v x0), 394 | (Mtv_view.time_of_x v x1) 395 | ) 396 | | _ -> 397 | cancel_mouse_timeouts (); 398 | touch := Touch_none end; 399 | Js._false in 400 | 401 | let touch_move (ev:Dom_html.touchEvent Js.t) = 402 | begin match !touch, touches ev##.touches with 403 | | Touch_drag (start_time, start_y), [touch] -> 404 | let x_new, view_y_new = rel_event_coords touch in 405 | last_focal_x := x_new; 406 | let t_new = Mtv_view.x_of_time v x_new in 407 | let y_new = Mtv_view.y_of_view_y v view_y_new in 408 | if t_new <> start_time || start_y <> y_new then ( 409 | Mtv_view.set_start_time v (start_time -. Mtv_view.timespan_of_width v x_new) |> ignore; 410 | Mtv_view.set_view_y_so v start_y view_y_new |> ignore; 411 | Dom_html.window##setTimeout (Js.wrap_callback (fun _ev -> render ())) 10.0 |> ignore 412 | ) 413 | | Touch_zoom (start_t0, start_t1), [touch0; touch1] -> 414 | let (x0, _) = rel_event_coords touch0 in 415 | let (x1, _) = rel_event_coords touch1 in 416 | last_focal_x := x0; 417 | Mtv_view.set_start_time v (start_t0 -. Mtv_view.timespan_of_width v x0) |> ignore; 418 | Mtv_view.set_scale v ((x1 -. x0) /. (start_t1 -. start_t0)); 419 | Dom_html.window##setTimeout (Js.wrap_callback (fun _ev -> render ())) 10.0 |> ignore 420 | | _ -> () 421 | end; 422 | Js._false in 423 | 424 | let key_press ev = 425 | if Modal.is_open () then Js._true 426 | else match Js.Optdef.map ev##.charCode Char.chr |> Js.Optdef.to_option with 427 | | Some ' ' -> 428 | Mtv_view.set_show_metrics v (not (Mtv_view.show_metrics v)); 429 | render (); 430 | Js._false 431 | | Some '/' -> 432 | show_side_panel (); 433 | Js._false 434 | | _ -> Js._true in 435 | 436 | Dom_html.addMousewheelEventListener c zoom (Js.bool true) |> ignore; 437 | c##.ondblclick := Dom_html.handler double_click; 438 | c##.onmousedown := Dom_html.handler mouse_down; 439 | c##.onmouseup := Dom_html.handler mouse_up; 440 | c##.onmouseout := Dom_html.handler mouse_up; 441 | 442 | Dom_html.addEventListener c Dom_html.Event.touchstart (Dom_html.handler touch_change) (Js.bool true) |> ignore; 443 | Dom_html.addEventListener c Dom_html.Event.touchmove (Dom_html.handler touch_move) (Js.bool true) |> ignore; 444 | Dom_html.addEventListener c Dom_html.Event.touchend (Dom_html.handler touch_change) (Js.bool true) |> ignore; 445 | Dom_html.addEventListener c Dom_html.Event.touchcancel (Dom_html.handler touch_change) (Js.bool true) |> ignore; 446 | Dom_html.addEventListener c Dom_html.Event.keypress (Dom_html.handler key_press) (Js.bool true) |> ignore; 447 | 448 | if grab_focus then focus c; 449 | 450 | let resize_false _ = resize (); Js._false in 451 | Dom_html.addEventListener Dom_html.window Dom_html.Event.resize (Dom_html.handler resize_false) (Js.bool true) |> ignore; 452 | resize_callbacks := resize :: !resize_callbacks; 453 | resize () 454 | 455 | let load ?grab_focus ?file ?metrics ?range name = 456 | let file = 457 | match file with 458 | | Some file -> file 459 | | None -> Printf.sprintf "/static/%s.bin" name in 460 | let ch = open_in file in 461 | let v = Marshal.from_channel ch in 462 | close_in ch; 463 | begin match range with 464 | | None -> () 465 | | Some (t_min, t_max) -> 466 | let scale = (Mtv_view.view_width v -. Mtv_view.h_margin *. 2.) /. (t_max -. t_min) in 467 | Mtv_view.set_scale v scale; 468 | Mtv_view.set_start_time v t_min |> ignore end; 469 | begin match metrics with 470 | | None -> () 471 | | Some metrics -> 472 | Mtv_view.vat v |> Mtv_thread.counters |> List.iter (fun counter -> 473 | counter.Mtv_counter.shown <- List.mem counter.Mtv_counter.name metrics; 474 | ); 475 | end; 476 | try 477 | match Dom_html.tagged (Dom_html.getElementById name) with 478 | | Dom_html.Canvas c -> attach ?grab_focus c v 479 | | _ -> raise Not_found 480 | with Not_found -> 481 | failwith (Printf.sprintf "Canvas element '%s' not found in DOM" name) 482 | -------------------------------------------------------------------------------- /lib/mtv_render.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2014, Thomas Leonard *) 2 | 3 | module type CANVAS = sig 4 | type context 5 | type text_extents = { 6 | x_bearing : float; 7 | y_bearing : float; 8 | width : float; 9 | height : float; 10 | x_advance : float; 11 | y_advance : float; 12 | } 13 | 14 | val set_line_width : context -> float -> unit 15 | val set_source_rgb : context -> r:float -> g:float -> b:float -> unit 16 | val set_source_rgba : context -> r:float -> g:float -> b:float -> a:float -> unit 17 | (* (Cairo needs to know the r,g,b too) *) 18 | val set_source_alpha : context -> r:float -> g:float -> b:float -> float -> unit 19 | val move_to : context -> x:float -> y:float -> unit 20 | val line_to : context -> x:float -> y:float -> unit 21 | val rectangle : context -> x:float -> y:float -> w:float -> h:float -> unit 22 | val stroke : context -> unit 23 | val stroke_preserve : context -> unit 24 | val fill : context -> unit 25 | val text_extents : context -> string -> text_extents 26 | val paint_text : context -> ?clip_area:(float * float) -> x:float -> y:float -> string -> unit 27 | val paint : ?alpha:float -> context -> unit 28 | end 29 | 30 | (* Find a place to put the label for the next stat line, ideally close to y. *) 31 | let insert_label y stat_labels = 32 | let rec aux (y:float) = function 33 | | [] -> y, [y] 34 | | y2 :: ys when y +. 16. < y2 -> y, (y :: y2 :: ys) 35 | | y2 :: ys -> 36 | let y, ys = aux (max y (y2 +. 16.)) ys in 37 | y, (y2 :: ys) in 38 | let y, new_stats = aux y !stat_labels in 39 | stat_labels := new_stats; 40 | y 41 | 42 | module Make (C : CANVAS) = struct 43 | let arrow_width = 4. 44 | let arrow_height = 10. 45 | 46 | let thin cr = C.set_line_width cr 1.0 47 | 48 | let thread_label cr = 49 | C.set_source_rgb cr ~r:0.0 ~g:0.0 ~b:0.0 50 | 51 | let type_label cr = 52 | C.set_source_rgb cr ~r:0.5 ~g:0.5 ~b:0.5 53 | 54 | let counter_line_width = 5.0 55 | 56 | let counter_shadow cr = 57 | C.set_source_rgb cr ~r:0.0 ~g:0.0 ~b:0.0; 58 | C.set_line_width cr 5.0 59 | 60 | let counter_line i cr = 61 | C.set_line_width cr 3.0; 62 | match i mod 4 with 63 | | 0 -> C.set_source_rgb cr ~r:1.0 ~g:0.4 ~b:0.4 64 | | 1 -> C.set_source_rgb cr ~r:1.0 ~g:0.5 ~b:0.0 65 | | 2 -> C.set_source_rgb cr ~r:0.4 ~g:0.8 ~b:0.8 66 | | _ -> C.set_source_rgb cr ~r:0.8 ~g:0.4 ~b:1.0 67 | 68 | let anonymous_thread cr = 69 | C.set_line_width cr 2.0; 70 | C.set_source_rgb cr ~r:0.6 ~g:0.6 ~b:0.6 71 | 72 | let highlight cr = 73 | C.set_source_rgb cr ~r:1.0 ~g:1.0 ~b:0.0 74 | 75 | let named_thread cr = 76 | C.set_line_width cr 2.0; 77 | C.set_source_rgb cr ~r:0.2 ~g:0.2 ~b:0.2 78 | 79 | let failed cr = 80 | C.set_line_width cr 2.0; 81 | C.set_source_rgb cr ~r:0.8 ~g:0.0 ~b:0.0 82 | 83 | let activation cr = 84 | C.set_line_width cr 3.0; 85 | C.set_source_rgb cr ~r:1.0 ~g:1.0 ~b:1.0 86 | 87 | let line v cr time src recv = 88 | C.move_to cr ~x:(Mtv_view.x_of_time v time) ~y:(Mtv_view.y_of_thread v src); 89 | C.line_to cr ~x:(Mtv_view.x_of_time v time) ~y:(Mtv_view.y_of_thread v recv); 90 | C.stroke cr 91 | 92 | let draw_arrow_head_v cr ~x ~y ~arrow_head_y = 93 | C.line_to cr ~x ~y:arrow_head_y; 94 | C.stroke cr; 95 | C.move_to cr ~x ~y; 96 | C.line_to cr ~x:(x +. arrow_width) ~y:arrow_head_y; 97 | C.line_to cr ~x:(x -. arrow_width) ~y:arrow_head_y; 98 | C.fill cr 99 | 100 | let draw_arrow_head_h cr ~x ~y ~arrow_head_x = 101 | C.line_to cr ~x:arrow_head_x ~y; 102 | C.stroke cr; 103 | C.move_to cr ~x ~y; 104 | C.line_to cr ~x:arrow_head_x ~y:(y +. arrow_width); 105 | C.line_to cr ~x:arrow_head_x ~y:(y -. arrow_width); 106 | C.fill cr 107 | 108 | let arrow v cr src src_time recv recv_time (r, g, b) = 109 | let width = Mtv_view.width_of_timespan v (recv_time -. src_time) in 110 | let alpha = 1.0 -. (min 1.0 (width /. 6000.)) in 111 | if alpha > 0.01 then ( 112 | C.set_source_alpha cr ~r ~g ~b alpha; 113 | 114 | if Mtv_thread.id src <> -1 && Mtv_thread.id src <> Mtv_thread.id recv then ( 115 | let src_x = Mtv_view.clip_x_of_time v src_time in 116 | let src_y = Mtv_view.y_of_thread v src in 117 | let recv_y = Mtv_view.y_of_thread v recv in 118 | 119 | C.move_to cr ~x:src_x ~y:src_y; 120 | 121 | let x = Mtv_view.clip_x_of_time v recv_time in 122 | let d = recv_y -. src_y in 123 | if d < -.arrow_height then draw_arrow_head_v cr ~x ~y:recv_y ~arrow_head_y:(recv_y +. arrow_height) 124 | else if d > arrow_height then draw_arrow_head_v cr ~x ~y:recv_y ~arrow_head_y:(recv_y -. arrow_height) 125 | else draw_arrow_head_h cr ~x ~y:recv_y ~arrow_head_x:(x -. arrow_height) 126 | ) 127 | ) 128 | 129 | let draw_grid v cr area_start_x area_end_x = 130 | C.set_line_width cr 1.0; 131 | C.set_source_rgb cr ~r:0.7 ~g:0.7 ~b:0.7; 132 | 133 | let grid_step = Mtv_view.grid_step v in 134 | let top = 0.0 in 135 | let bottom = Mtv_view.view_height v in 136 | 137 | let area_start_time = Mtv_view.time_of_x v area_start_x in 138 | let grid_start_x = floor (area_start_time /. grid_step) *. grid_step |> Mtv_view.x_of_time v in 139 | let grid_step_x = Mtv_view.width_of_timespan v grid_step in 140 | let rec draw x = 141 | if x < area_end_x then ( 142 | C.move_to cr ~x:x ~y:top; 143 | C.line_to cr ~x:x ~y:bottom; 144 | C.stroke cr; 145 | draw (x +. grid_step_x) 146 | ) in 147 | draw grid_start_x; 148 | C.set_source_rgb cr ~r:0.4 ~g:0.4 ~b:0.4; 149 | let msg = 150 | if grid_step >= 1.0 then Printf.sprintf "Each grid division: %.0f s" grid_step 151 | else if grid_step >= 0.001 then Printf.sprintf "Each grid division: %.0f ms" (grid_step *. 1000.) 152 | else if grid_step >= 0.000_001 then Printf.sprintf "Each grid division: %.0f us" (grid_step *. 1_000_000.) 153 | else if grid_step >= 0.000_000_001 then Printf.sprintf "Each grid division: %.0f ns" (grid_step *. 1_000_000_000.) 154 | else Printf.sprintf "Each grid division: %.2g s" grid_step in 155 | let extents = C.text_extents cr msg in 156 | let y = bottom -. C.(extents.height +. extents.y_bearing) -. 2.0 in 157 | C.paint_text cr ~x:4.0 ~y msg 158 | 159 | let draw_mark cr x y = 160 | C.move_to cr ~x ~y; 161 | C.line_to cr ~x ~y:(y +. 6.); 162 | C.stroke cr 163 | 164 | (** Draw [msg] in the area (min_x, max_x) and ideally centred at [x]. *) 165 | let draw_label cr ~v ~y ~min_x ~max_x x msg = 166 | let text_width = C.((text_extents cr msg).x_advance) in 167 | let x = 168 | x -. (text_width /. 2.) (* Desired start for centred text *) 169 | |> min (max_x -. text_width) 170 | |> max min_x in 171 | 172 | if x +. text_width > max_x then ( 173 | (* Doesn't fit. Draw as much as we can. *) 174 | C.paint_text cr ~x:min_x ~y ~clip_area:(max_x -. x, Mtv_view.view_height v) msg; 175 | max_x 176 | ) else ( 177 | (* Show label on left margin if the thread starts off-screen *) 178 | let x = 179 | if x < 4.0 then min 4.0 (max_x -. text_width) 180 | else x in 181 | C.paint_text cr ~x ~y msg; 182 | x +. text_width 183 | ) 184 | 185 | let rec draw_labels cr ~v ~y ~min_x ~max_x = function 186 | | [] -> () 187 | | [(time, msg)] -> 188 | let x = Mtv_view.clip_x_of_time v time in 189 | let _end : float = draw_label cr ~v ~y ~min_x ~max_x x msg in 190 | draw_mark cr x y; 191 | () 192 | | (t1, msg1) :: (((t2, _msg2) :: _) as rest) -> 193 | let x1 = Mtv_view.clip_x_of_time v t1 in 194 | let x2 = Mtv_view.clip_x_of_time v t2 in 195 | let min_x = draw_label cr ~v ~y ~min_x ~max_x:x2 x1 msg1 in 196 | draw_mark cr x1 y; 197 | draw_labels cr ~v ~y ~min_x ~max_x rest 198 | 199 | let render v cr ~expose_area = 200 | let vat = Mtv_view.vat v in 201 | let top_thread = Mtv_thread.top_thread vat in 202 | let ((expose_min_x, expose_min_y), (expose_max_x, expose_max_y)) = expose_area in 203 | 204 | (* Note: switching drawing colours is really slow with HTML canvas, so we try to group by colour. *) 205 | 206 | C.set_source_rgb cr ~r:0.9 ~g:0.9 ~b:0.9; 207 | C.paint cr; 208 | 209 | let region_labels = ref [] in 210 | 211 | (* When the system thread is "active", the system is idle. *) 212 | C.set_source_rgb cr ~r:0.8 ~g:0.8 ~b:0.8; 213 | Mtv_thread.activations top_thread |> List.iter (fun (start_time, end_time) -> 214 | let start_x = Mtv_view.clip_x_of_time v start_time in 215 | let end_x = Mtv_view.clip_x_of_time v end_time in 216 | if end_x >= expose_min_x && start_x < expose_max_x then ( 217 | C.rectangle cr ~x:start_x ~y:expose_min_y ~w:(end_x -. start_x) ~h:expose_max_y; 218 | C.fill cr; 219 | if end_x -. start_x > 16. then region_labels := (start_x, end_x, "sleeping") :: !region_labels 220 | ) 221 | ); 222 | 223 | C.set_source_rgb cr ~r:0.7 ~g:0.6 ~b:0.6; 224 | Mtv_thread.gc_periods vat |> List.iter (fun (start_time, end_time) -> 225 | let start_x = Mtv_view.clip_x_of_time v start_time in 226 | let end_x = Mtv_view.clip_x_of_time v end_time in 227 | if end_x >= expose_min_x && start_x < expose_max_x then ( 228 | C.rectangle cr ~x:start_x ~y:expose_min_y ~w:(end_x -. start_x) ~h:expose_max_y; 229 | C.fill cr; 230 | if end_x -. start_x > 16. then region_labels := (start_x, end_x, "GC") :: !region_labels 231 | ) 232 | ); 233 | 234 | C.set_source_rgb cr ~r:1.0 ~g:1.0 ~b:1.0; 235 | !region_labels |> List.iter (fun (min_x, max_x, label) -> 236 | let x = (min_x +. max_x) /. 2. in 237 | draw_label cr ~v ~y:14.0 ~min_x ~max_x x label |> ignore 238 | ); 239 | 240 | draw_grid v cr expose_min_x expose_max_x; 241 | 242 | (* Draw the thread lines. *) 243 | let failed_thread_lines = ref [] in 244 | let draw_thread_line start_x end_x y = 245 | C.move_to cr ~x:start_x ~y; 246 | C.line_to cr ~x:end_x ~y; 247 | C.stroke cr in 248 | let visible_t_min = Mtv_view.time_of_x v expose_min_x in 249 | let visible_t_max = Mtv_view.time_of_x v expose_max_x in 250 | let visible_threads = Mtv_view.visible_threads v (visible_t_min, visible_t_max) in 251 | 252 | let highlights = Mtv_view.highlights v in 253 | let short_highlights = ref [] in 254 | if not (Mtv_view.ThreadSet.is_empty highlights) then ( 255 | highlight cr; 256 | visible_threads |> Mtv_layout.IT.IntervalSet.iter (fun i -> 257 | let t = i.Interval_tree.Interval.value in 258 | if Mtv_view.ThreadSet.mem t highlights then ( 259 | let start_x = Mtv_view.clip_x_of_time v (Mtv_thread.start_time t) in 260 | let end_x = Mtv_view.clip_x_of_time v (Mtv_thread.end_time t) in 261 | let y = Mtv_view.y_of_thread v t in 262 | if end_x -. start_x < 32.0 then short_highlights := (start_x, end_x, y) :: !short_highlights 263 | else ( 264 | C.rectangle cr ~x:start_x ~y:(y -. 4.0) ~w:(end_x -. start_x) ~h:8.0; 265 | C.fill cr; 266 | ); 267 | match Mtv_thread.becomes t with 268 | | Some child when Mtv_thread.y child <> Mtv_thread.y t && Mtv_view.ThreadSet.mem child highlights -> 269 | let h = Mtv_view.y_of_thread v child -. y in 270 | C.rectangle cr ~x:(end_x -. 4.0) ~y:(y -. 4.0) ~w:8.0 ~h:(h +. 8.0); 271 | C.fill cr 272 | | _ -> () 273 | ) 274 | ) 275 | ); 276 | 277 | named_thread cr; 278 | visible_threads |> Mtv_layout.IT.IntervalSet.iter (fun i -> 279 | let t = i.Interval_tree.Interval.value in 280 | let start_x = Mtv_view.clip_x_of_time v (Mtv_thread.start_time t) in 281 | let end_x = Mtv_view.clip_x_of_time v (Mtv_thread.end_time t) in 282 | let y = Mtv_view.y_of_thread v t in 283 | if Mtv_thread.failure t = None then draw_thread_line start_x end_x y 284 | else failed_thread_lines := (start_x, end_x, y) :: !failed_thread_lines; 285 | Mtv_thread.creates t |> List.iter (fun child -> 286 | let child_start_time = Mtv_thread.start_time child in 287 | if Mtv_thread.show_creation child then 288 | line v cr child_start_time t child 289 | ); 290 | match Mtv_thread.becomes t with 291 | | Some child when Mtv_thread.y child <> Mtv_thread.y t -> 292 | line v cr (Mtv_thread.end_time t) t child 293 | | None when not (Mtv_thread.resolved t) && end_x -. start_x > 4.0 -> 294 | C.move_to cr ~x:end_x ~y; 295 | C.line_to cr ~x:(end_x -. 6.) ~y:(y -. 4.); 296 | C.line_to cr ~x:(end_x -. 6.) ~y:(y +. 4.); 297 | C.fill cr; 298 | | _ -> () 299 | ); 300 | 301 | activation cr; 302 | visible_threads |> Mtv_layout.IT.IntervalSet.iter (fun i -> 303 | let t = i.Interval_tree.Interval.value in 304 | let y = Mtv_view.y_of_thread v t in 305 | Mtv_thread.activations t |> List.iter (fun (start_time, end_time) -> 306 | C.move_to cr ~x:(max expose_min_x (Mtv_view.clip_x_of_time v start_time)) ~y; 307 | C.line_to cr ~x:(min expose_max_x (Mtv_view.clip_x_of_time v end_time)) ~y; 308 | C.stroke cr; 309 | ) 310 | ); 311 | 312 | (* Arrows that are only just off screen can still be visible, so extend the 313 | * window slightly. Once we get wider than a screen width, they become invisible anyway. *) 314 | let view_timespace = Mtv_view.timespan_of_width v (Mtv_view.view_width v) in 315 | let vis_arrows_min = visible_t_min -. view_timespace in 316 | let vis_arrows_max = visible_t_max +. view_timespace in 317 | thin cr; 318 | let c = (0.8, 0.8, 0.4) in 319 | begin let r, g, b = c in C.set_source_rgb cr ~r ~g ~b end; 320 | Mtv_view.iter_interactions v vis_arrows_min vis_arrows_max (fun (t, start_time, op, other, end_time) -> 321 | match op with 322 | | Mtv_thread.Try_read -> arrow v cr t start_time other end_time c 323 | | _ -> () 324 | ); 325 | let c = (0.0, 0.0, 1.0) in 326 | begin let r, g, b = c in C.set_source_rgb cr ~r ~g ~b end; 327 | Mtv_view.iter_interactions v vis_arrows_min vis_arrows_max (fun (t, start_time, op, other, end_time) -> 328 | match op with 329 | | Mtv_thread.Read when Mtv_thread.failure other = None -> arrow v cr other end_time t start_time c 330 | | _ -> () 331 | ); 332 | let c = (1.0, 0.0, 0.0) in 333 | begin let r, g, b = c in C.set_source_rgb cr ~r ~g ~b end; 334 | Mtv_view.iter_interactions v vis_arrows_min vis_arrows_max (fun (t, start_time, op, other, end_time) -> 335 | match op with 336 | | Mtv_thread.Read when Mtv_thread.failure other <> None -> arrow v cr other end_time t start_time c 337 | | _ -> () 338 | ); 339 | let c = (0.0, 0.5, 0.0) in 340 | begin let r, g, b = c in C.set_source_rgb cr ~r ~g ~b end; 341 | Mtv_view.iter_interactions v vis_arrows_min vis_arrows_max (fun (t, start_time, op, other, end_time) -> 342 | match op with 343 | | Mtv_thread.Resolve when Mtv_thread.id t <> -1 -> arrow v cr t start_time other end_time c 344 | | _ -> () 345 | ); 346 | let c = (1.0, 0.6, 0.0) in 347 | begin let r, g, b = c in C.set_source_rgb cr ~r ~g ~b end; 348 | Mtv_view.iter_interactions v vis_arrows_min vis_arrows_max (fun (t, start_time, op, other, end_time) -> 349 | match op with 350 | | Mtv_thread.Signal -> arrow v cr t start_time other end_time c 351 | | _ -> () 352 | ); 353 | 354 | let text_visible t = 355 | let vert_dist = Mtv_view.dist_from_focus v t in 356 | vert_dist > -.2000. && vert_dist < 2000. in 357 | 358 | thread_label cr; 359 | visible_threads |> Mtv_layout.IT.IntervalSet.iter (fun i -> 360 | let t = i.Interval_tree.Interval.value in 361 | let start_x = Mtv_view.x_of_start v t +. 2. in 362 | let end_x = Mtv_view.x_of_end v t in 363 | let thread_width = end_x -. start_x in 364 | if thread_width > 16. && text_visible t then ( 365 | let y = Mtv_view.y_of_thread v t -. 3.0 in 366 | let end_x = 367 | match Mtv_thread.becomes t with 368 | | Some child when Mtv_thread.y child = Mtv_thread.y t -> Mtv_view.x_of_start v child 369 | | _ -> end_x in 370 | draw_labels cr ~v ~y ~min_x:start_x ~max_x:(min end_x (Mtv_view.view_width v)) (Mtv_thread.labels t) 371 | ) 372 | ); 373 | 374 | let text_visible t = 375 | let vert_dist = Mtv_view.dist_from_focus v t in 376 | vert_dist > -.1000. && vert_dist < 1000. in 377 | 378 | type_label cr; 379 | visible_threads |> Mtv_layout.IT.IntervalSet.iter (fun i -> 380 | let t = i.Interval_tree.Interval.value in 381 | let start_x = Mtv_view.x_of_start v t +. 2. in 382 | let end_x = Mtv_view.x_of_end v t in 383 | let thread_width = end_x -. start_x in 384 | if thread_width > 16. && text_visible t then ( 385 | let y = Mtv_view.y_of_thread v t +. 10.0 in 386 | let end_x = 387 | match Mtv_thread.becomes t with 388 | | Some child when Mtv_thread.y child = Mtv_thread.y t -> Mtv_view.x_of_start v child 389 | | _ -> end_x in 390 | draw_label cr ~v ~y ~min_x:start_x ~max_x:end_x start_x (Mtv_thread.thread_type t) 391 | |> ignore; 392 | ) 393 | ); 394 | 395 | failed cr; 396 | !failed_thread_lines |> List.iter (fun (start_x, end_x, y) -> 397 | draw_thread_line start_x end_x y; 398 | C.move_to cr ~x:end_x ~y:(y -. 8.); 399 | C.line_to cr ~x:end_x ~y:(y +. 8.); 400 | C.stroke cr; 401 | ); 402 | 403 | if Mtv_view.show_metrics v then ( 404 | let stat_labels = ref [] in 405 | Mtv_thread.counters vat |> List.iteri (fun counter_i counter -> 406 | let open Mtv_counter in 407 | if counter.shown then ( 408 | let range = counter.scale.max -. counter.scale.min in 409 | let v_scale = (Mtv_view.view_height v -. (2.0 *. counter_line_width)) /. range in 410 | let v_offset = Mtv_view.view_height v +. (v_scale *. counter.scale.min) -. counter_line_width in 411 | let y_of_value value = v_offset -. v_scale *. value in 412 | 413 | let values = counter.values in 414 | let i = Mtv_sorted_array.count_before (fun (time, _v) -> time >= Mtv_view.view_start_time v) values in 415 | let first_visible = max (i - 1) 0 in 416 | let first_value = 417 | if i = 0 then 0.0 418 | else (snd values.(first_visible)) in 419 | let y = ref (y_of_value first_value) in 420 | C.move_to cr ~x:0.0 ~y:!y; 421 | begin try 422 | for i = first_visible to Array.length values - 1 do 423 | let time, value = Array.get values i in 424 | let x = Mtv_view.clip_x_of_time v time in 425 | C.line_to cr ~x ~y:!y; 426 | if x > Mtv_view.view_width v then raise Exit; 427 | let new_y = y_of_value value in 428 | C.line_to cr ~x ~y:new_y; 429 | y := new_y; 430 | done 431 | with Exit -> () end; 432 | C.line_to cr ~x:(Mtv_view.view_width v) ~y:!y; 433 | counter_shadow cr; 434 | C.stroke_preserve cr; 435 | counter_line counter_i cr; 436 | C.stroke cr; 437 | 438 | let y = insert_label (max 16. (!y -. 2.)) stat_labels in 439 | let max_x = Mtv_view.view_width v in 440 | draw_label cr ~v ~y ~min_x:0.0 ~max_x max_x counter.name |> ignore 441 | ) 442 | ); 443 | ); 444 | 445 | (* Draw these on top of everything else so they can still be seen *) 446 | if !short_highlights <> [] then ( 447 | highlight cr; 448 | !short_highlights |> List.iter (fun (start_x, end_x, y) -> 449 | C.rectangle cr ~x:(start_x -. 4.0) ~y:(y -. 4.0) ~w:(end_x +. 4.0 -. start_x) ~h:8.0; 450 | C.fill cr; 451 | ) 452 | ); 453 | 454 | end 455 | --------------------------------------------------------------------------------